FreeBASIC ソート過程を可視化 2 Visual Sort

'Visual Sort
'by denise_amiga ≫ Jun 05, 2019 10:10 
'Last edited by denise_amiga on Jun 05, 2019 17:11. 
'https://www.freebasic.net/forum/viewtopic.php?f=7&t=27665

' Sets the graphics method GDI
' 描画方法を GDI に設定
SetEnviron("fbgfx=GDI")

#Include "fbgfx.bi"
#If __FB_LANG__ = "fb"
Using FB '' 画面モード旗は、lang FB の FB名前空間にあります。
#EndIf

'' 画面モード18（640*480）色深度 32bpp を 4ページ設定します。 ウィンドウモード、スイッチング無効。
'Screen 18, 32, 4, (GFX_WINDOWED Or GFX_NO_SWITCH)

#Define inc += 1
#Define dec -= 1

#Define hres 1024
#Define vres 600

#Define mode1 1
#Define mode2 2
#Define mode3 4

ScreenRes hres, vres, 8, 2
ScreenSet 1, 0

'dim as String k, buff
Dim As Long a(hres)
Dim Shared As Long dcmp, dswap, plot, sync = 0, r=1
Dim Shared As String dmeth
Dim As Long modes(4) => {0,1,2,4}
Dim Shared As String smodes(4) '=> {"off", "mode1", "mode2", "mode3"}
smodes(0)="off":smodes(1)="mode1":smodes(2)="mode2":smodes(3)="mode3"

Sub display(a() As Long)
   Cls
   For i As Long = 0 To UBound(a)
      If plot = 0 Then
         PSet (i,a(i)+vres\4)
      Else
         Line (i,(a(i)\2+vres\2))-(i,(-a(i)\2+vres\2)) 
      End If
   Next
   Locate 3,100:Print "Comparison: " & dcmp   '比較
   Locate 4,100:Print "Interchange: " & dswap '交換
   Locate 5,100:Print "Method: " & dmeth      '方法
   Locate 6,100:Print "ScreenSync: " & smodes(sync)
   If sync = 1 Then ScreenSync
   Dim As String s=InKey
   If s=" " Then 'Multikey(SC_S) Then
      sync inc
      sync Mod= 3
   End If
   ScreenCopy
   Sleep 1,1
End Sub

Sub bubble_sort( a() As Long, l As Long, h As Long )
   Dim As Boolean flag = TRUE
   dcmp = 0
   dswap = 0
   dmeth = "bubble"
   While 1
      flag=TRUE
      For i As Long = 0 To UBound(a)-1
         If a(i)<a(i+1) Then
            Swap a(i), a(i+1)
            dswap inc
            flag=FALSE
         End If
         dcmp inc
         If sync = 2 Then display(a())
         If MultiKey(SC_ESCAPE) Then Exit Sub
      Next
      display(a())
      If flag Then Exit While
   Wend
End Sub

Sub bubble2_sort( a() As Long, l As Long, h As Long )
   dcmp = 0
   dswap = 0
   dmeth = "bubble2"
   For i As Long = 0 To h-1
      For j As Long = 0 To (h-(i+1))
         If a(j)<a(j+1) Then
            Swap a(j), a(j+1)
            dswap inc
         End If
         dcmp inc
         If sync = 2 Then display(a())
         If MultiKey(SC_ESCAPE) Then Exit Sub
      Next
      display(a())
   Next
End Sub

Sub   select_sort( a() As Long, l As Long, h As Long )
   dcmp = 0
   dswap = 0
   dmeth = "select"
   For i As Long = 0 To UBound(a)-1
      Dim As Long k = i
      For j As Long = i+1 To UBound(a)
         If a(j)>a(k) Then k = j
         dcmp inc
         If sync = 2 Then display(a())
         If MultiKey(SC_ESCAPE) Then Exit Sub
      Next
      Swap a(k), a(i)
      dswap inc
      display(a())
   Next
End Sub

Sub insert_sort( a() As Long, l As Long, h As Long )
   dcmp = 0
   dswap = 0
   dmeth = "insertion"
   For i As Long = 1 To UBound(a)
      Dim As Long key = a(i)
      Dim As Long j = i - 1
      While j>=0 AndAlso a(j)<key
         a(j+1) = a(j)
         j -= 1
         dswap inc
         dcmp inc
         If sync = 2 Then display(a())
         If MultiKey(SC_ESCAPE) Then Exit Sub
      Wend
      a(j+1) = key
      dswap inc
      display(a())
   Next
End Sub

