Code: Select all
'FIVE SORTS
#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)
'__ INITIALIZE ARRAYS_________
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)
'reverse the arrays
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
'__ ARRAYS SET UP _________
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 the array to be sorted
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 'quit by closing window
if e.type=13 then end
end if
'Sort as clicked
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)
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