'Sort Array 'by I3I2UI/I0 ≫ Jan 16, 2012 16:39 'https://www.freebasic.net/forum/viewtopic.php?f=7&t=19268 Dim As UInteger MaxSize = 2000000 Dim Shared NumArray(MaxSize) As UInteger Randomize Timer Sub Qsort(start As Integer,Finish As UInteger) Dim As UInteger I=start,J=Finish,X=NumArray(Int((I+J)/2)),A While I <= J While NumArray(I) < X I+=1 Wend While NumArray(J) > X J-=1 Wend If I<=J Then A = NumArray(I) NumArray(I) = NumArray(J) NumArray(J) = A I+=1 J-=1 EndIf Wend If J > Start Then Qsort(start,J) If I < Finish Then Qsort(I,Finish) End Sub Sub ASM_QSort(a() As Integer, l As Integer, r As Integer) Dim As Integer i=l, j=r, x=a((l+r)\2) Asm QS_L0: 'Do mov ecx, [a] mov ecx, [ecx] QS_L1: mov ebx, [i] lea edi, [ecx+ebx*4] mov ebx, [x] cmp [edi], ebx 'While a(i)<x jge QS_L2 inc dword ptr [i] 'i+=1 jmp QS_L1 QS_L2: mov ebx, [j] lea esi, [ecx+ebx*4] mov eax, [esi] cmp [x], eax 'While x<a(j) jge QS_L3 dec dword ptr [j] 'j-=1 jmp QS_L2 QS_L3: cmp [i], ebx 'If i<=j Then jg QS_L4 mov eax, [edi] 'Swap a(i), a(j) xchg eax, [esi] mov [edi], eax inc dword ptr [i] 'i+=1 dec dword ptr [j] 'j-=1 QS_L4: cmp [i], ebx 'Loop Until i>j jle QS_L0 End Asm If l<j Then ASM_QSort(a(), l, j) If i<r Then ASM_QSort(a(), i, r) End Sub Sub RapidSort (Item()As Integer, LoElement As Integer, HiElement As Integer) Dim As Integer n, wert, nptr, arr, rep, LoVal, HiVal LoVal=Item(LoElement) HiVal=Item(HiElement) For n=LoElement To HiElement If LoVal> Item(n) Then LoVal=Item(n) If HiVal< Item(n) Then HiVal=Item(n) Next ReDim SortArray(LoVal To HiVal) As Integer For n=LoElement To HiElement wert=Item(n) SortArray(wert)=SortArray(wert)+1 Next nptr=LoElement-1 For arr=LoVal To HiVal rep=SortArray(arr) For n=1 To rep nptr=nptr+1 Item(nptr)=arr Next Next Erase SortArray End Sub Dim t As Double Print "Qsort "; For I As Integer=1 To MaxSize NumArray(I) = Int(Rnd*MaxSize) Next t=Timer Qsort(1,MaxSize) ?Timer-t Print "ASM_QSort "; For I As Integer=1 To MaxSize NumArray(I) = Int(Rnd*MaxSize) Next t=Timer ASM_QSort(NumArray(),1,MaxSize) ?Timer-t Print "RapidSort "; For I As Integer=1 To MaxSize NumArray(I) = Int(Rnd*MaxSize) Next t=Timer RapidSort(NumArray(),1,MaxSize) ?Timer-t Sleep
'Sort Array 'by MichaelW ≫ Feb 02, 2012 3:41 'https://www.freebasic.net/forum/viewtopic.php?f=7&t=19268 ''============================================================================= #include "crt.bi" ''============================================================================= Dim As UInteger MaxSize = 1000000 Dim Shared NumArray(MaxSize) As UInteger Randomize Timer ''============================================================================= function compare naked cdecl( byval elem1 as any ptr, _ byval elem2 as any ptr ) as integer asm mov ecx, [esp+4] mov edx, [esp+8] mov eax, [ecx] sub eax, [edx] ret end asm end function ''============================================================================= Sub _Qsort(start As Integer,Finish As UInteger) Dim As UInteger I=start,J=Finish,X=NumArray(Int((I+J)/2)),A While I <= J While NumArray(I) < X I+=1 Wend While NumArray(J) > X J-=1 Wend If I<=J Then A = NumArray(I) NumArray(I) = NumArray(J) NumArray(J) = A I+=1 J-=1 EndIf Wend If J > Start Then _Qsort(start,J) If I < Finish Then _Qsort(I,Finish) End Sub ''============================================================================= /' Print "Unsorted Array" For I As Integer=1 To MaxSize NumArray(I) = Int(Rnd*100) Print NumArray(I);" "; Next print _Qsort(1,MaxSize) Print "Sorted Array" For I As Integer=1 To MaxSize Print NumArray(I);" "; Next print Print "Unsorted Array" For I As Integer=1 To MaxSize NumArray(I) = Int(Rnd*100) Print NumArray(I);" "; Next print qsort( @NumArray(1), MaxSize, 4, @compare ) Print "Sorted Array" For I As Integer=1 To MaxSize Print NumArray(I);" "; Next print '/ sleep 3000 dim as double t t = timer _Qsort(1,MaxSize) print using "Qsort ##.###";timer-t t = timer qsort( @NumArray(1), MaxSize, 4, @compare ) print using "qsort ##.###";timer-t sleep
'Sort Array 'by dafhi ≫ Feb 02, 2012 5:31 'https://www.freebasic.net/forum/viewtopic.php?f=7&t=19268 Dim As Integer NumElements = 65000 Dim Shared As double mTimeQ,mTimeG,MinLoopTime Dim Shared As String strNum,strDen #include "crt.bi" function compare naked cdecl( byval elem1 as any ptr, _ byval elem2 as any ptr ) as integer asm mov ecx, [esp+4] mov edx, [esp+8] mov eax, [ecx] sub eax, [edx] ret end asm end function '' LerpSort by cRex '' also included: cRex-modified quicksort '' Both: '' 1. index reference array, swapping those vals (for langs w/o pointers) '' 2. post-sort cycle swap for minimum user-data movement Dim Shared As Integer Q, UB,LB Dim Shared As Integer Sorted,mDelta,SwapI_ Dim Shared As Single SwapVar,mDelt #Macro zSort3C(pLo,pMid,pHi,A) ''CycleSort version If A(pLo) <= A(pMid) Then If A(pMid) <= A(pHi) Then '123 Else If A(pLo) <= A(pHi) Then '132 SwapI_ = pMid pMid = pHi: pHi = SwapI_ Else '231 SwapI_ = pHi pHi = pMid pMid = pLo: pLo = SwapI_ End If End If Else 'plo > pMid If A(pMid) <= A(pHi) Then If A(pLo) <= A(pHi) Then '213 SwapI_ = pMid pMid = pLo: pLo = SwapI_ Else '312 SwapI_ = pLo pLo = pMid pMid = pHi: pHi = SwapI_ End If Else '321 SwapI_ = pLo pLo = pHi: pHi = SwapI_ End If End If #EndMacro #Macro zIfSwapC(I_,J_,A) ''CycleSort version If A(I_) > A(J_) Then Swap I_, J_ EndIf #EndMacro #Macro zInsertionSortC(A,lSt,lEnd,pBtr) ''CycleSort version I_ = lSt For J_ = I_ + 1 To lEnd If A(pBtr(I_)) > A(pBtr(J_)) Then Swap_=pBtr(J_) SwapVar = A(Swap_) Copy_ = I_ pBtr(J_) = pBtr(Copy_) For I_ = J_ - 2 To lSt Step -1 If A(pBtr(I_)) <= SwapVar Then Exit For pBtr(Copy_) = pBtr(I_) Copy_ = I_ Next pBtr(Copy_) = Swap_ End If I_ = J_ Next #EndMacro Private Sub zCycleSort(pSt As Integer, pEnd As Integer, pBtr() As Integer, A() As Single) Dim J As Integer, K As Integer For pSt = pSt To pEnd K = pBtr(pSt) If K <> pSt Then J = pSt SwapVar = A(J) Do A(J) = A(K) J = K K = pBtr(K) pBtr(J) = J ' "Null" If K = pSt Then Exit Do Loop A(J) = SwapVar pBtr(K) = K End If Next End Sub #Macro zInitIndices(IndxAry) ReDim IndxAry(UBound(A)) For I_ = 0 To UBound(A) IndxAry(I_) = I_ Next #EndMacro Private sub zLerpSortC(pSt As Integer,pEnd As Integer,A() As Single,pBtr() As Integer,Final() As Integer,Lerp_() As Integer) Dim As Integer I_,J_,K_ '' : : About LerpSort (cyclesort version) : : '' 1. LBound must be zero '' 2. LerpSort creates at least 4 Integer arrays '' 3. (2011 July 1) - discovered that LerpSort is identical '' to FlashSort by Karl Dietrich Neubert I_ = pSt J_ = pSt Sorted = -1 For K_ = pSt + 1 To pEnd ''pBtr = "pointers" If A(pBtr(J_)) <= A(pBtr(K_)) Then J_ = K_ Else Sorted = 0 If A(pBtr(I_)) > A(pBtr(K_)) Then I_ = K_ End If End If Next If Sorted Then Exit Sub mDelta = pEnd - pSt Dim lStack(mDelta) As Integer '' created here in case recursive LerpSort I_ = pBtr(I_) mDelt = A(pBtr(J_)) - A(I_) mDelt = mDelta / mDelt For K_ = pSt To pEnd J_ = (A(pBtr(K_)) - A(I_)) * mDelt Lerp_(K_) = J_ lStack(J_) += 1 Next I_ = pSt + lStack(0) lStack(0) = pSt For J_ = 1 To mDelta If lStack(J_) > 0 Then K_ = lStack(J_) lStack(J_) = I_ I_ = I_ + K_ End If Next For I_ = pSt To pEnd J_ = Lerp_(I_) Final(lStack(J_)) = pBtr(I_) lStack(J_) = lStack(J_) + 1 Next For I_ = pSt To pEnd pBtr(I_) = Final(I_) ''CycleSwap after LerpSort Next Dim As Integer Swap_, Copy_ '' InsertionSort Macro Dim As Integer L_ For L_ = 0 To mDelta pEnd = lStack(L_) I_ = pEnd - pSt If I_ < 1 Then ElseIf I_ = 1 Then pSt = pEnd ElseIf I_ = 2 Then zIfSwapC(pBtr(pSt), pBtr(pEnd - 1), A) pSt = pEnd ElseIf I_ = 3 Then zSort3C(pBtr(pSt), pBtr(pSt + 1), pBtr(pEnd - 1), A) pSt = pEnd ElseIf I_ < 10 Then zInsertionSortC(A,pSt,pEnd - 1,pBtr) pSt = pEnd Else zLerpSortC pSt,pEnd - 1,A(),pBtr(),Final(),Lerp_() pSt = pEnd End If Next End Sub Sub LerpSort(A() As Single) mDelta = UBound(A) If mDelta = 0 Then Exit Sub Dim As Integer I_,J_,pBtr() zInitIndices(pBtr) If mDelta = 1 Then zIfSwapC(pBtr(0), pBtr(1), A) ElseIf mDelta = 2 Then zSort3C(pBtr(0), pBtr(1), pBtr(2), A) Else Dim As Integer lSt Dim Final() As Integer Dim Lerp_() As Integer ReDim Final(mDelta) ReDim Lerp_(mDelta) zLerpSortC lSt,mDelta,A(),pBtr(),Final(),Lerp_() End If zCycleSort 0, UBound(A), pBtr(), A() End Sub Private Sub zTimerCompare(A() As Single,ByRef RetTotal_ As Double) mTimeQ = Timer - mTimeQ RetTotal_ = RetTotal_ + mTimeQ Dim As Integer J, I For J = 1 To UB If A(I) > A(J) Then Q = Q + 1 ? "Sort Problem!" Exit For End If I = J Next mDelta = UB - LB For J = 0 To UB A(J) = Rnd * UB'-J Next Sleep 1 End Sub Private Sub Test(A() As Single,U_ As Integer) Dim TQ_ As Double, TG_ As Double Dim Q2 As Integer Dim lTimer As Double UB = U_ ReDim A(U_) For Q = 0 To U_ A(Q) = Rnd * U_ Next Q = 1 Q2 = Q lTimer = Timer Do Q2 = Q strDen = "Quick" mTimeQ = Timer qsort( @A(0), UB+1, 4, @compare ) zTimerCompare A(), TQ_ If Q > Q2 Then ? "Quick " & Q2 GoTo OHNO End If strNum = "Lerp" mTimeQ = Timer LerpSort A() zTimerCompare A(),TG_ If Q > Q2 Then ? "Lerp " & Q2 GoTo OHNO End If If MinLoopTime <= (timer - lTimer) Then Exit Do Q += 1 Loop mTimeQ = TQ_ mTimeG = TG_ OHNO: Q = 0 End Sub Randomize Timer MinLoopTime = 1.5 Dim MyData() As Single Test MyData(), NumElements If mTimeQ <> 0 Then Print strNum & " / " & strDen & " = " & mTimeG / mTimeQ Sleep