qsort

Posted: 2002-06-01
By: ArchiveBot
Viewed: 87

Filed Under:

VB6 Code Cache

No attachments for this post

Want to sort 5,000 10-byte strings in about 1/10th of a second? This will do it (at least on my PII-233!). The insertion sort manages the same task in about 60 seconds (even when optimized it still took about 15 seconds on the same machine).

Original Author: Mike Shaffer

Inputs

strList (a string array)

Assumptions

Want to sort 5,000 10-byte strings in about 1/10th of a second? This will do it (at least on my PII-233!). The insertion sort manages the same task in about 60 seconds (even when optimized it still took about 15 seconds on the same machine).

Returns

strList (the same array - sorted)

API Declarations

Code

Public Function QSort(strList() As String, lLbound As Long, lUbound As Long)
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::'
':::                                :::'
'::: Routine:  QSort                       :::'
'::: Author:  Mike Shaffer (after Rod Stephens, et al.)     :::'
'::: Date:   21-May-98                     :::'
'::: Purpose:  Very fast sort of a string array         :::'
'::: Passed:  strList  String array              :::'
':::       lLbound  Lower bound to sort (usually 1)     :::'
':::       lUbound  Upper bound to sort (usually ubound()) :::'
'::: Returns:  strList  (in sorted order)            :::'
'::: Copyright: Copyright *c* 1998, Mike Shaffer         :::'
':::       ALL RIGHTS RESERVED WORLDWIDE           :::'
':::       Permission granted to use in any non-commercial  :::'
':::       product with credit where due. For free      :::'
':::       commercial license contact mshaffer@nkn.net    :::'
'::: Revisions: 22-May-98 Added and then dropped revision     :::'
':::       using CopyMemory rather than the simple swap   :::'
':::       when it was found to not provide much benefit.  :::'
':::                                :::'
':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::'
Dim strTemp As String
Dim strBuffer As String
Dim lngCurLow As Long
Dim lngCurHigh As Long
Dim lngCurMidpoint As Long

lngCurLow = lLbound              ' Start current low and high at actual low/high
lngCurHigh = lUbound

If lUbound <= lLbound Then Exit Function   ' Error!
lngCurMidpoint = (lLbound + lUbound) 2   ' Find the approx midpoint of the array
  
strTemp = strList(lngCurMidpoint)       ' Pick as a starting point (we are making
                        ' an assumption that the data *might* be
                        ' in semi-sorted order already!
  
Do While (lngCurLow <= lngCurHigh)
    
   Do While strList(lngCurLow) < strTemp
      lngCurLow = lngCurLow + 1
      If lngCurLow = lUbound Then Exit Do
   Loop
  
   Do While strTemp < strList(lngCurHigh)
      lngCurHigh = lngCurHigh - 1
      If lngCurHigh = lLbound Then Exit Do
   Loop
      
   If (lngCurLow <= lngCurHigh) Then     ' if low is <= high then swap
     strBuffer = strList(lngCurLow)
     strList(lngCurLow) = strList(lngCurHigh)
     strList(lngCurHigh) = strBuffer
     '
     lngCurLow = lngCurLow + 1       ' CurLow++
     lngCurHigh = lngCurHigh - 1      ' CurLow--
   End If
  
Loop
    
If lLbound < lngCurHigh Then         ' Recurse if necessary
   QSort strList(), lLbound, lngCurHigh
End If
    
If lngCurLow < lUbound Then          ' Recurse if necessary
    QSort strList(), lngCurLow, lUbound
End If

End Function


Comments on this post

No comments have been added for this post.

You must be logged in to make a comment.