PBWin/PBCC Sidewinder Sort – 2 to 3 times faster than PB sort

[Stanley Durham]

Sidewinder Sort – 2 to 3 times faster than PB sort

This is a Trie/Bucket sort

About 2.4 times faster than PB sort.
Over 3 times faster for string > 200 characters.
The longer the strings, the wider the spread.

Note: this is purely for those who like to play around with sort algorithms.
On 100,000 strings, you’ll save a fraction of a second.

This is a slight improvement over the “slot sort” I posted before.
(same sort with a little tuning)

The Burst Sort used to be the champ.
It was about twice as fast as the Quick Sort.
There are now variations of the Burst Sort that are 4 to 5 times faster than Quick Sort.
These sorts are also Trie based.
They are very complex sorts that focus on keeping the work in the CPU cache.
http://www.cs.mu.oz.au/~rsinha/paper...Zobel-2006.pdf

This sort uses recursive calls to build a Trie tree on the program stack.

I had a request for information on how to convert it to an UCase sort.
I tried, but couldn’t do it.

Public domain – use at your own risk

.

[Stanley Durham]

'pb 5/9
'SidewinderSort5.inc
    '
    '   Sidewinder String Sort
    '
    '   !!! zero-based arrays only !!!
    '
    '   the sort moves sideways through the string array, one character depth at a time
    '   - now makes three passes
    '   - uses two temporary arrays
    '       pArr2: used to store string pointers in proper bucket order
    '           pointers copied back to original array after bucket built
    '       charArr(): hold character at current depth - character ASCIIZ value used as indes
    '           charArr(i) = Peek(Byte, @pArr[i] + depth)
    '           storing index avoids having to to do expensive operation twice; Peek(Byte, @pArr[i] + depth)
    '               Peek(Byte, @pArr[i] + depth) = get byte from string ptr in @pArr[i] at depth
    '
    '   move all null string to left side of array before recursive sort starts - final destination
    '   Passes:
    '       1. get count for each different kind of character, at a given depth, for each string in array segment
    '           1a. build bucket information - where each string belongs in array
    '       2. goes through array and stores each string ptr in temp array in proper bucket
    '           (this turned out to be faster than swapping string pointers in place)
    '       3. copies string pointers back into original array
    '               now in sorted order for current depth
    '           3a. recursively sort each bucket
    '               skip bucket zero (end-of-string) now in final position
    '               skip buckets with only one string - in final position
    '
    '   if 5 strings in the array start with "a" (lowest strings in array)
    '       on the first pass; those 5 string would be on the left side of the array
    '           we then recursively work on those 5 strings, next character down, before moving to the next lowest group in the array
    '
'
#If Not %Def(%WINAPI)
    #Include Once "WIN32API.INC"
#EndIf
'
Type SidewinderSortBuckeyInfoT
    bucketSize(255) As Long
    bucketStart(255) As Long
    bucketEnd(255) As Long
End Type
'
'
'tix test macors
'''Macro McSidewinderTixStart1 = Local qTix_Counter1 As Quad : Tix qTix_Counter1
'''Macro McSidewinderTixEnd1
'''    Tix End qTix_Counter1
'''    #Debug Print "Tix #1 = "+ Format$(qTix_Counter1, "#,")
'''End Macro
'''Macro McSidewinderTixStart2 = Local qTix_Counter2 As Quad : Tix qTix_Counter2
'''Macro McSidewinderTixEnd2
'''    Tix End qTix_Counter2
'''    #Debug Print "Tix #2 = "+ Format$(qTix_Counter2, "#,")
'''End Macro
'
'
Sub SidewinderSort(arr() As String)
    Register i As Long
    Register leftSide As Long
    Local arrUBound, rightSide, depth As Long
    Local pArr, pArr2 As Long Ptr
    Local dummy(), charArr() As Long
    '
    arrUBound = UBound(arr)
    '
    If arrUBound < 1 Then Exit Sub
    '
    ReDim charArr(arrUBound)
    ReDim dummy(arrUBound)
    '
    rightSide = arrUBound
    leftSide = 0
    depth = 0
    pArr = VarPtr(arr(0))
    pArr2 = VarPtr(dummy(0))
    'swap any null strings to far left - they will be in their final position
    For i = 0 To rightSide
        If @pArr[i] = %NULL Then
            If i <> leftSide Then Swap @pArr[i], @pArr[leftSide]
            Incr leftSide
        End If
    Next i
    SidewinderSortRecursive pArr, pArr2, charArr(), depth, leftSide, rightSide
End Sub
'
'
'-------------------------------------------------------------------------------------------------------------------------------------------
    ' internal use