Sub shell_sort(a() As Long, l As Long, h As Long )
   dcmp = 0
   dswap = 0
   dmeth = "shell"
   Dim As Long inter = 5
   While inter > 0
      Dim As Long j
      For i As Long = l To h
         Dim As Long key = a(i)
         j = i
         While j >= inter AndAlso a(j-inter) <= key
            a(j) = a(j-inter)
            j = j - inter
            dcmp inc
            dswap inc
            If sync = 2 Then display(a())
            If MultiKey(SC_ESCAPE) Then Exit Sub
         Wend
         a(j) = key
         dswap inc
         display(a())
      Next
      inter = ((inter-1)/5)
   Wend
End Sub

Sub _merge( a() As Long, aa() As Long, l As Long, m As Long, h As Long )
   Dim As Long l1, l2, i
   l1 = l
   l2 = m + 1
   i = l
   While l1 <= m AndAlso l2 <= h
      If a(l1) >= a(l2) Then
         aa(i) = a(l1)
         l1 inc
      Else
         aa(i) = a(l2)
         l2 inc
      End If
      dswap inc
      dcmp inc
      i inc
      If sync = 2 Then display(a())
      If MultiKey(SC_ESCAPE) Then Exit Sub
   Wend
   While l1 <= m
      aa(i) = a(l1)
      i inc
      l1 inc
      dswap inc
      If sync = 2 Then display(a())
      If MultiKey(SC_ESCAPE) Then Exit Sub
   Wend
   While l2 <= h
      aa(i) = a(l2)
      i inc
      l2 inc
      dswap inc
      If sync = 2 Then display(a())
      If MultiKey(SC_ESCAPE) Then Exit Sub
   Wend
   For i = l To h
      a(i) = aa(i)
   Next
   display(a())
End Sub

Sub _merge_rec_sort( a() As Long, aa() As Long, l As Long, h As Long )
   If l < h Then
      If MultiKey(SC_ESCAPE) Then Exit Sub
      Dim As Long m = (l+h)\2
      _merge_rec_sort(a(), aa(), l, m)
      _merge_rec_sort(a(), aa(), m+1, h)
      _merge(a(), aa(), l, m, h)
   End If
End Sub

Sub merge_rec_sort( a() As Long, l As Long, h As Long )
   dcmp = 0
   dswap = 0
   dmeth = "merge (recursive)"
   Dim As Long aa(hres)
   _merge_rec_sort( a(), aa(), l, h )
End Sub

Function _min( a As Long, b As Long ) As Long
   Return IIf( a < b, a, b )
End Function

Sub _merge_ite_sort( a() As Long, aa() As Long, l As Long, h As Long )
   Dim As Long curr_size, lstart
   curr_size = 1
   While curr_size <= h-1
      lstart = 0
      If MultiKey(SC_ESCAPE) Then Exit Sub
      While lstart < h-1
         Dim As Long m = lstart + curr_size - 1
         Dim As Long rend = _min(lstart + 2*curr_size - 1, h - 1 )
         _merge( a(), aa(), lstart, m, rend )
         lstart += (2*curr_size)
      Wend
      curr_size *= 2
   Wend
End Sub

Sub merge_ite_sort( a() As Long, l As Long, h As Long )
   dcmp = 0
   dswap = 0
   dmeth = "merge (iterative)"
   Dim As Long aa(hres)
   _merge_ite_sort( a(), aa(), l, h )
End Sub

Sub _quick_rec_sort( a() As Long, l As Long, h As Long )
   Dim As Long key, i, j, k = (l+h)\2
   If l < h Then
      If MultiKey(SC_ESCAPE) Then Exit Sub
      Swap a(l),a(k)
      dswap inc
      key = a(l)
      i = l+1
      j = h
      While i<=j
         While i<=h AndAlso a(i)>=key
            i inc
            dcmp inc
            If sync = 2 Then display(a())
            If MultiKey(SC_ESCAPE) Then Exit Sub
         Wend
         While j >= l AndAlso a(j)<key
            j -= 1
            dcmp inc
            If sync = 2 Then display(a())
            If MultiKey(SC_ESCAPE) Then Exit Sub
         Wend
         If i < j Then
            Swap a(i),a(j)
            dswap inc
            If sync = 2 Then display(a())
            If MultiKey(SC_ESCAPE) Then Exit Sub
         End If
         display(a())
      Wend
      Swap a(l),a(j)
      dswap inc
      display(a())
      _quick_rec_sort( a(), l, j-1 )
      _quick_rec_sort( a(), j+1, h )
   End If
End Sub

Sub quick_rec_sort( a() As Long, l As Long, h As Long )
   dcmp = 0
   dswap = 0
   dmeth = "quick (recursive)"
   _quick_rec_sort(a(),l,h-1)
End Sub

#Define MAX_LEVELS 64

