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