FreeBASIC ソート過程を可視化 1 Visual Sorts

'Bubble Sort Alphabetize
'by BasicCoder2 ≫ Mar 27, 2014 4:39 
'https://www.freebasic.net/forum/viewtopic.php?f=7&t=22401

'並び変え過程を可視化★

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

'処理時間計測
#include "vbcompat.bi"   'Now を使えるようにする

Dim TimeStart As Double
Dim TimeEnd As Double


ScreenRes 640,480,32

Dim Shared As Integer myData(320),swapDone

Sub displayMyData()
    ScreenLock()
    Cls
    For i As Integer = 0 To 319
        Line (i*2,0)-(i*2,myData(i)),RGB(255,myData(i)\2,0)
    Next i
    ScreenUnlock()
End Sub

'データを初期化する
For i As Integer = 0 To 319
    myData(i)=Int(Rnd(1)*480)
Next i

displayMyData()

'単純なバブルソート
'バブルソート (bubble sort) は、隣り合う要素の大小を比較しながら整列させます。
'最悪計算時間が遅いが、アルゴリズムが単純で実装が容易です。

'全ての要素に関して、隣接する要素と比較し順序が逆であれば入れ替えます。
'これを要素数-1 回繰り返すことでソートを行ないます。
'この繰り返しは、入れ替えが起こらなくなった時点で中断することができます。

TimeStart = Now         ' 開始時刻を変数に格納します。

Do
    swapDone = 0
    For i As Integer = 0 To 318
        If myData(i)>myData(i+1) Then
            Swap myData(i),myData(i+1)
            swapDone = 1
        End If
    Next i
    displayMyData()
    Sleep 10
Loop Until swapDone = 0

TimeEnd = Now           ' 終了時刻を変数に格納します。

Locate 50,1 : Print  "Processing time : hh:mm:ss"
Locate 52,19 : Print Format (TimeEnd - TimeStart, "hh:mm:ss")

Sleep

'Good Old Shellsort
'https://www.freebasic.net/forum/viewtopic.php?f=7&t=26158
'by dafhi ≫ Dec 01, 2017 14:54
'inspired by this thread
'https://www.freebasic.net/forum/viewtopic.php?f=7&t=22401

'並び変え過程を可視化★

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

'処理時間計測
#include "vbcompat.bi"   'Now を使えるようにする

Dim TimeStart As Double
Dim TimeEnd As Double


Const           w = 640
Const           h = 480

Sub Bar(a() As Single, x As Long, Alpha As UByte = 255)
  Line ( x, 0 ) - ( x, Int( a(x)*h ) ), RGB(Alpha, a(x)*Alpha, 0)
End Sub

Sub show_lines(a() As Single, i As Long, j As Long, Alpha As UByte = 255)
  bar a(), i, Alpha
  bar a(), j, Alpha
End Sub

Sub rand_vals(a() As Single, quant As Long = 0)
  If quant < 1 Then quant = 5*h
  For i As Long = 0 To UBound(a)
    a(i) = Int(Rnd*(quant+1))/quant
  Next
 
  '' 値を表示する
  Cls
  For x As Long = 0 To UBound(a)
    bar a(), x
  Next
End Sub

'シェルソート(Shell sort)は、交換によるソート（バブルソート）や挿入によるソート（挿入ソート）を一般化したものです。
'まず、間隔の離れた要素の組に対してソートを行い、だんだんと比較する要素間の間隔を小さくしながらソートを繰り返します。
'離れた場所の要素からソートを始めることで、単純に近くの要素を比較する場合よりも速く、要素を所定の位置に移動させることができます。
Sub Shellsort(arr() As Single)
 
  Var n1 = LBound(arr)
  Var n2 = UBound(arr)
  Var max = n2 - n1 + 1
  Var nswap = FALSE
 
  Do
    max = max \ 2
    Do
      nswap = FALSE
      For i As Long = n1 To n2 - max
        Var j = i + max
        If arr(i) > arr(j) Then
          show_lines arr(), i, j, 0
          Swap arr(i), arr(j)
          show_lines arr(), i, j
          nswap = TRUE
          Sleep 5,1
        End If
        If InKey<>"" Then Exit Sub
      Next
    Loop While nswap
  Loop Until max = 1

