Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Slot Sort – about 75% faster than PB string sort

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

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

    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()

    Code:
    #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
    stanthemanstan~gmail
    Dead Theory Walking
    Range Trie Tree
    HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

  • #2
    Is this an insertion sort?
    Roy Cline

    Comment


    • #3
      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.
      stanthemanstan~gmail
      Dead Theory Walking
      Range Trie Tree
      HLib ~ Free Data Container Lib ~ Arrays, Lists, Stacks, Queues, Deques, Trees, Hashes

      Comment

      Working...
      X