'-------------------------------------------------------------------------------------------------------------------------------------------
'
Sub SidewinderSortRecursive(ByVal pArr As Long Ptr, ByVal pArr2 As Long Ptr, charArr() As Long, ByVal depth As Long, ByVal leftSide As Long, ByVal rightSide As Long)
    Register i As Long
    Register char As Long
    Local lastBucketStart, lastBucketSize As Long
    Local buckets As SidewinderSortBuckeyInfoT
    '
    'Pass #1: get character counts
    '   10 strings begin with "A"
    '   5 strings begin with "B"
    '   ...etc
    '   determine how big a bucket we need for each character
    '       - at the current character depth of the array being sorted
    '       - in the current segment of the array being sorted
    '           - on the first call - we move through the whole array
    For i = rightSide To leftSide Step -1
        charArr(i) = Peek(Byte, @pArr[i] + depth)
        Incr buckets.bucketSize(charArr(i))
    Next i
    '
    '
    'build bucket info
    '   determine the start position of each bucket
    lastBucketStart = leftSide
    lastBucketSize = 0
    For char = 0 To 255
        If buckets.bucketSize(char) Then
            buckets.bucketStart(char) = lastBucketStart + lastBucketSize
            buckets.bucketEnd(char) = buckets.bucketStart(char) - 1
            lastBucketStart = buckets.bucketStart(char)
            lastBucketSize = buckets.bucketSize(char)
        End If
    Next char
    '
    '
    'Pass #2: store each string in proper bucket
    For i = rightSide To leftSide Step -1
        char = charArr(i)
        Incr buckets.bucketEnd(char)
        @pArr2[buckets.bucketEnd(char)] = @pArr[i]
    Next i
    '
    '
    'Pass #3: restore buckets to original array in sorted order
    For i = rightSide To leftSide Step -1
        @pArr[i] = @pArr2[i]
    Next i
    '
    '
    'recursively sort each bucket on next character down
    '   we skip zero - null on end of string
    '       those strings have reached their final destination
    For char = 255 To 1 Step - 1
        'if a bucket only has one string - no need to sort - string in final destination
        If buckets.bucketSize(char) > 1 Then
            SidewinderSortRecursive pArr, pArr2, charArr(), depth + 1, buckets.bucketStart(char), buckets.bucketEnd(char)
        End If
    Next char
End Sub
'
'

[Stanley Durham]

'test program

#PBForms CREATED V1.51
'pbwin 9
$TestSource = "SidewinderSortTest.bas"
$TestTitle = "Sidewinder Sort Test"
#Compile Exe "SidewinderSortTest.exe"
#Dim All
#Optimize Speed
#Include Once "SidewinderSort5.inc"
'
#PBForms BEGIN INCLUDES
#If Not %Def(%WINAPI)
    #Include Once "WIN32API.INC"
#EndIf
#Include Once "PBForms.INC"
#PBForms END INCLUDES
#PBForms BEGIN CONSTANTS
%Dlg1    =  101
%BtnTest = 1002
%Lbx1    = 1001
#PBForms END CONSTANTS
Declare CallBack Function ShowDlg1Proc()
Declare Function ShowDlg1(ByVal hParent As Dword) As Long
#PBForms DECLARATIONS
Global lbx As LBxI
Global tmr As TimerI
Function PBMain()
    ShowDlg1 %HWND_Desktop
End Function
'
Sub BtnTest(ByVal hDlg As Long)
    Local i, j, arrUBound As Long
    Local a(), b() As String
    Local s As String
    Local pbTime, ssTime As Double
    Local pbTix, ssTix As Quad
    '
    'test settings
    Local Count As Long          : Count = 100000        'number of random strings to build
    Local shortestString As Long : shortestString = 10   'shortest random string
    Local longestString As Long  : longestString = 50    'longest random string
    Local lowestChar As Long     : lowestChar = 32       'ASC() smallest random character
    Local highestChar As Long    : highestChar = 127     'ASC() largest random character
    '
    'if Count <= 500 then random strings will be displayed
    '   any Count < 100,000 is to small to show any difference
    '
    Randomize
    arrUBound = Count - 1
    ReDim a(arrUBound)
    ReDim b(arrUBound)
    lbx.Clear(2)
    lbx.Add("fill arrays")
    For i = 0 To arrUBound
        s = ""
        For j = 1 To Rnd(shortestString, longestString)
            s += Chr$(Rnd(lowestChar, highestChar))
        Next j
        'make sure we have a couple of NULL string in here
        If i = 100 Or i = 200 Then s = ""
        a(i) = s
        b(i) = s
    Next i
    '
    '
    'PB sort
    lbx.Add("")
    lbx.Add("PB Sort")
    tmr.Start()
    Tix pbTix
    Array Sort a()
    Tix End pbTix
    tmr.Stop()
    lbx.Add(tmr.Get())
    pbTime = tmr.GetTime
    '
    '
    'Sidewinder sort
    lbx.Add("")
    lbx.Add("Sidewinder Sort")
    tmr.Start()
    Tix ssTix
    SidewinderSort b()
    Tix End ssTix
    tmr.Stop()
    lbx.Add(tmr.Get())
    ssTime = tmr.GetTime()
    '
    '
    lbx.Add("")
    lbx.Add("see if anything out of order")
    For i = 0 To arrUBound
        If a(i) <> b(i) Then
            ? "out of order at: " + Str$(i)
            Exit For
        End If
    Next i
    '
    '
    lbx.Add("")
    lbx.Add("Tix PB: " + Format$(pbTix))
    lbx.Add("Tix SW: " + Format$(ssTix))
    lbx.Add("TIme PB: " + Format$(pbTime, "####.##########"))
    lbx.Add("Time SW: " + Format$(ssTime, "####.##########"))
    lbx.Add("Sidewinder Sort is " + Format$(pbTime/ssTime) + " times faster than PB sort")
    '
    '
    If Count <= 500 Then
        lbx.Add("")
        lbx.Add("====================")
        For i = 1 To Count
            lbx.Add("")
            lbx.Add("PB: = '" + a(i) +"'")
            lbx.Add("SS: = '" + b(i) +"'")
        Next i
    End If
    '
    '
    lbx.Add("")
    lbx.Add("done...")