End Sub

ScreenRes w,h,32

Dim As Single   a(w - 1)

Var quant = 16

rand_vals a(), quant

TimeStart = Now         ' 開始時刻を変数に格納します。

shellsort a()

TimeEnd = Now           ' 終了時刻を変数に格納します。

Locate 50,1 : Print  "Processing time : hh:mm:ss"
Locate 52,19 : Print Format (TimeEnd - TimeStart, "hh:mm:ss")
Sleep

'Bubble Sort Alphabetize
'by dafhi ≫ Mar 27, 2014 6:13 
'https://www.freebasic.net/forum/viewtopic.php?f=7&t=22401
'Last edited by dafhi on Dec 01, 2017 16:01, edited 4 times in total. 

'並び変え過程を可視化★

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

'処理時間計測
#include "vbcompat.bi"   'Now を使えるようにする

Dim TimeStart As Double
Dim TimeEnd As Double


Const           w = 640
Const           h = 480

Sub Bar(a() As Single, x As Long, Alpha As UByte = 255)
  Line ( x, 0 ) - ( x, Int( a(x)*h ) ), RGB(Alpha, a(x)*Alpha, 0)
End Sub

Sub show_lines(a() As Single, i As Long, j As Long, Alpha As UByte = 255)
  Bar a(), i, Alpha
  Bar a(), j, Alpha
End Sub

Sub rand_vals(a() As Single, quant As Long = 0)
  If quant < 1 Then quant = 5*h
  For i As Long = 0 To UBound(a)
    a(i) = Int(Rnd*(quant+1))/quant
  Next
 
  '' 値を表示する
  Cls
  For x As Long = 0 To UBound(a)
    Bar a(), x
  Next
End Sub

#Macro setsort(datatype,fname,b1,b2,dot) 'my quicksort, dodicat's macro
Sub fname(a() As datatype, lb As Long=0, ub As Long=0) '2017 Oct 6
  #Macro sw(x,y)
    If a(x)dot b2 a(y)dot Then
      show_lines a(), x, y, 0
      Swap a(x),a(y)
      show_lines a(), x, y
      Sleep 5, 1
    EndIf
  #EndMacro

  'YouTube クイックソート Z5nSXTnD1I4 に基づいて....
  'https://www.youtube.com/watch?v=Z5nSXTnD1I4
  'http://blog.bodurov.com/Visualizing-QuickSort-Algorithm

  '最初の要素はピボット
  Var j=(lb+ub)\2
  sw(j,ub):  If lb>=ub-1 Then Exit Sub      '2017 Oct 6
  sw(j,lb)
  sw(lb,ub) 'After 3 swaps:  [mid][lo][hi]
  If lb<ub-1 Then                           '2017 Oct 4
    j=ub: Var i=lb
    While i<j
      j-=1                                  '2017 Oct 6
      While a(j)dot b2 a(lb)dot: j-=1: Wend
      i+=1
      While a(i)dot b1 a(lb)dot: i+=1: Wend
      If j<=i Then i=j: Exit While
      sw(i,j)
    Wend
    sw(lb,j)
    i-=1: If lb<i Then fname a(), lb,i
    j+=1: If j<ub Then fname a(), j,ub
  EndIf
End Sub
#EndMacro
'**************************************


#define up <,>
#define down >,<
'        udt  name  dirn field

setsort(Single,quicksort,up,)

ScreenRes w,h,32

Dim As Single   a(w - 1)

Var quant = 16

rand_vals a(), quant

TimeStart = Now         ' 開始時刻を変数に格納します。

quicksort a(), 0, w - 1

TimeEnd = Now           ' 終了時刻を変数に格納します。

Locate 50,1 : Print  "Processing time : hh:mm:ss"
Locate 52,19 : Print Format (TimeEnd - TimeStart, "hh:mm:ss")

Sleep

'Visual sorts
'Quote
'Postby dodicat ≫ Apr 21, 2011 21:58 
'A view of five sorts in action. 
'https://www.freebasic.net/forum/viewtopic.php?t=17702