Function _quick_ite_sort( a() As Long, l As Long, h As Long ) As Long
   Dim As Long ll, rr, i, pstart(MAX_LEVELS), pend(MAX_LEVELS)
   pstart(0) = 0
   pend(0) = h
   While i >= 0
      ll = pstart(i)
      rr = pend(i)
      If (rr - ll) > 1 Then
         Dim As Long m = ll+((rr-ll) Shr 1)
         Dim As Long p = a(m)
         a(m) = a(ll)
         dswap inc
         If i = MAX_LEVELS - 1 Then Return -1
         rr dec 
         While ll < rr
            While a(rr) <= p AndAlso ll < rr
               rr dec
               dcmp inc
               If sync = 2 Then display(a())
               If MultiKey(SC_ESCAPE) Then Exit Function
            Wend
            If ll < rr Then
               a(ll) = a(rr)
               ll inc
               dswap inc
            End If
            While a(ll) >= p AndAlso ll < rr
               ll inc
               dcmp inc
               If sync = 2 Then display(a())
               If MultiKey(SC_ESCAPE) Then Exit Function
            Wend
            If ll < rr Then
               a(rr) = a(ll)
               rr dec 
               dswap inc
            End If
            display( a() )
         Wend
         a(ll) = p
         dswap inc
         m = ll + 1
         While ll > pstart(i) AndAlso a(ll -1) = p
            ll dec
            dcmp inc
            If sync = 2 Then display(a())
            If MultiKey(SC_ESCAPE) Then Exit Function
         Wend
         While m < pend(i) AndAlso a(m) = p
            m inc
            dcmp inc
            If sync = 2 Then display(a())
            If MultiKey(SC_ESCAPE) Then Exit Function
         Wend
         If ll - pstart(i) > pend(i) - m Then
            pstart(i+1) = m
            pend(i+1) = pend(i)
            pend(i) = ll
            i inc
         Else
            pstart(i+1) = pstart(i)
            pend(i+1) = ll
            pstart(i) = m
            i inc
         End If
      Else
         i dec 
      End If
      display( a() )
   Wend
   Return 0
End Function

Sub quick_ite_sort( a() As Long, l As Long, h As Long )
   dcmp = 0
   dswap = 0
   dmeth = "quick (iterative)"
   _quick_ite_sort(a(),l,h)
End Sub

Sub rrandom( a() As Long, s As Long = 1000)
   Randomize IIf(s,1000,Timer)
   For i As Long = LBound(a) To UBound(a)
      a(i)=Rnd*(vres\2)
   Next
End Sub

'for i as Long = 0 to 19
'   ?a(i);
'Next
'?

Do
   Locate 1,2:? "1.- Bubble"
   Locate 2,2:? "2.- Bubble (variant)"  '変化形
   Locate 3,2:? "3.- Select"
   Locate 4,2:? "4.- Insert"
   Locate 5,2:? "5.- Shell"
   Locate 6,2:? "6.- Merge (recursive)"  '再帰
   Locate 7,2:? "7.- Merge (iterative)"  '反復
   Locate 8,2:? "8.- Quick (recursive)"  '再帰
   Locate 9,2:? "9.- Quick (iterative)"  '反復
   
   Locate 11,2:? "q.- Quit (Exit Do)"   
   
   Locate 13,2:? Space(30):Locate 13,2:? "r.- Random " & IIf(r, "off", "on") 
   Locate 14,2:? Space(30):Locate 14,2:? "p.- Draw " & IIf(plot, "line", "plot") '表示方法：点か線か
   Locate 15,2:? Space(30):Locate 15,2:? "(spc).- ScreenSync " & smodes(sync)
   ScreenCopy
   'Cls
   Dim As String k = InKey
   Select Case k
      Case "1":rrandom(a(),r):bubble_sort(a(),LBound(a),UBound(a))
      Case "2":rrandom(a(),r):bubble2_sort(a(),LBound(a),UBound(a))
      Case "3":rrandom(a(),r):select_sort(a(),LBound(a),UBound(a))
      Case "4":rrandom(a(),r):insert_sort(a(),LBound(a),UBound(a))
      Case "5":rrandom(a(),r):shell_sort(a(),LBound(a),UBound(a))
      Case "6":rrandom(a(),r):merge_rec_sort(a(),LBound(a),UBound(a))
      Case "7":rrandom(a(),r):merge_ite_sort(a(),LBound(a),UBound(a))
      Case "8":rrandom(a(),r):quick_rec_sort(a(),LBound(a),UBound(a))
      Case "9":rrandom(a(),r):quick_ite_sort(a(),LBound(a),UBound(a))
      Case "p":plot = 1 - plot
      Case " ":sync inc: sync Mod= 3
      Case "r":r = 1 - r
      Case "q": Exit Do
   End Select
   Sleep 1,1
Loop
'sleep