End Sub
'
CallBack Function ShowDlg1Proc()
    Select Case As Long CbMsg
        Case %WM_InitDialog
             lbx = Class "LBxC"
             lbx.INI(Cb.Hndl, %Lbx1)
             lbx.SetHorizontal(1000)
             tmr = Class "TimerC"
        Case %WM_NCActivate
            Static hWndSaveFocus As Dword
            If IsFalse CbWParam Then
                hWndSaveFocus = GetFocus()
            ElseIf hWndSaveFocus Then
                SetFocus(hWndSaveFocus)
                hWndSaveFocus = 0
            End If
        Case %WM_Command
            Select Case As Long CbCtl
                Case %BtnTest
                    If CbCtlMsg = %BN_Clicked Or CbCtlMsg = 1 Then
                        BtnTest(Cb.Hndl)
                    End If
            End Select
    End Select
End Function
Function ShowDlg1(ByVal hParent As Dword) As Long
    Local lRslt  As Long
#PBForms BEGIN DIALOG %Dlg1->->
    Local hDlg   As Dword
    Local hFont1 As Dword
    Dialog New hParent, $TestTitle, 67, 61, 341, 241, %WS_Popup _
        Or %WS_Border Or %WS_DlgFrame Or %WS_Caption Or %WS_SysMenu Or _
        %WS_MinimizeBox Or %WS_ClipSiblings Or %WS_Visible Or %DS_ModalFrame _
        Or %DS_3DLook Or %DS_NoFailCreate Or %DS_SetFont, _
        %WS_Ex_ControlParent Or %WS_Ex_Left Or %WS_Ex_LtrReading Or _
        %WS_Ex_RightScrollbar, To hDlg
    Control Add ListBox, hDlg, %Lbx1, , 5, 5, 330, 210, %WS_Child Or _
        %WS_Visible Or %WS_HScroll Or %WS_VScroll Or %LBS_Notify Or _
        %LBS_NoIntegralHeight, %WS_Ex_ClientEdge Or %WS_Ex_Left Or _
        %WS_Ex_LtrReading Or %WS_Ex_RightScrollbar
    Control Add Button,  hDlg, %BtnTest, "Test", 275, 220, 60, 15
    hFont1 = PBFormsMakeFont("Courier New", 9, 400, %FALSE, %FALSE, %FALSE, _
        %ANSI_CHARSET)
    Control Send hDlg, %Lbx1, %WM_SETFONT, hFont1, 0
#PBForms END DIALOG
    Dialog Show Modal hDlg, Call ShowDlg1Proc To lRslt
#PBForms BEGIN CLEANUP %Dlg1
    DeleteObject hFont1
#PBForms END CLEANUP
    Function = lRslt
End Function
Class LBxC
    Instance meHDlg As Long
    Instance meID As Long
    Interface LBxI
        Inherit IUnknown
        Method INI(ByVal hDlg As Long, ByVal Id As Long)
            meHDlg = hDlg
            meID = Id
        End Method
        Method SetHorizontal(ByVal Count As Long)
            Local hCntrl&
            Control Handle meHDlg, meID To hCntrl&
            SendMessage hCntrl&, %LB_SETHORIZONTALEXTENT, Count, 0
        End Method
        Method Clear(Opt doEventsCount As Long)
            ListBox Reset meHDlg, meID
            If VarPtr(doEventsCount) Then me.DoEventsCount(doEventsCount)
        End Method
        Method Add(ByVal s As String, Opt doEventsCount As Long) As String
            ListBox Add meHDlg, meID, s
            If VarPtr(doEventsCount) Then me.DoEventsCount(doEventsCount)
        End Method
    End Interface
    Class Method DoEventsCount(ByVal Count As Long)
        Local i As Long
        For i = 1 To Count
            Dialog DoEvents
        Next i
    End Method
End Class
Class TimerC
    Instance startTime As Double
    Instance stopTime As Double
    Interface TimerI
        Inherit IUnknown
        Method Start()
            startTime = Timer
        End Method
        Method Stop()
            stopTime = Timer
        End Method
        Method Get() As String
            Method = "    Time: " + Format$(stopTime - startTime, "#####.###############")
        End Method
        Method GetTime() As Double
            Method = stopTime - startTime
        End Method
    End Interface
End Class