'FIVE SORTS
'5 種類のソート方法で、ソートの過程を可視化します。
'右下のスライダーをクリックして、処理速度を調整すると、過程を見やすくできます。

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

#Include "fbgfx.bi"
Dim Shared As Integer xres,yres
Screen 19,32
ScreenInfo xres,yres
Type box
    As Single x,y,z
    As String caption
    As UInteger textcol,boxcol
End Type

#define rect 4
Declare Sub thickline(x1 As Double,_
                     y1 As Double,_
                     x2 As Double,_
                     y2 As Double,_
                     thickness As Double,_
                     colour As UInteger,_
                     im As Any Pointer=0)
            
Declare Sub drawbars(arr() As Double,col() As UInteger)
Declare Sub bubblesort(array() As Double)
Declare Sub exchangesort(array() As Double)
Declare Sub shellsort(array() As Double)
Declare Sub insertionsort(array() As Double)
Declare Sub quicksort(arr() As Double,D As String="up")
Declare Sub set_bar_colours(arr() As Double)
Declare Sub resetarray
Declare Sub delay(n As Double)

Declare Function inbox(p1() As box,p2 As box) As Integer
Declare Sub On_Click(box() As box,mp As box)
Declare Sub drawbox(x As Integer,y As Integer,box()As box,boxlength As Integer,boxheight As Integer,boxcolour As UInteger,outline As UInteger,highlight As UInteger,caption As String)
Declare Sub draw_box(p() As box,col As UInteger,pnt As String="paint",im As Any Pointer=0)

Dim Shared As box label(rect,1)
Dim Shared As box button(rect,1)
Dim Shared As fb.event e
Dim Shared As Integer counter
Dim As String Btime,Etime,Stime,Itime,Qtime
Dim As Single t1,t2
Dim Shared As Integer exchange,bubble,_shell,insertion,quick,slider_val=600
Dim Shared As Integer sleeptime,bars=28
Dim Shared As UInteger bar_colour(1 To bars)
Dim Shared As Double ref(1 To bars)
Dim Shared As UInteger refcolour(1 To bars)
Dim Shared As Double sort(1 To bars)
Dim As UInteger background=RGB(100,100,100)

'__ 配列を初期化する _________
For x As Integer=1 To bars 
   ref(x)=x/bars
   'ref(x)=rnd*1
   refcolour(x)=RGB(Rnd*255,Rnd*255,Rnd*255)
   bar_colour(x)=refcolour(x)
   sort(x)=ref(x)
Next x
Dim As Integer lb=LBound(ref),ub=UBound(ref)
'配列を逆にする
For n As Integer=Lb To Int((lb+Ub)/2):Swap ref(n),ref(ub+lb-n):Next
For n As Integer=Lb To Int((lb+Ub)/2):Swap sort(n),sort(ub+lb-n):Next 

'__ 配列をセット _________

