PBWin Slot Sort – about 75% faster than PB string sort

[Stanley Durham]

This is just a test sort algorithm.
Not fully debugged for general use.
Appears to be a new concept, couldn’t find anything like it.

The sort moves sideways through each character of the strings in the array at a given depth.
Gets the count of each character (0 – 255) and determines where it should be in the array.
Then makes another pass and swaps strings into their proper slot.

Then it recursively sorts each slot (next char down) until it hits null (end-of-string) or only one string slot.

Note: you have to run the test several times to get a general ideal of the speed difference.
Settings may be changed in: Sub BtnTest()

#PBForms CREATED V1.51
'pbwin 9
$TestSource = "SlotSort.bas"
$TestTitle = "Slot Sort Test"
#Compile Exe "SlotSort.exe"
#Dim All
#Optimize Speed
    'Slot Sort (may/may not be) new sort algorithm
    '   about 75% faster then PB string sort (about 30% faster "A" ~ "z"; 65 to 122)
    '   (this is only a split-second difference on 100,000 strings)
    '
    '   Note: this is not suggested as an alternative to PB sort
    '       only posted to test the concept
    '
    '   this is a recursive radix type sort
    '
    '   Pass #1: get count for each character (0 ~ 255) at a given depth
    '       establishes slot position of where each string should be in the array
    '   Pass #2: swap strings into their slot
    '       skipping already swapped strings
    '   recursively sort each slot on next character down
    '       skip slot zero (end of string - already in position)
    '       skip slots that only have one string (already in position)
    '
    '
    '   currently, doesn't handle null strings in test array: arr(i) = ""
 
#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
Type SlotSortT
    slotCount(255) As Long
    slotStart(254) As Long
    slotEnd(255) As Long
End Type
Sub SlotSort(arr() As String)
    Local pArr As Long Ptr
    Local i, lb, ub, Count, depth, arrNdx As Long
    lb = LBound(arr)
    ub = UBound(arr)
    Count = ub - lb + 1
    If Count > 1 Then
        pArr = VarPtr(arr(lb))
        depth = 0
        SlotSortR pArr, depth, 0, Count - 1
    End If
End Sub
Sub SlotSortR(ByVal pArr As Long Ptr, ByVal depth As Long, ByVal leftSide As Long, ByVal rightSide As Long)
    Local i, char, lastSlotStart, lastSlotCount As Long
    Local pbStr As Byte Ptr
    Local ss As SlotSortT
    'Pass #1: get slot counts
    For i = rightSide To leftSide Step - 1
        pbStr = @pArr[i]
        Incr ss.slotCount(@pbStr[depth])
    Next i
    'build slot info
    lastSlotStart = leftSide
    lastSlotCount = 0
    For char = 0 To 255
        If ss.slotCount(char) Then
            ss.slotStart(char) = lastSlotStart + lastSlotCount
            ss.slotEnd(char) = ss.slotStart(char) - 1
            lastSlotStart = ss.slotStart(char)
            lastSlotCount = ss.slotCount(char)
        End If
    Next char
    'Pass #2: swap strings into proper slot
    i = leftSide
    While i <= rightSide
        pbStr = @pArr[i]
        char = @pbStr[depth]
        If i >= ss.slotStart(char) And i <= ss.slotEnd(char) Then
            'we are within a slot
            '   need to move past then end of the slot
            i = ss.slotEnd(char) + 1
        Else
            'widen slot to except string
            Incr ss.slotEnd(char)
            'swap string into its slot
            Swap @pArr[i], @pArr[ss.slotEnd(char)]
            'can't move from here
            '   have to take care of string that was swapped into this index position
        End If
    Wend
    'recursively sort each slot 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 slot only has one string - no need to sort
        If ss.slotCount(char) > 1 Then
            SlotSortR pArr, depth + 1, ss.slotStart(char), ss.slotEnd(char)
        End If
    Next char
End Sub
 
Sub BtnTest(ByVal hDlg As Long)
    Local i, j As Long
    Local a(), b() As String
    Local s As String
    Local pbTime, swTime As Double
 
    'test settings
    Local Count As Long          : Count = 100000        'number of random strings to build
    Local shortestString As Long : shortestString = 6    'shortest random string
    Local longestString As Long  : longestString = 20    '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
    ReDim a(1 To Count)
    ReDim b(1 To Count)
    lbx.Clear(2)
    lbx.Add("fill arrays")
    For i = 1 To Count
        s = ""
        For j = 1 To Rnd(shortestString, longestString)
            s += Chr$(Rnd(lowestChar, highestChar))
        Next j
        a(i) = s
        b(i) = s
    Next i
    lbx.Add("")
    lbx.Add("PB Sort")
    tmr.Start()
    Array Sort a()
    tmr.Stop()
    lbx.Add(tmr.Get())
    pbTime = tmr.GetTime
 
    lbx.Add("")
    lbx.Add("Slot Sort")
    tmr.Start()
    SlotSort b()
    tmr.Stop()
    lbx.Add(tmr.Get())
    swTime = tmr.GetTime()
    lbx.Add("")
    lbx.Add("see if anything out of order")
    For i = 1 To Count
        If a(i) <> b(i) Then
            ? "out of order at: " + Str$(i)
            Exit For
        End If
    Next i
    lbx.Add("")
    lbx.Add(Format$(pbTime/swTime) + " faster")
    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

[Roy Cline]

Is this an insertion sort?

[Stanley Durham]

I made up from scratch, but looking at wikipedia; it would be a cross between a counting, bucket, and Trie sort.

This version swaps string pointers in the sort array.

Slot Sort #2 is faster. It uses a temporary array, which actually turns out to be faster.