[2014 March 17] - cartesian tree merge
[2012 May 27] - new qsort
[2011 Aug 27] - minor optimizations to the QSorts
Code: Select all
' =============================
' visual sorts by c_rex '
' Ver. 0.95 - 2023 June 3 '
' (0.94 will be next version) '
' =============================
/' ------- Notes -------
lerp, cascade, and exchange-insertion are my own.
I also optimized comb.
'/
#Macro SelCase(pVar)
Select Case pVar: Case
#EndMacro
Dim Shared As Integer SCR_W, SCR_H, WidM, HgtM
Dim Shared As Integer AryResizing, Running = TRUE
Type DemoMode
As Integer SleepVal,MinE,MaxE,CountE,VisScale,ScaleM
As Single sCountE
End Type
Type X1X2
As Integer x1,x2
End Type
Type SortDev
As Integer Delta, Gap, Sorted
End Type
Dim Shared As DemoMode mDemo,Macro,Micro
Dim Shared As X1X2 mFrameP
Dim Shared As SortDev mSi
Type RGBQUAD
Blue As UByte
Green As UByte
Red As UByte
Alpha As UByte
End Type
Type ColorSet
As RGBQUAD Fore,Compare
End Type
Dim Shared As RGBQUAD BackRGB,ComparRGB,ForeRGB
Dim Shared As ColorSet Cols(3)
Dim Shared As Integer UB,LB,Q,CSChoice,mShowHelp2,ModeMaMi,mDelta,mGap,mExchgSortTravel
Dim Shared As Integer SortError,ShiftKey
Dim Shared As Single swapvar, sngswap_, mDelt, sngA, sngB, MyData()
Dim Shared As integer swI 'qs2
Private Type CascadeSortVars
aSt As Integer
aEnd As Integer
PtAsc As Integer
PtDsc As Integer
aCpy As Integer
Gap As Integer
End Type
Dim Shared As Const UInteger QS_INSERTSORT_THRESHOLD = 6
Declare Sub PrintInfo()
Declare Sub Key_Press (Byval scancode As Integer, Byval ascii As Integer)
Declare Sub Key_Release (Byval scancode As Integer, Byval ascii As Integer)
Declare Sub Key_Repeat (Byval scancode As Integer, Byval ascii As Integer)
#Include "fbgfx.bi"
Using FB
Dim Shared mE_ As EVENT '' extra part allowing user to interrupt a sort
' ============================
' Startup
' ============================
Private Sub zDefRGB(pRGB As RGBQUAD,R_ As Integer,G_ As Integer,B_ As Integer)
pRGB.Blue = B_:pRGB.Green = G_:pRGB.Red = R_
End Sub
Private Sub ColorSet(csval As Integer)
CSChoice = csval
ForeRGB = Cols(csval).Fore
ComparRGB = Cols(csval).Compare
End Sub
declare Sub RedimALL(A() As Single,ByVal sElemC As Single)
Private Sub SetDefaults()
zDefRGB BackRGB,0,0,0
zDefRGB Cols(0).Fore, 255, 255, 0
zDefRGB Cols(0).Compare, 0, 0, 255
zDefRGB Cols(1).Fore, 255, 255, 255
zDefRGB Cols(1).Compare, 0, 255, 255
zDefRGB Cols(2).Fore, 255,255,255
zDefRGB Cols(2).Compare, 155,5,255
zDefRGB Cols(3).Fore, 164,136,72
zDefRGB Cols(3).Compare, 255,0,16
ColorSet 0
Micro.MinE = 9
Micro.MaxE = 70
Macro.MinE = 70
Macro.MaxE = 500
Macro.SleepVal = 1
Micro.SleepVal = 50
Macro.VisScale = 1
Micro.VisScale = 8
Macro.sCountE = 240
Micro.sCountE = 36
Macro.ScaleM = Macro.VisScale - 1
Micro.ScaleM = Micro.VisScale - 1
randomize
mDemo = Macro
If mDemo.VisScale < 5 Then ModeMaMi = 1 ''Debugging
RedimALL MyData(), mDemo.sCountE
mGap = 3
End Sub
' ============= start of fpu round mode down ============= '
'
' http://www.freebasic.net/forum/viewtopic.php?f=3&t=22285
#define RC_NEAREST 0 '' or to even if equidistant (initialized state)
#define RC_DOWN 1 '' toward -infinity
#define RC_UP 2 '' toward +inifinity
#define RC_TRUNCATE 3 '' toward zero
''----------------------------------------------------
'' This procedure sets the FPU and SSE floating-point
'' rounding control to one of the above values.
''
'' Even with-fpu sse some math support will still use
'' the FPU, so must set rounding control for both.
''
'' This code assumes an FPU, and if __FB_SSE__ is
'' defined, a compatible processor.
''----------------------------------------------------
/'
sub SetRC naked( rc as integer )
#if __FB_GCC__
asm
".intel_syntax noprefix"
"mov eax, [esp+4]"
"and eax, 3"
"shl eax, 10"
"push 0"
"fstcw [esp]"
"and WORD PTR [esp], NOT 0xc00"
"or [esp], ax"
"fldcw [esp]"
"add esp, 4"
#ifdef __FB_SSE__
"mov eax, [esp+4]"
"and eax, 3"
"shl eax, 13"
"push 0"
"stmxcsr [esp]"
"and DWORD PTR [esp], NOT 0x3000"
"or [esp], eax"
"ldmxcsr [esp]"
"add esp, 4"
#endif
"ret 4"
".att_syntax prefix"
end asm
#else
asm
mov eax, [esp+4]
and eax, 3
shl eax, 10
push 0
fstcw [esp]
and WORD PTR [esp], NOT 0xc00
or [esp], ax
fldcw [esp]
add esp, 4
#ifdef __FB_SSE__
mov eax, [esp+4]
and eax, 3
shl eax, 13
push 0
stmxcsr [esp]
and DWORD PTR [esp], NOT 0x3000
or [esp], eax
ldmxcsr [esp]
add esp, 4
#endif
ret 4
end asm
#endif
end sub
' ===== end of fpu round mode down ===== '
'/
#Macro KeyEvents() '' interrupt a sort
If (ScreenEvent(@mE_)) Then
SelCase( mE_.type ) EVENT_KEY_RELEASE
Key_Release(mE_.scancode,0)
Case EVENT_KEY_PRESS
Key_Press(mE_.scancode,0)
Case EVENT_KEY_REPEAT
Key_Repeat(mE_.scancode,0)
End Select
End If
#EndMacro
#Macro TriggerBreak()
Q = 0
#EndMacro
#Macro IfUserBreak()
If Q <> 1 Then Exit Sub
#EndMacro
#Macro UserInput()
KeyEvents()
IfUserBreak()
#EndMacro
' ===================
' Visualization
' ===================
#Macro zSleepy()
Sleep mDemo.SleepVal
#EndMacro
Private Sub zCopyPause()
If Rnd < 0.25 Then
zSleepy()
End If
End Sub
Private Sub zSwapPause()
If Rnd < 0.75 Then
zSleepy()
End If
End Sub
#Macro LockUnlock()
ScreenLock
ScreenUnlock
#EndMacro
#Macro DrawBar(A,x_,pRGB)
sngA = A(x_) + 1
sngB = x_ * mDemo.VisScale
Line (sngB,HgtM)-(sngB+mDemo.ScaleM,HgtM - (sngA * mDemo.VisScale - 1)),RGB(pRGB.Red,pRGB.Green,pRGB.Blue),BF
LockUnlock()
#EndMacro
Private Sub DrawBars3(A() As Single, x1 As Integer, x2 As Integer,x3 As Integer,pRGB As RGBQUAD)
DrawBar(A,x1,pRGB)
DrawBar(A,x2,pRGB)
DrawBar(A,x3,pRGB)
End Sub
Private Sub DrawBars(A() As Single, x1 As Integer, x2 As Integer,pRGB As RGBQUAD)
DrawBar(A,x1,pRGB)
DrawBar(A,x2,pRGB)
End Sub
Private Sub VisCompare(A() As Single,x1 As Integer,x2 As Integer,ByVal Color_ As long = 1)
Dim As RGBQUAD Ptr lpRQ = @Color_
If Color_ = 1 Then lpRQ = @ComparRGB
Dim As RGBQUAD lRGBQ = *lpRQ
DrawBar(A,mFrameP.x1,ForeRGB)
DrawBar(A,mFrameP.x2,ForeRGB)
DrawBar(A,x1,lRGBQ)
DrawBar(A,x2,LRGBQ)
zSleepy()
mFrameP.x1 = x1
mFrameP.x2 = x2
End Sub
Sub DrawData()
Dim As Integer I
For I = 0 To UB
DrawBar(MyData,I,ForeRGB)
Next
mFrameP.x1 = 0
mFrameP.x2 = 0
End Sub
#Macro zVisSwapPre(A,Index1,Index2)
zSwapPause
DrawBars A(),(Index1),(Index2),BackRGB
#EndMacro
#Macro zVisSwapPost(A,Index1,Index2)
DrawBars A(),(Index1),(Index2),ForeRGB
#EndMacro
#Macro zVisSwap(A,Index1,Index2)
zSwapPause
DrawBars A(),(Index1),(Index2),BackRGB
Swap A(Index1),A(Index2)
DrawBars A(),(Index1),(Index2),ForeRGB
#EndMacro
#Macro zVisCopy(pDstAry,pDstIndx,pSrcVal)
zCopyPause
DrawBar(pDstAry,(pDstIndx),BackRGB)
pDstAry(pDstIndx) = (pSrcVal)
DrawBar(pDstAry,(pDstIndx),ForeRGB)
#EndMacro
#Macro zVisIfSwap(A,I_,J_)
If A(I_) > A(J_) Then
zSwapPause
DrawBars A(), (I_), (J_), BackRGB
Swap A(I_), A(J_)
EndIf
VisCompare A(),(I_),(J_)
#EndMacro
' ============================
' Randomize, Line, etc.
' ============================
Private Sub Validate(A() As Single)
Dim I As Integer
SortError = 0
For J As Integer = 1 To UB
If A(I) > A(J) Then SortError = 1: Q = 0: Exit For
I = J
Next
Q = 0
If SortError Then ? "Sort Error!"
End Sub
Private Sub CreateRNDVals(A() As Single)
For I As Integer = 0 To UB
A(I) = Rnd * UB
Next
TriggerBreak()
End Sub
Private Sub RandomizeArray(A() As Single)
For I As Integer = 0 To UB
Swap A(I), A(Rnd * UB)
Next
TriggerBreak()
End Sub
Private Sub CamelHump(A() As Single)
Dim As integer ll = LBound(a), uu=UBound(a), delt=uu-ll
Dim As Integer i, h
For i = ll To ll + delt \ 2
A(I) = h: h+=2
Next: h-=1
For i = i To uu
A(i) = h: h-=2
next
End sub
Private Sub Reversed(A() As Single)
For I As Integer = 0 To UB
A(I)= UB - I
' A(I) = Int(Rnd*3) * 5
Next
TriggerBreak()
End Sub
Private Sub RandomLinear(A() As Single)
Reversed A()
RandomizeArray A()
End Sub
Private Sub RedimALL(A() As Single,ByVal sElemC As Single)
sElemC = Int(sElemC + 0.5)
If sElemC = mDemo.CountE Then
Exit Sub
EndIf
mDemo.CountE = sElemC
UB = sElemC - 1
ReDim A(UB)
mExchgSortTravel = 0.31 * (UB + 1)
RandomLinear A()
'CreateRNDVals A()
TriggerBreak()
PrintInfo
End Sub
Private Sub RequestSizeUp
mDemo.sCountE *= 0.9:If mDemo.sCountE < mDemo.MinE Then mDemo.sCountE = mDemo.MinE
Cls: ? Int(mDemo.sCountE + 0.5) & " elements"
End Sub
Private Sub RequestSizeDown
mDemo.sCountE /= 0.9:If mDemo.sCountE > mDemo.MaxE Then mDemo.sCountE = mDemo.MaxE
Cls: ? Int(mDemo.sCountE + 0.5) & " elements"
End Sub
' ============================
' S O R T S
' ============================
#Macro zInsertionSort(A,lSt,lEnd,pGap)
I = lSt
For J = I + pGap To lEnd Step pGap
VisCompare A(),I, J
If A(I) > A(J) Then
zCopyPause
SwapVar = A(J)
Dim As Integer K = I
zVisCopy(A,J,A(K))
For I = I - pGap To lSt Step -pGap
VisCompare A(),I, J
If A(I) <= SwapVar Then Exit For
zVisCopy(A,K,A(I))
K = I
UserInput()
Next
zVisCopy(A,K,SwapVar)
End If
I = J
Next
IfUserBreak()
#EndMacro
Type MyType As Single
#Macro zSort3(A,pLo,pMid,pHi)
VisCompare A(),pLo,pMid
If A(pLo) <= A(pMid) Then
VisCompare A(),pMid,pHi
If A(pMid) <= A(pHi) Then '123
Else
VisCompare A(),pLo,pMid
DrawBars3 A(), pLo,pMid,pHi,BackRGB
If A(pLo) <= A(pHi) Then '132
sngswap_ = A(pMid)
A(pMid) = A(pHi): A(pHi) = sngswap_
Else '231
sngswap_ = A(pHi)
A(pHi) = A(pMid)
A(pMid) = A(pLo): A(pLo) = sngswap_
End If
DrawBars3 A(), pLo,pMid,pHi,ForeRGB
zSwapPause:zCopyPause
End If
Else 'plo > pMid
VisCompare A(),pMid,pHi
If A(pMid) <= A(pHi) Then
VisCompare A(),pLo,pHi
DrawBars3 A(), pLo,pMid,pHi,BackRGB
If A(pLo) <= A(pHi) Then '213
sngswap_ = A(pMid)
A(pMid) = A(pLo): A(pLo) = sngswap_
Else '312
sngswap_ = A(pLo)
A(pLo) = A(pMid)
A(pMid) = A(pHi): A(pHi) = sngswap_
End If
DrawBars3 A(), pLo,pMid,pHi,ForeRGB
zSwapPause:zCopyPause
Else '321
DrawBars3 A(), pLo,pMid,pHi,BackRGB
sngswap_ = A(pLo)
A(pLo) = A(pHi): A(pHi) = sngswap_
DrawBars3 A(), pLo,pMid,pHi,ForeRGB
zSwapPause:zCopyPause
End If
End If
#EndMacro
Sub zExchangeSort(A() As Single,ByVal pSt As Integer,ByRef pStTravel As Integer, ByRef pEnd As Integer, pGap As Integer)
Dim J As Integer
For pSt = pSt To pSt + pStTravel Step pGap
For J = pEnd To pSt + pGap Step -pGap '' common upper bound
zVisIfSwap(A,pSt,J)
UserInput()
Next
Next
End Sub
#Macro zQuickSort2G(pSt,pEnd)
'Standard QuickSort Routine
'http://www.freebasic-portal.de/porticula/sort-testbas-schnellste-routinen-513.html
Do
Do
If pEnd - pSt < QS_INSERTSORT_THRESHOLD Then ''Tests show 13 optimal for many cases
zInsertionSort(A, pSt, pEnd, 1)
Exit Do
Else
I = pSt
J = pEnd
SwapVar = A((I + J) \ 2)
mDelta = (I+J) \ 2 ''Vis only
Do
VisCompare A(),I, mDelta
While A(I) < SwapVar
I = I + 1
VisCompare A(),I, mDelta
Wend
VisCompare A(),J, mDelta
While SwapVar < A(J)
J = J - 1
VisCompare A(),J, mDelta
Wend
If I > J Then Exit Do
zVisIfSwap(A,I, J)
I = I + 1
J = J - 1
UserInput()
Loop While I <= J
If I < pEnd Then
lStack(StackPtr) = I
lStack(StackPtr + 1) = pEnd
StackPtr = StackPtr + 2
End If
pEnd = J
End If
Loop While pSt < pEnd
If StackPtr = 0 Then Exit Do
StackPtr = StackPtr - 2
pSt = lStack(StackPtr)
pEnd = lStack(StackPtr + 1)
Loop
#EndMacro
Private Sub zCycleSwap(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)
VisCompare A(),K,pSt
If K <> pSt Then
J = pSt
SwapVar = A(J)
Do
zVisCopy(A,J,A(K))
J = K
K = pBtr(K)
pBtr(J) = J ' "Null"
VisCompare A(),K,pSt
If K = pSt Then Exit Do
Loop
zVisCopy(A,J,SwapVar)
pBtr(K) = K
End If
Next
End Sub
Private sub zLerpSort(pSt As Integer,pEnd As Integer,A() As Single,Final() As Integer,Lerp_() As Integer)
'' : : About LerpSort : :
'' 1. O(3n) memory with this implementation
'' 2. about twice as fast as quicksort
'' 3. (2011 July 1) -
'' discovered that LerpSort is similar to FlashSort by Karl Dietrich Neubert
Dim As Integer I,J,K,L
I = pSt
J = pSt
mSI.Sorted = -1
For K = pSt + 1 To pEnd
VisCompare A(),J,K
If A(J) <= A(K) Then
J = K
Else
mSI.Sorted = 0
VisCompare A(),I,K
If A(I) > A(K) Then
I = K
End If
End If
UserInput()
Next
If mSI.Sorted Then Exit Sub
mDelta = pEnd - pSt
Dim lStack(mDelta) As Integer '' recursive
mDelt = mDelta / (A(J) - A(I))
For K = pSt To pEnd
VisCompare A(),I,K
J = (A(K) - A(I)) * mDelt
Lerp_(K) = J
lStack(J) += 1
UserInput()
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)
VisCompare A(),I,lStack(J)
Final(lStack(J)) = I
lStack(J) = lStack(J) + 1
UserInput()
Next
zCycleSwap pSt, pEnd, Final(), A()
For L = 0 To mDelta
UserInput()
pEnd = lStack(L)
I = pEnd - pSt
If I < 1 Then
ElseIf I = 1 Then
pSt = pEnd
ElseIf I = 2 Then
zVisIfSwap(A,pSt, pEnd - 1)
pSt = pEnd
ElseIf I = 3 Then
zSort3(A,pSt, pSt + 1, pEnd - 1)
pSt = pEnd
ElseIf I < 10 Then
zInsertionSort(A,pSt,(pEnd - 1),1)
pSt = pEnd
Else
zLerpSort pSt,pEnd - 1,A(),Final(),Lerp_()
pSt = pEnd
End If
Next
End Sub
Private Sub zCombSort4(A() As Single, pSt As Integer, pEnd As Integer, Gap_ As Integer)
Dim Gap As Integer
Dim GapX As Integer
Dim I As Integer, K As Integer
Dim J As Integer
Gap = (pEnd - pSt)
Do While Gap > 1
GapX = CLng(Gap_) * CLng(Gap)
For I = pSt To pEnd - GapX Step Gap_
J = I + GapX
zVisIfSwap(A,I,J)
UserInput()
Next I
Gap *= 100
Gap \= 143
Loop
zInsertionSort(A,pSt,pEnd,Gap_)
End Sub
Private Sub zCombSortE(A() As Single, pSt As Integer, pEnd As Integer, Gap_ As Integer)
Dim As Single Gap = (pEnd - pSt), GapAdd = 1
Dim As Integer I, K, J, GapX
Do While Gap > 2
GapX = CLng(Gap_) * CLng(Gap)
For I = pSt To pEnd - GapX Step Gap_
J = I + GapX
zVisIfSwap(A,I,J)
UserInput()
Next I
Gap = Gap * .7
' Gap = Gap - GapAdd
' GapAdd = GapAdd + 1.3
Loop
zInsertionSort(A,pSt,pEnd,Gap_)
End Sub
Private Sub zCascadeSort(A() As Single,Cascade() As Integer,pSt as integer, pEnd as integer)', SI As CascadeSortVars)
''cRex Sort II - A new Selection Sort
/'
SI.PtAsc = SI.aSt
SI.PtDsc = SI.aEnd
Cascade(SI.PtAsc) = SI.aSt
Cascade(SI.PtDsc) = SI.aSt
Dim As Integer I = SI.aSt + SI.Gap
While SI.aSt < SI.aEnd
For I = I To SI.aEnd Step SI.Gap
VisCompare A(),Cascade(SI.PtAsc),I
mFrameP.x1 = I ''prevent compare bar color from being erased
If A(Cascade(SI.PtAsc)) <= A(I) Then
SI.PtAsc = SI.PtAsc + 1
Cascade(SI.PtAsc) = I
DrawBar(A,I,ComparRGB)
UserInput()
End If
Next
If SI.PtAsc = SI.aEnd Then Exit Sub
If Cascade(SI.PtAsc) <> SI.aEnd Then
zVisSwap(A,Cascade(SI.Ptasc),SI.aEnd)
Else
DrawBar(A,SI.aEnd,ForeRGB)
End If
If SI.PtAsc > SI.aSt Then
I = Cascade(SI.PtAsc)
SI.PtAsc = SI.PtAsc - 1
Else
I = SI.aSt + SI.Gap
End If
SI.aEnd = SI.aEnd - SI.Gap
UserInput()
Wend
'/
Dim As Integer ptr p = @cascade(0), qq = p
Dim As integer i = pSt + 1'st = pSt + 1
*p = pSt
Do
For i = i To pEnd - 1
viscompare a(), *p, i
mFrameP.x1 = I ''prevent compare bar color from being erased
If A(i) > A(*p) Then
p = p + 1: *p = i
DrawBar(A,I,ComparRGB)
End if
UserInput()
Next
If A(*p) > A(pEnd) Then
zVisIfSwap( A, *p, pEnd )
i = *p
If p > qq Then p = p - 1
pEnd = pEnd - 1
If pEnd - pSt = p - qq Then Exit Do
Else
pEnd = pEnd - 1
If pEnd - pSt = p - qq Then Exit Do
If pEnd = *p Then
If p > qq Then p = p - 1
End if
i = pEnd
End If
Loop
End Sub
#Macro zHeapSort_sift(A,pSt,pCount)
'http://sortvis.org/algorithms/heapsort.html
Root = pSt
Child = Root * 2 + 1
Do While Child < pCount
If Child < pCount - 1 Then
VisCompare A(),Child,Child + 1
If A(Child) < A(Child+1) Then
Child += 1
EndIf
EndIf
VisCompare A(),Root,Child
If A(Root) < A(Child) Then
zVisSwap(A,Root,Child)
Root = Child
Child = Root * 2 + 1
Else
Exit Do
EndIf
Loop
#EndMacro
Sub heapsort(A() As single)
Dim lSt As Integer,pEnd As Integer,lCount As Integer
Dim Root As Integer,Child As Integer
'http://sortvis.org/algorithms/heapsort.html
lCount = UB+1
lSt = lCount\2-1
pEnd = UB
While lSt >= 0
zHeapSort_sift(A,lSt,lCount)
lSt -= 1
Wend
While pEnd > 0
zVisSwap(A,pEnd,0)
zHeapSort_sift(A,0,pEnd)
pEnd -= 1
UserInput()
Wend
End Sub
#Macro zGap()
If Gap < 1 Then Gap = 1
If ShiftKey Then Gap = mGap
#EndMacro
' ============================
' = Sort Wrappers
' ============================
Sub CascadeSort(A() As Single,ByVal Gap As Integer)
' Dim pSt As Integer, Cascade() As Integer
' Dim SI As CascadeSortVars
Dim As Integer Cascade(UB)
' zGap()
' SI.Gap = Gap
' For pSt = pSt To pSt + Gap - 1
' mSi.Delta = Gap * ((UB - pSt) \ Gap)
' SI.aSt = pSt
' SI.aEnd = pSt + mSi.Delta
zCascadeSort A(),Cascade(), 0,ub'SI
' IfUserBreak()
' Next
End Sub
Private Sub InsertionSort(A() As Single, ByVal Gap As Integer=1)
Dim I_ As Integer,I As Integer,J As Integer,K As Integer
zGap()
For I_ = 0 To Gap - 1
mSi.Delta = Gap * ((UB - I_) \ Gap)
zInsertionSort(A, I_, I_ + mSi.Delta, Gap)
IfUserBreak()
Next
End Sub
Private Sub ExchangeSort(A() As Single,ByVal Gap As Integer=1)
Dim I_ As Integer,StTravel As Integer,TravelTo As Integer
Dim I As Integer,J As Integer,K As Integer ''InsertionSort Macro
zGap()
''Tests show 0.31 near-optimal.
''Time Result: (ExchangeInsertion) / Insertion = 0.65
StTravel = Gap * (0.31 *(UB + 1) \ Gap)
For I_ = 0 To Gap - 1
mSi.Delta = Gap * ((UB - I_) \ Gap)
TravelTo = I_ + StTravel
zExchangeSort A(), I_,TravelTo, I_ + mSi.Delta, Gap
IfUserBreak()
zInsertionSort(A, TravelTo , I_ + mSi.Delta, Gap)
Next
End Sub
Sub CombSort(A() As Single)
Dim Gap As Integer
zGap()
Dim I As Integer
For I = 0 To Gap - 1
mSi.Delta = Gap * ((UB - I) \ Gap)
zCombSort4 A(), I,I+ mSi.Delta, Gap
IfUserBreak()
Next
End Sub
Sub CombSortE(A() As Single)
Dim Gap As Integer
zGap()
Dim I As Integer
For I = 0 To Gap - 1
mSi.Delta = Gap * ((UB - I) \ Gap)
zCombSortE A(), I,I+ mSi.Delta, Gap
IfUserBreak()
Next
End Sub
Sub LerpSort(A() As Single)
If UB = 0 Then Exit Sub
Dim As Integer lSt
Dim Final() As Integer
Dim Lerp_() As Integer
ReDim Final(UB)
ReDim Lerp_(UB)
zLerpSort lSt,UB,A(),Final(),Lerp_()
End Sub
#Macro QS2_Common(QS_NAME)
Else
swapvar = A(swI)
/'
Do
While J > swI
VisCompare A(), swI, J
If A(J) < SwapVar Then Exit while
J = J - 1
UserInput()
Wend
zVisCopy(A, swI, A(J))
zVisCopy(A, J, SwapVar)
swI = J
If J = I Then Exit Do
While I < swI
VisCompare A(), J, swI
If A(I) > swapvar Then Exit while
I = I + 1
UserInput()
Wend
zVisCopy(A, swI, A(I))
zVisCopy(A, I, SwapVar)
swI = I
If J = I Then Exit Do
Loop
J = swI - 1
I = swI + 1
'/
'
Do
I += 1
J -= 1
VisCompare A(), I, swI
While A(I) < SwapVar
I = I + 1
VisCompare A(), I, swI
UserInput()
Wend
VisCompare A(), J, swI
While SwapVar < A(J)
J = J - 1
VisCompare A(), J, swI
UserInput()
Wend
if J <= I then exit Do
zVisSwap( A, I, J )
Loop
If A(i) = SwapVar Then
j=i-1: i+=1
ElseIf A(j) = SwapVar Then
i=j+1: j-=1
End If
'/
if J > pSt Then QS_NAME A(), pSt, J
if I < pEnd Then QS_NAME A(), I, pEnd
End If
#EndMacro
Sub QS2(A() As Single, pSt As Integer, pEnd As integer)
Dim As Integer I=pSt, J=pEnd
swI = (I+J) \ 2
zVisIfSwap(A,I,J)
zVisIfSwap(A,I,swI)
zVisIfSwap(A,swI,J)
If pEnd - pSt < QS_INSERTSORT_THRESHOLD Then 'Tests show 39 near-optimal for many cases
zInsertionSort(A, pSt, pEnd, 1)
QS2_Common(QS2)
End sub
Sub QuickSort2(A() As Single)
Dim As Integer UB = ubound(a)
If UB < 1 Then Exit Sub
Dim As Integer LB = lbound(a), delt = ub-lb
For i As single = lb To ub Step 30.4
Dim As Integer j = lb + Rnd*delt
zVisSwap(A,i,j)
next
QS2 A(), LB, UB
End Sub
type CtmNode
as MyType value
as CtmNode ptr lhs, rhs
as integer visual_index
end type
Type t_StackElement As CtmNode ptr
'#include "stack.bas
' ========= start of stack.bas ========= '
' usage:
' type stack_elem 'your data type
' as whateverA A,A1
' as whateverB B
' End Type
' Type t_StackElement As stack_elem 'introduce the data type to the handler
' #include "stack.bas" ' this file
Type tStackHandler
as integer stackp
As Single expansion_coeff = 1.5
As String data
Declare Sub ppush(valu As t_StackElement)
declare function ppop() as t_StackElement
private:
Declare Sub preserve
as integer marker
as any ptr srcAny, dstAny, _p
as t_StackElement ptr p
End Type
Sub tStackHandler.preserve
marker = (stackp+1) * expansion_coeff
Dim As String sav = data
data = Space( marker * Len(t_StackElement) )
dstAny = @data[0]
srcAny = @sav[0]
Dim As t_StackElement Ptr src=srcAny
p = dstAny
For dst As t_StackElement Ptr = @p[0] To @p[stackp-1]
*dst = *src: src+=1
Next
End Sub
Sub tStackHandler.ppush(valu As t_StackElement)
If stackp = marker Then preserve
p[stackp] = valu: stackp += 1
End Sub
function tStackHandler.ppop() as t_StackElement
stackp -= 1
return p[stackp]
End Function
' ========= end of stack.bas ========= '
function ctm_merge(A() as MyType, L as CtmNode ptr, R as CtmNode ptr) as CtmNode ptr
if L=0 then return R
if R=0 then return L
dim as CtmNode Ptr ins, nxt
'if (predicate(left.value, right.value)) {
viscompare A(), L->visual_index, R->visual_index
if L->value < R->value then
ins = R
nxt = L
else
ins = L
nxt = R
EndIf
swap nxt->lhs, nxt->rhs
nxt->rhs = ctm_merge(A(), ins, nxt->rhs)
return nxt
end function
sub CartesianTreeMerge(A() as MyType)
var length=ubound(a) - lbound(a) + 1
if length <= 1 then exit sub
var root = new CtmNode(a(0),0,0,0)
var last = root
dim as tStackHandler stack
for i as integer = 1 to length - 1
' while(!predicate(last.value, array[i])) {
VisCompare A(),i,last->visual_index
while last->value >= a(i)
if stack.stackp then
last = stack.ppop
else
last = 0
exit while
end if
wend
if last then
viscompare a(), i, last->visual_index
last->rhs = new CtmNode(a(i), last->rhs, 0, i)
stack.ppush(last)
last = last->rhs
else
viscompare a(), i, root->visual_index
root = new CtmNode(a(i), root, 0, i)
last = root
stack.ppush last
end if
next
var i = 0
while root
zSwapPause
DrawBar(A,i,BackRGB)
a(i) = root->value
DrawBar(A,i,ForeRGB)
i += 1
root = ctm_merge(A(), root->lhs, root->rhs)
wend
end sub
sub Flash(A() as MyType)
'' http://www.neubert.net/Flapaper/9802n.htm
dim as single ANMIN=A(0)
dim as integer NMAX=0,NMIN=0 ''NMIN for visual only
for i as integer = 1 to ub
VisCompare A(),I,0
IF A(I)<ANMIN then ANMIN=A(I): NMIN=I
IF A(I)>A(NMAX) then NMAX=I
Next
IF ANMIN=A(NMAX) then exit sub
dim as integer N=UB-LB+1,M=N*0.1,J,K,I,L(UB)
dim as single C1=M / (A(NMAX) - ANMIN)
for I=0 to N-1
L( INT( C1 * ( A(I) - ANMIN)))+=1
Next
for k as integer = 1 to M-1
L(K)+=L(K - 1)
if L(K)>ub then L(K)=UB
next
zVisSwap(A,NMAX,0)
' =============================== PERMUTATION =====
dim as integer NMOVE=0
J=0: K=M-1
DO WHILE (NMOVE<N - 1)
DO WHILE (J>L(K))
J+=1
K= INT(C1 * (A(J) - ANMIN))
VisCompare A(),J,NMIN
loop
dim as integer R = J '' visual
dim as single sFLASH=A(J)
DO WHILE J<>L(K)+1
K= INT(C1 * (sFLASH - ANMIN))
zVisSwapPre(A,R,L(K))
swap A(L(K)),sFLASH
zVisSwapPost(A,R,L(K))
zSwapPause
R=L(K)
L(K)-=1: NMOVE+=1
loop
loop
InsertionSort A()
End Sub
' ============================
' = Interface
' ============================
Private Sub ToggleMaMi
If ModeMaMi = 0 Then Micro.sCountE=mDemo.sCountE Else Macro.sCountE=mDemo.sCountE
ModeMaMi = 1 - ModeMaMi
If ModeMaMi = 0 Then mDemo = Micro Else mDemo = Macro
Q = 1
RedimALL MyData(), mDemo.sCountE
End Sub
Sub PrintF1()
Print "Other keys:"
Print
Print "M - Micro vs. Macro"
Print "C - Create random values"
Print "V - Reverse Line"
Print
Print "Up/Down - Resize"
Print "Num 1 to 9 - Lenticular Gap"
Print
Print "F1 - switch help"
End Sub
Sub PrintInfo()
Cls
If mShowHelp2 Then
PrintF1
Else
Print "Press a key for a different sort:"
Print
Print "A - Quick"
Print "F - Flash"
Print "T - Cartesian Tree Merge"
Print "H - Heap"
Print "K - Cascade"
Print "L - Lerp"
Print "G - Comb"
Print "J - Comb Experiment"
Print "I - Insertion (shift-i for Lenticular gap)"
Print "E - Exchange-Insertion"
Print "W - Primes Exchange-Insertion"
Print
Print "R - Randomize array"
Print
Print "F1 - switch help"
End If
Print
DrawData
End Sub
Sub Key_Repeat (Byval scancode As Integer, Byval ascii As Integer)
Select Case scancode
Case SC_DOWN
RequestSizeUp
Case SC_UP
RequestSizeDown
End Select
End Sub
Private Sub Sorts(Key_ As Integer,A() As single)
If Q <> 0 Then TriggerBreak(): Exit Sub
PrintInfo()
Q = Q + 1
Select Case Key_
Case SC_A
? "Quick"
QuickSort2 A()
Case SC_F
? "Flash"
Flash A()
Case SC_T
? "Cartesian Tree Merge"
CartesianTreeMerge A()
Case SC_H
? "Heap"
heapsort A()
Case SC_G
? "Comb"
CombSort A()
Q = 0 ''Skip Validation
Case SC_J
? "Comb Exp"
CombSortE A()
Q = 0 ''Skip Validation
Case SC_L
? "Lerp"
LerpSort A()
Case SC_K
? "Cascade"
CascadeSort A(), 1
Q = 0 ''Skip Validation
Case SC_E
? "Exchange-Insertion"
ExchangeSort A(),1
Q = 0 ''Skip Validation
Case SC_I
? "Insertion"
InsertionSort A(),1
Q = 0 ''Skip Validation
Case SC_W
? "Primes Exchange-Insertion"
ExchangeSort A(),Sqr(UB+1)
InsertionSort A(),5
InsertionSort A(),2
InsertionSort A(),1
Q = 0 ''Skip Validation
End Select
If Q <> 1 Then SortError = 0: Exit Sub '' user-request mid-sort
Validate A()
End Sub
Sub Key_Press (Byval scancode As Integer, Byval ascii As Integer)
SelCase( scancode ) SC_A, SC_F, SC_T, SC_L, SC_G, SC_J, SC_I, SC_E, SC_K, SC_H, SC_W
Sorts scancode, MyData()
Case SC_R
RandomizeArray MyData()
PrintInfo
Case SC_C
CreateRNDVals MyData()
PrintInfo
Case SC_B
CamelHump MyData()
PrintInfo
Case SC_V
Reversed MyData()
PrintInfo
Case SC_M
ToggleMaMi
Case SC_F1
mShowHelp2 = 1 - mShowHelp2
PrintInfo
Case SC_DOWN
RequestSizeUp
Case SC_UP
RequestSizeDown
Case SC_SPACE
TriggerBreak()
Case 42 'Shift
ShiftKey = -1
End Select
End Sub
Sub Key_Release (Byval scancode As Integer, Byval ascii As Integer)
SelCase( scancode ) SC_DOWN
RedimALL MyData(),mDemo.sCountE
Case SC_UP
RedimALL MyData(),mDemo.sCountE
Case 29 'Ctrl
ColorSet (1 + CSChoice) Mod (UBound(Cols) + 1)
DrawData
Case 42 'Shift
ShiftKey = 0
Case 2 To 10 'Number Key (not keypad)
PrintInfo
mGap = scancode - 1
? "Gap = " & mGap
Case SC_ESCAPE
Running = FALSE
TriggerBreak()
End Select
End Sub
SCR_W = 640
SCR_H = 480
WidM = SCR_W - 1
HgtM = SCR_H - 1
ScreenRes SCR_W,SCR_H,32,,&h20
SetDefaults
'SetRC(RC_DOWN) ' rounding mode: down
Do While Running
KeyEvents()
Sleep 10
Loop
' ----------------------------------------------------------------------
' ======================================================================
' ============================
' = Example Vis
' ============================
'Sub ExchangeSort(A() As Single)
'Dim I As Integer,J As Integer
' For I = 0 To UB - 1
' For J = UB To I+1 Step -1
' zVisIfSwap(A,I,J) 'if A(I) < A(J) then swap
' UserInput() '' Key press
' Next
' Next
'End Sub
'' -- HELPER SUB --
'VisCompare A(),I,I + 1 ''visualize a compare
'If A(I) < A(I+1) Then
'' -- 3 HELPER MACROS --
'' -- automatic swap/copy/compare
'zVisSwap(A,head,rt) ''Swap A(head), A(rt)
'zVisCopy(A,K,SwapVar) ''A(K) = SwapVar
'zVisIfSwap(A,I,J) ''If A(I) < A(J) Then Swap
'' -- 3 steps to "register" a sort
'' 1. Add a keystroke
'Private Sub KeyDown(KeyVal As Integer)
' Select Case KeyVal
' Case SC_F, SC_L, SC_G, SC_I, SC_Q, SC_E, SC_W
'' 2. Call new sort from sorts() using new letter
'' 3. List it in PrintInfo
' ----------------------------------------------------------------------
' ======================================================================