Do
   counter=0
   ScreenLock
   Cls
   Paint(0,0),background
   
   drawbox(290,40,label(),420,460,RGB(0,00,0),RGB(120,20,20),RGB(120,20,20),"")'big box
   drawbars(ref(),refcolour()) 'ソートされる配列を描画する
   
   Draw String(100,50),"SORTS:",RGB(255,255,255)
   Draw String(10,115),Btime
   Draw String(10,215),Etime
   Draw String(10,315),Stime
   Draw String(10,415),Itime
   Draw String(10,515),Qtime
   Draw String (290,20),"Press esc to exit any sort",RGB(200,200,200)
   
   drawbox(100,100,button(),110,50,RGB(200,200,0),RGB(255,255,255),RGB(00,0,200),"BUBBLE")
   drawbox(100,200,button(),110,50,RGB(200,200,0),RGB(255,255,255),RGB(00,0,200),"EXCHANGE")
   drawbox(100,300,button(),110,50,RGB(200,200,0),RGB(255,255,255),RGB(00,0,200),"SHELL")
   drawbox(100,400,button(),110,50,RGB(200,200,0),RGB(255,255,255),RGB(00,0,200),"INSERTION")
   drawbox(100,500,button(),110,50,RGB(200,200,0),RGB(255,255,255),RGB(00,0,200),"QUICK")
   
   drawbox(250,560,label(),350,15,RGB(150,100,00),RGB(250,155,5),RGB(250,155,5),"")'slider box
   Draw String(250,540),"Min --------------- speed -------------- Max",RGB(200,200,200)
   drawbox(slider_val,560,label(),1,15,RGB(0,00,200),RGB(50,55,5),RGB(50,55,5),"")'slider
   
   If (ScreenEvent(@e)) Then 'ウィンドウを閉じて終了する
     If e.type=13 Then End
   End If
   'クリックして並べ替える
   If bubble Then
      resetarray
      t1=Timer
      bubblesort(sort()):t2=Timer:delay(1e8)
      Btime=Left(Str(t2-t1),5)
      bubble=0
   End If
   If exchange Then 
      resetarray
      t1=Timer
      exchangesort(sort()):t2=Timer:delay(1e8)
      Etime=Left(Str(t2-t1),5)
      exchange=0
   End If
   If _shell Then 
      resetarray
      t1=Timer
      shellsort(sort()):t2=Timer:delay(1e8)
      Stime=Left(Str(t2-t1),5)
      _shell=0
   End If
   If insertion Then 
      resetarray
      t1=Timer
      insertionsort(sort()):t2=Timer:delay(1e8)
      Itime=Left(Str(t2-t1),5)
      insertion=0
   End If
   If quick Then 
      resetarray
      t1=Timer
      quicksort(sort()):t2=Timer:delay(1e8)
      Qtime=Left(Str(t2-t1),5)
      quick=0
   End If
   ScreenUnLock
   Sleep 1,1
Loop Until Inkey=Chr(27) 'ESC エスケープキー 

Sub draw_box(p() As box,col As UInteger,pnt As String="paint",im As Any Pointer=0)
    Dim As Single n1= p(rect,0).z
    Dim As Integer index,nextindex
    Dim As Double xc,yc
    For n As Integer=1 To 4
        xc=xc+p(n,n1).x:yc=yc+p(n,n1).y
        index=n Mod 5:nextindex=(n+1) Mod 5
        If nextindex=0 Then nextindex=1
        thickline(p(index,n1).x,p(index,n1).y,p(nextindex,n1).x,p(nextindex,n1).y,4,col,im)
        'Line im,(p(index,n1).x,p(index,n1).y)-(p(nextindex,n1).x,p(nextindex,n1).y),col
    Next
    xc=xc/UBound(p):yc=yc/UBound(p)
    If pnt="paint" Then Paint (xc,yc),col,col
End Sub

Function inbox(p1() As box,p2 As box) As Integer
    Type pt2d:As Single x,y:End Type
    Type ln2d:As pt2d v1,v2:End Type
    
    #Macro isleft(L,p)
    -Sgn(  (L.v1.x-L.v2.x)*(p.y-L.v2.y) - (p.x-L.v2.x)*(L.v1.y-L.v2.y))
    #EndMacro
    Dim As Single n1=p1(rect,0).z
    Dim As Integer index,nextindex
    Dim send As ln2d
    Dim wn As Integer=0
    For n As Integer=1 To 4
        index=n Mod 5:nextindex=(n+1) Mod 5
        If nextindex=0 Then nextindex=1
        send.v1.x=p1(index,n1).x:send.v2.x=p1(nextindex,n1).x
        send.v1.y=p1(index,n1).y:send.v2.y=p1(nextindex,n1).y
        If p1(index,n1).y<=p2.y Then
            If p1(nextindex,n1).y>p2.y Then 
                If isleft(send,p2)>0 Then 
                    wn=wn+1
                End If
            End If
        Else
            If p1(nextindex,n1).y<=p2.y Then
                If isleft(send,p2)<0 Then
                    wn=wn-1
                End If
            End If
        End If
    Next n
    Return wn
End Function

