visual sorts

[dafhi]

[2023 June 3] - commented out asm to get demo working again

[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

' ----------------------------------------------------------------------
' ======================================================================

[j_milton]

Throws lots of errors when I attempt to compile, could you please post your compiler command line?

Thanks

[fxm]

Throws lots of errors when I attempt to compile, could you please post your compiler command line?

Thanks

This demo runs in Visual Basic 6.0

[dafhi]

Update: properly formatted to eliminate aforementioned errors :)

[dodicat]

Update: properly formatted to eliminate aforementioned errors :)

Thanks for the update dafhi, it works fine now.
I've got a couple extra to put into my own visual sorts, maybe tomorrow.
But Hey, you wanted a Leonardo number generator, so I threw one together specially for you:

Code: Select all

'LEONARDO
Function plus(NUM1 As String,NUM2 As String) As String
    dim as string * 20 S1="01234567890123456789"
   dim as string * 20 S2=string(10,chr(0))+string(10,chr(1)) 
        var flag =0
 #macro finish()
  answer=Ltrim(answer,"0")
        If answer="" Then Return "0"
       If flag=1 Then Swap NUM2,NUM1
       Return answer
 #endmacro
 var lenf=Len(NUM1)
 var lens=Len(NUM2)
 If lens>lenf Then 
 Swap NUM2,NUM1
 Swap lens,lenf
 flag=1
 Endif

        var diff =lenf-lens-Sgn(lenf-lens)
       dim as string answer="0"+NUM1
       dim as string two=String(lenf-lens,"0")+NUM2
        Dim As Long n2
       var addcarry=0
        var addup=0   
         For n2=lenf-1 To diff Step -1 
          addup=two[n2]+NUM1[n2]-96
            answer[n2+1]=S1[addup+addcarry]
            addcarry=S2[addup+addcarry]
        Next n2 
       
        If addcarry=0 Then 
        finish()
        Endif
        If n2=-1 Then 
        answer[0]=addcarry+48
         finish()
        Endif

        For n2=n2 To 0 Step -1 
             addup=two[n2]+NUM1[n2]-96
               answer[n2+1]=S1[addup+addcarry]
            addcarry=S2[addup+addcarry]
        Next n2
        answer[0]=addcarry+48
    finish()
End Function
function  Leonardo(num as long) as string
  dim as string sl="1",l=sl,term
  if num = 0 then return "1"
  if num=1 then return "1"
  for x as long= 1 to num
      term=plus(plus(l,sl),"1")
      sl=l
      l=term
      next x
  function =term
end function

for x as integer=0 to 297
print Leonardo(x)
next x
sleep

[dafhi]

@dodi - that's pretty cool

Looking forward to seeing your sorts demo.