Sub drawbox(x As Integer,y As Integer,box()As box,boxlength As Integer,boxheight As Integer,boxcolour As UInteger,outline As UInteger,highlight As UInteger,caption As String)
   counter=counter+1
   Dim As box startpoint 
   startpoint.x=x:startpoint.y=y
   Dim As Integer mmx,mmy
   GetMouse mmx,mmy
   Dim As box mouse
   mouse.x=mmx
   mouse.y=mmy
   box(rect,1).boxcol=boxcolour
   box(rect,1).caption=caption
   Dim As Integer count=1
   #Macro _highlightbox()
   box(rect,0).z=1
   If inbox(box(),mouse) Then draw_box(box(),highlight,"dont_paint")
   #EndMacro
   For x As Integer=1 To 4
      Select Case x
         Case 1
             box(1,count).x=startpoint.x
             box(1,count).y=startpoint.y
         Case 2
             box(2,count).x=box(1,count).x+boxlength
             box(2,count).y=box(1,count).y
         Case 3
             box(3,count).x=box(2,count).x
             box(3,count).y=box(2,count).y+boxheight
         Case 4
             box(4,count).x=box(3,count).x-boxlength
             box(4,count).y=box(3,count).y
      End Select
   Next x
   box(rect,0).z=1
   draw_box(box(),boxcolour)
   draw_box(box(),outline,"nopaint")
   If inbox(box(),mouse) Then
      _highlightbox()
      If (ScreenEvent(@e)) Then
         If e.type=fb.EVENT_MOUSE_BUTTON_PRESS Then
           On_Click(box(),mouse)
         End If
      End If
   End If
   Draw String(box(1,1).x+5,box(1,1).y+5),box(rect,1).caption,box(rect,1).textcol
End Sub

Sub On_Click(box() As box,mp As box)
       
   If counter=2 Then
       bubble=1:exchange=0:_shell=0:insertion=0:quick=0
   End If
   If counter=3 Then
       bubble=0:exchange=1:_shell=0:insertion=0:quick=0
   End If
   If counter=4 Then
       bubble=0:exchange=0:_shell=1:insertion=0:quick=0
   End If
   If counter=5 Then
       insertion=1:bubble=0:exchange=0:_shell=0:quick=0
   End If
   If counter=6 Then
       quick=1:insertion=0:bubble=0:exchange=0:_shell=0
   End If
   If counter=7 Then
       slider_val=mp.x
       sleeptime=(600-slider_val)/2
   End If
End Sub


Sub thickline(x1 As Double,_
              y1 As Double,_
              x2 As Double,_
              y2 As Double,_
              thickness As Double,_
              colour As UInteger,_
              im As Any Pointer=0)
   Dim p As UInteger=RGB(255, 255, 254)
   If thickness<2 Then
      Line(x1,y1)-(x2,y2),colour
   Else               
      Dim As Double h=Sqr((x2-x1)^2+(y2-y1)^2):If h=0 Then h=1e-6
      Dim As Double s= (y1-y2)/h ,c=(x2-x1)/h 
      For x As Integer=1 To 2
         Line im,(x1+s*thickness/2,y1+c*thickness/2)-(x2+s*thickness/2,y2+c*thickness/2),p
         Line im,(x1-s*thickness/2,y1-c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),p
         Line im,(x1+s*thickness/2,y1+c*thickness/2)-(x1-s*thickness/2,y1-c*thickness/2),p
         Line im,(x2+s*thickness/2,y2+c*thickness/2)-(x2-s*thickness/2,y2-c*thickness/2),p
         Paint im,((x1+x2)/2, (y1+y2)/2), p, p
         p=colour
      Next x
   End If
End Sub

Sub bubblesort(array() As Double)
   Paint(301,51),RGB(0,0,0),RGB(120,20,20)
   Dim As Integer n=UBound(array)
   For p1 As Integer = 1 To n - 1
       For p2 As Integer  = p1 + 1 To n 
        If (array(p1)) >= (array(p2)) Then Swap array(p1),array(p2):Swap bar_colour(p1),bar_colour(p2)
        ScreenUnLock
        Sleep sleeptime
        ScreenLock
        If Inkey=Chr(27) Then Exit Sub
        Paint(309,59),RGB(0,0,0),RGB(120,20,20)
        drawbars(array(),bar_colour())
      Next p2
   Next p1
   ScreenUnLock
End Sub

Sub exchangesort(array() As Double)
   For i As Integer=1 To UBound(array)
        Dim As Integer min=i
        For j As Integer=i+1 To UBound(array)
            If (array(j) < array(min)) Then min=j
        Next j
        If min>i Then Swap array(i), array(min):Swap bar_colour(i),bar_colour(min)
         
        ScreenUnLock
        Sleep sleeptime
        ScreenLock
        If Inkey=Chr(27) Then Exit Sub
        Paint(309,59),RGB(0,0,0),RGB(120,20,20)
        drawbars(array(),bar_colour())
   Next i
   ScreenUnLock
End Sub

Sub shellsort(array() As Double)
   Dim As Integer half=UBound(array)/2,limit,switch
   While half>0
      limit = UBound(array) - half 
      Do
         switch = 0 
         For x As Integer= 1 To limit 
            If array(x) >array(x + half) Then
              Swap array(x),array(x + half)
              Swap bar_colour(x),bar_colour(x+half)      
              ScreenUnLock
              Sleep sleeptime
              ScreenLock
              If Inkey=Chr(27) Then Exit Sub
              Paint(309,59),RGB(0,0,0),RGB(120,20,20)
              drawbars(array(),bar_colour())
              switch = x
            End If
          Next x
      Loop Until switch=0
      half = half \ 2
   Wend
   ScreenUnLock
End Sub

Sub insertionsort(array() As Double)
   Dim As Double temp,temp2
   Dim As Integer j
   For row As Integer= 2 To UBound(array)
      temp = array(row)
      temp2 = temp
      j = row
      While j>=2 And array(j-1)>temp2
           array(j) = array(j - 1)
           Swap bar_colour(j),bar_colour(j-1)
           j=j-1
      Wend
      array(j)=temp
      ScreenUnLock
      Sleep sleeptime
      ScreenLock
      If Inkey=Chr(27) Then Exit Sub
      Paint(309,59),RGB(0,0,0),RGB(120,20,20)
      drawbars(array(),bar_colour())
   Next row
   ScreenUnLock
End Sub 
'_________________________________ QUICKSORT
Sub MD(g As Long,d As Long,a()As Double)
   Dim As Double v,t:Dim As Byte o:Dim As Long i,j
   If g<d Then:v=a(d):i=g-1:j=d
   Do
      Do:i=i+1:Loop Until a(i)>=v:o=0
      Do
         If j>LBound(a) Then:j=j-1:Else:o=1:EndIf
         If a(j)<=v Then o=1 
      Loop Until o<>0
      Swap a(i),a(j)
   Loop Until j<=i
   t=a(j):a(j)=a(i):a(i)=a(d):a(d)=t
   Swap bar_colour(i),bar_colour(d)
   ScreenUnLock
   Sleep sleeptime
   ScreenLock
   If Inkey=Chr(27) Then Exit Sub
       Paint(309,59),RGB(0,0,0),RGB(120,20,20)
       drawbars(a(),bar_colour())
       MD(g,i-1,a())
       MD(i+1,d,a())
    EndIf
End Sub
    
Sub quicksort(arr() As Double,D As String="up")
   D=LCase(D)
   MD(LBound(arr),UBound(arr),arr())
   Select Case D
       'Case "up"
       Case "down"
       Dim As Long lb,ub:lb=LBound(arr):ub=UBound(arr)
       For n As Long=Lb To Int((lb+Ub)/2):Swap arr(n),arr(ub+lb-n):Next
   End Select
ScreenUnLock
End Sub 
'_________________________
 Sub set_bar_colours(arr() As Double)
   For z As Integer=1 To UBound(arr)
      bar_colour(z)=RGB(Rnd*255,Rnd*255,Rnd*255)
   Next z
End Sub
        
Sub drawbars(arr() As Double,col() As UInteger)
     Dim As Integer down
     For z As Integer=1 To UBound(arr)
        Dim As Double k=arr(z)
        thickline(500,50+down,500+k*(700-500),50+down,6,col(z))
        thickline(500,50+down,500-k*(700-500),50+down,6,col(z))
        down=down+16
     Next z
End Sub 

Sub resetarray
    For z As Integer=1 To bars
       sort(z)=ref(z)
       bar_colour(z)=refcolour(z)
    Next z
End Sub

Sub delay(n As Double)
    For x As Double=1 To n
    Next x
 End Sub