Visual sorts

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
dodicat
Posts: 5951
Joined: Jan 10, 2006 20:30
Location: Scotland

Visual sorts

Postby dodicat » Apr 21, 2011 21:58

A view of five sorts in action.

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
   
srvaldez
Posts: 2111
Joined: Sep 25, 2005 21:54

Postby srvaldez » Apr 21, 2011 23:26

nice work dodicat, my times are as follows

Bubble 1.236
Exchange 0.096
Shell 0.180
Insertion 0.085
Quick 0.084
dafhi
Posts: 1251
Joined: Jun 04, 2005 9:51

Postby dafhi » Apr 22, 2011 4:44

vdecampo's post on qsort got me hyped. I intended to speed up the bubble sort by storing location of lowest and highest values, and researched thereafter, finding that I had coded a bi-directional selection sort. It's about twice as fast as bubble
fxm
Posts: 9190
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Postby fxm » Apr 22, 2011 6:05

- Compiled with option -exx:
INSERTION:
Aborting due to runtime error 6 (out of bounds array access) at line 344 of ...
(344) while j>=2 and array(j-1)>temp2

- But it seems to run normally without the option -exx, because it's just an error at the exit condition (second test after the 'and') of the 'while' (when j=1) at line 344.

- I modified line 344:
(344) while j>=2 andalso array(j-1)>temp2
because 'array(0)' is not defined.


my PC wrote:BUBBLE 1.431
EXCHANGE 0.105
SHELL 0.208
INSERTION 0.101
QUICK 0.102
Portable Lenovo with Intel Core 2 Duo P8400 / 2.26 GHz
dodicat
Posts: 5951
Joined: Jan 10, 2006 20:30
Location: Scotland

Postby dodicat » Apr 24, 2011 2:05

Thanks for the times srvaldez, my box is 2 x dual core Xeons at 3000 Mhz, and is a shade slower than yours.

@ fxm
I've fixed that bug and added another sort, also I've adjusted all the other sorts for arrays using the 0 element, because the Gnomesort must include the 0'th element.
Also I've used different fonts and made the initial array random, rather than uniform.
@ dafhi
The bubblesort seems slow in comparison, but it has it's uses.
Maybe you could post the bi-directional version and I could add it.
Here are the SLOW times for these sorts:
Bubble 82.69
Exchange 6.117
Shell 16.61
Insertion 5.898
Quick 3.929
Gnome 45.92
And here's the code for the updated sorts:
(Edited 25 April to include a sort by Dafhi)

Code: Select all



'SEVEN SORTS INCLUDING A SORT BY DAFHI
#include "fbgfx.bi"

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 gnomesort(a() as double)
                     declare Sub DafhiSort(Ary() As double)
                     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 draw_string(xpos As Integer,ypos As Integer,text As String,colour As Uinteger,size As Single,textangle As Single=0,charangle as single=0)
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,highlight_thickness as single,caption as string,captioncolour as uinteger=rgb(0,0,0),captionsize as single=1.2)
declare Sub draw_box(p() As box,col As Uinteger,pnt As String="paint",thickness as single=1,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,sc
dim shared as integer counter
dim as string Btime,Etime,Stime,Itime,Qtime,Gtime,Dtime
dim as single t1,t2
dim  shared as integer exchange,bubble,_shell,insertion,quick,gnome,dafhi,slider_val=600
dim shared as integer sleeptime,bars=27
'dim shared as integer scrollx,scrolly,wh,bt  'for mouse scroll
dim shared as uinteger bar_colour(0 to bars)
dim shared as double ref(0 to bars)
dim shared as uinteger refcolour(0 to bars)
dim shared as double sort(0 to bars)
dim as uinteger background=rgb(00,100,100)
draw_string(0,0,"",0,0) 'must initialize before setting screen by this line
Dim Shared As Integer xres,yres
Screen 19,32
Screeninfo xres,yres
'__ INITIALIZE ARRAYS_________
for x as integer=0 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 _________
dim as single size=1.5 'caption size
dim as uinteger col=rgb(250,250,255)'caption colour

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),4,"",rgb(0,0,0))'big box
drawbars(ref(),refcolour()) 'draw the array to be sorted

draw string(100,10),"SORTS:",rgb(255,255,255)
draw_string(10,115-70,Btime,rgb(255,255,255),1)
draw_string(10,215-70-20,Etime,rgb(255,255,255),1)
draw_string(10,315-70-40,Stime,rgb(255,255,255),1)
draw_string(10,415-70-60,Itime,rgb(255,255,255),1)
draw_string(10,515-70-80,Qtime,rgb(255,255,255),1)
draw_string(10,615-70-100,Gtime,rgb(255,255,255),1)
draw_string(10,715-70-120,Dtime,rgb(255,255,255),1)
draw string (290,20),"Press esc to exit any sort",rgb(200,200,200)

    drawbox(100,100-70,button(),120,50,rgb(100,100,0),rgb(255,255,255),rgb(00,0,200),4,"BUBBLE",col,size)
    drawbox(100,200-70-20,button(),120,50,rgb(100,100,0),rgb(255,255,255),rgb(00,0,200),4,"EXCHANGE",col,size)
    drawbox(100,300-70-40,button(),120,50,rgb(100,100,0),rgb(255,255,255),rgb(00,0,200),4,"SHELL",col,size)
    drawbox(100,400-70-60,button(),120,50,rgb(100,100,0),rgb(255,255,255),rgb(00,0,200),4,"INSERTION",col,size)
    drawbox(100,500-70-80,button(),120,50,rgb(100,100,0),rgb(255,255,255),rgb(00,0,200),4,"QUICK",col,size)
    drawbox(100,600-70-100,button(),120,50,rgb(100,100,0),rgb(255,255,255),rgb(00,0,200),4,"GNOME",col,size)
    drawbox(100,700-70-120,button(),120,50,rgb(100,100,0),rgb(255,255,255),rgb(00,0,200),4,"DAFHI",col,size)
    drawbox(250,560,label(),350,15,rgb(150,100,00),rgb(250,155,5),rgb(250,155,5),1,"",rgb(0,0,0))'slider box
   
    draw_string(250,540,"Min --------------- speed -------------- Max",rgb(200,200,200),1)
    drawbox(slider_val,560,label(),8,15,rgb(0,00,200),rgb(50,55,5),rgb(50,55,5),1,"",rgb(0,0,0))'slider
    circle(430,520),30,rgb(200,0,0),,,.5,f 'speed circle
    circle(430,520),30,rgb(0,0,0),,,.5
    draw_string(415,515,str(slider_val-250),rgb(250,250,250),1)
    if (screenevent(@e)) then 'quit by closing window
        sc.type=e.type
        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
if gnome then
        resetarray
        t1=timer
 gnomesort(sort()):t2=timer:delay(1e8)
 Gtime=left(str(t2-t1),5)
 gnome=0
end if
if dafhi then
    resetarray
        t1=timer
 dafhisort(sort()):t2=timer:delay(1e8)
 Dtime=left(str(t2-t1),5)
 dafhi=0
end if
    screenunlock
    Sleep 1,1
Loop Until Inkey=Chr(27)

Sub draw_string(xpos As Integer,ypos As Integer,text As String,colour As Uinteger,size As Single,textangle As Single=0,charangle as single=0)
    Type point2d
        As single x,y
        As Uinteger col
    End Type
    Dim As Integer codenum=128            '(Full Asci 256 if required)
    Static As Integer runflag
    Static As point2d infoarray()
    Redim Preserve As point2d infoarray(64,codenum) '64 = 8 x 8 pixel size
    If runflag=0 Then   '                  'scan codenum of codepage once
        Dim As Uinteger background=Rgb(0,0,0)
        Screenres 10,10,32  '8 x 8 pixels on this screen
        Dim count As Integer
        For ch As Integer=1 To codenum
            Cls
            Draw String(1,1),Chr(ch)
            For x As Integer=1 To 8  'scan for characters
                For y As Integer=1 To 8
                    If Point(x,y)<>background Then
                        count=count+1
                        infoarray(count,ch)=Type<point2d>(x,y)'save pixel position
                    End If
                Next y
            Next x
            count=0
        Next ch
        runflag=1
    End If
    If size=0 Then Exit Sub
    Dim As point2d temp(1 To 64,codenum),np
    dim as single cr= 0.01745329,x1,y1,x2,y2 '(4*atn(1))/180=.017453....
    #macro rotate(p1,p2,a,d)
    np.col=p2.col
    np.x=d*(Cos(a*cr)*(p2.x-p1.x)-Sin(a*cr)*(p2.y-p1.y)) +p1.x
    np.y=d*(Sin(a*cr)*(p2.x-p1.x)+Cos(a*cr)*(p2.y-p1.y)) +p1.y
    #endmacro
    #macro _box()
    Dim As Single dx=x2-x1,dy=y2-y1
    Swap dx,dy:dx=-dx
    Dim As Single p1x=x1+dx/2,p1y=y1+dy/2
    Dim As Single p2x=x1-dx/2,p2y=y1-dy/2
    Dim As Single p3x=x2+dx/2,p3y=y2+dy/2
    Dim As Single p4x=x2-dx/2,p4y=y2-dy/2
    Dim As Uinteger c=Rgb(255,255,254)
    For x As Integer=1 To 2
        Line(p1x,p1y)-(p2x,p2y),c
        Line(p3x,p3y)-(p4x,p4y),c
        Line(p1x,p1y)-(p3x,p3y),c
        Line(p2x,p2y)-(p4x,p4y),c
        Paint((p1x+p2x+p3x+p4x)/4,(p1y+p2y+p3y+p4y)/4),c,c
        c=cpt(z).col
    Next x
    #endmacro
    Dim As point2d cpt(1 To 64),c=type<point2d>(xpos,ypos),c2
    Dim As Single sz =size/2
    Dim As Integer dx=xpos,dy=ypos,asci
    For z6 As Integer=1 To Len(text)
        asci=Asc(Mid(text,z6,1))
        For x1 As Integer=1 To 64
            temp(x1,asci).x=infoarray(x1,asci).x+dx
            temp(x1,asci).y=infoarray(x1,asci).y+dy
            temp(x1,asci).col=colour
        Next x1
c2=type<point2d>(xpos+(size*(z6-1)*8)*Cos(textangle*cr),ypos+(size*(z6-1)*8)*Sin(textangle*cr))
        For z2 As Integer=1 To 64
            rotate(c,temp(z2,asci),textangle,size)
            cpt(z2)=np
            if charangle<>0 then
              rotate(c2,cpt(z2),charangle,1)
            cpt(z2)=np
            end if
        Next z2
        For z As Integer=1 To 64
x1=cpt(z).x-sz*(Cos((textangle+charangle)*cr)):y1=cpt(z).y-sz*(Sin((textangle+CHARANGLE)*cr))
x2=cpt(z).x+sz*(Cos((textangle+charangle)*cr)):y2=cpt(z).y+sz*(Sin((textangle+charangle)*cr))
           if infoarray(z,asci).x<>0 then 'paint only relevant points
            If Abs(size)>1 Then
                _box()
            Else
                Pset(cpt(z).x,cpt(z).y),cpt(z).col
            End If
            end if
        Next z
        dx=dx+8
    Next z6
End Sub

Sub draw_box(p() As box,col As Uinteger,pnt As String="paint",thickness as single=1,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,thickness,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,highlight_thickness as single,caption as string,captioncolour as uinteger,captionsize as single=1)
    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",highlight_thickness)
    #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
            dim as integer scrollx,scrolly,wh,bt
            getmouse scrollx,scrolly,wh,bt
            if sc.type=4 and counter=9 and bt=1 then 
            slider_val=scrollX
             sleeptime=(600-slider_val)/2
            end if
        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
        dim as integer xln=4*len((box(rect,1).caption))*captionsize
        draw_string((box(1,1).x+box(3,1).x)/2-xln,(box(1,1).y+box(3,1).y)/2-8,box(rect,1).caption,captioncolour,captionsize)
     'draw string((box(1,1).x+box(3,1).x)/2-xln,(box(1,1).y+box(3,1).y)/2-8),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:gnome=0:dafhi=0
   end if
   if counter=3 then
       bubble=0:exchange=1:_shell=0:insertion=0:quick=0:gnome=0:dafhi=0
   end if
   if counter=4 then
       bubble=0:exchange=0:_shell=1:insertion=0:quick=0:gnome=0:dafhi=0
   end if
   if counter=5 then
       insertion=1:bubble=0:exchange=0:_shell=0:quick=0:gnome=0:dafhi=0
   end if
   if counter=6 then
       quick=1:insertion=0:bubble=0:exchange=0:_shell=0:gnome=0:dafhi=0
   end if
   if counter=7 then
       gnome=1:quick=0:insertion=0:bubble=0:exchange=0:_shell=0:dafhi=0
   end if
   if counter=8 then
       dafhi=1:gnome=0:quick=0:insertion=0:bubble=0:exchange=0:_shell=0
       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 = 0 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=0 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= 0 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= 1 TO ubound(array)
      temp = array(row)
   temp2 = temp
   j = row
    while j>=1 andalso 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)
 swap bar_colour(i),bar_colour(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(j)
    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 gnomesort(a() as double)
    dim as integer _pos=1,last=0
    while _pos < ubound(a)+1
        if a(_pos)>=a(_pos-1) then
            if last<>0 then
                _pos=last
                last=0
            end if
            _pos=_pos+1
        else
            swap a(_pos),a(_pos-1)
             swap bar_colour(_pos),bar_colour(_pos-1)
            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())
            if _pos>1 then
                if last=0 then
                    last=_pos
                end if
                _pos=_pos-1
            else
                _pos=_pos+1
            end if
        end if
    wend
    screenunlock
end sub
Sub DafhiSort(Ary() As double)
    'BY DAFHI
    dim as integer start_=lbound(ary),End_=ubound(ary)
Dim  as Integer Position_of_Hi, Position_of_Lo, S_:dim  As Long J
    Do While Start_ < End_
        Position_of_Hi = Start_
        Position_of_Lo = Start_
        S_ = Start_ + 1
        For J = S_ To End_
            If Ary(J) > Ary(Position_of_Hi) Then
                Position_of_Hi = J
            ElseIf Ary(J) < Ary(Position_of_Lo) Then
                Position_of_Lo = J
            End If
        Next
        'prevent swap conflicts
        If Position_of_Hi = Start_ Then
            If Position_of_Lo <> End_ Then
                'order important!
                Swap  Ary(Position_of_Hi), Ary(End_)
            swap bar_colour(Position_of_Hi),bar_colour(End_)
                Swap  Ary(Start_), Ary(Position_of_Lo)
             swap bar_colour(Start_),bar_colour(Position_of_Lo)   
            Else
                Swap  Ary(Start_), Ary(End_)
            swap bar_colour(Start_),bar_colour(End_)   
            End If
        Else
            'order important!
            Swap  Ary(Start_), Ary(Position_of_Lo)
           swap bar_colour(Start_),bar_colour(Position_of_Lo) 
            Swap  Ary(Position_of_Hi), Ary(End_)
            swap bar_colour(Position_of_Hi),bar_colour(End_)
        End If
        Start_ = S_
        End_ = End_ - 1
         screenunlock
        sleep sleeptime
        screenlock
        if inkey=chr(27) then exit sub
        paint(309,59),rgb(0,0,0),rgb(120,20,20)
        drawbars(ary(),bar_colour())
    Loop
    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=0 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=0 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
   

   
Last edited by dodicat on Apr 24, 2011 23:33, edited 1 time in total.
dafhi
Posts: 1251
Joined: Jun 04, 2005 9:51

Postby dafhi » Apr 24, 2011 2:18

Here's my bi-di selection sort

Code: Select all

Dim as Integer Position_of_Hi, Position_of_Lo, S_, J

' Pass lowerbound and upperbound as Start_ and End_
Sub BiDiSelectSort(Ary() As Single, Start_ As Integer, End_ As Integer)

    Do While Start_ < End_
       
        Position_of_Hi = Start_
        Position_of_Lo = Start_
       
        S_ = Start_ + 1
       
        For J = S_ To End_
            If Ary(J) > Ary(Position_of_Hi) Then
                Position_of_Hi = J
            ElseIf Ary(J) < Ary(Position_of_Lo) Then
                Position_of_Lo = J
            End If
        Next
       
        'prevent swap conflicts
        If Position_of_Hi = Start_ Then
            If Position_of_Lo <> End_ Then
                'order important!
                Swap Swapvar, Ary(Position_of_Hi), Ary(End_)
                Swap Swapvar, Ary(Start_), Ary(Position_of_Lo)
            Else
                Swap Swapvar, Ary(Start_), Ary(End_)
            End If
        Else
            'order important!
            Swap Swapvar, Ary(Start_), Ary(Position_of_Lo)
            Swap Swapvar, Ary(Position_of_Hi), Ary(End_)
        End If
       
        Start_ = S_
        End_ = End_ - 1
       
    Loop
   
End Sub
dodicat
Posts: 5951
Joined: Jan 10, 2006 20:30
Location: Scotland

Postby dodicat » Apr 24, 2011 23:44

Hi dafhi
I've got your sort working, I had to adjust a bit, you were swapping three things at the same time, a nice idea, a bit like the old three card trick, but the compiler doesn't know this trick.
Also, I've stuck all the variables inside, and made start and end bo 0 to ubound ary.
It is very fast really, and I've put it in the comparisons as promised.
(The last version has been edited)
Also, you can now slide the speed adjuster, which, after much farting around, I managed.
dafhi
Posts: 1251
Joined: Jun 04, 2005 9:51

Postby dafhi » Apr 24, 2011 23:57

UPDATE: lol. I see my edit hadn't occurred in time. The J as Long can simply be integer. I had overlooked it converting from VB.
Last edited by dafhi on Apr 25, 2011 0:07, edited 1 time in total.
badmrbox
Posts: 659
Joined: Oct 27, 2005 14:40
Location: Sweden
Contact:

Postby badmrbox » Apr 25, 2011 0:05

bubble 1.171
exchange 0.085
shell 0.171
insertion 0.078
quick 0.062
gnome 0.695
dafhi 0.046

the dafhi sort seems to be quite fast.
dafhi
Posts: 1251
Joined: Jun 04, 2005 9:51

Postby dafhi » Apr 25, 2011 0:26

It's just a selection sort. QSort shines with bigger lists. What I'm thinking would be cool is a "Linked List" sort which could sort chunks of say, 256 elements.

Keep in mind that selection sort will do well here because it intentionally keeps swaps to a minimum.
dodicat
Posts: 5951
Joined: Jan 10, 2006 20:30
Location: Scotland

Postby dodicat » Apr 25, 2011 1:42

dafhi wrote:It's just a selection sort. QSort shines with bigger lists. What I'm thinking would be cool is a "Linked List" sort which could sort chunks of say, 256 elements.

Keep in mind that selection sort will do well here because it intentionally keeps swaps to a minimum.

Here's a sort without a sort algo.
As soon as a number is manufactured it is slotted into an array in an organised fashion.

Code: Select all



Sub arrayinsertdouble( a() As Double,index As Integer,insert As Double )
    If index>=Lbound(a) And index<=Ubound(a)+1 Then
        index=index-Lbound(a)
        Redim Preserve a(Lbound(a) To  Ubound(a)+1)
        Dim x As Integer
        For x= Ubound(a) To Lbound(a)+index+1 Step -1
            Swap a(x),a(x-1)
        Next x
        a(Lbound(a)+index)=insert
    End If
End Sub

Redim As Double ar(0) 'the array to hold sorted numbers
Dim As Double x
ar(0)=0  'give a(0) the lowest value you want to sort to or expect
For z As Integer=0 To 256
    '__________________________________
    x=Rnd*10     'manufacture a number
    if z=1 then x=9.99999999 'check that the highest is caught
    if z=20 then x=5 'stick in a few of the same value
    if z=50 then x=5
    if z=112 then x=5
    if z=256 then x=.000000001 'check that the lowest is caught
    '_______________________________________
    For z2 As Integer=0 To Ubound(ar)
        If x>ar(z2) Then
            arrayinsertdouble(ar(),z2,x) 'pop in the number and move on
            Exit For
        End If
    Next z2
Next z
'print out all elements
print "START"
For z As Integer=0 To  Ubound(ar)
    Print ar(z)
Next z
Print "END",ubound(ar);" elements"
Sleep

dafhi
Posts: 1251
Joined: Jun 04, 2005 9:51

Postby dafhi » Apr 25, 2011 3:17

That's interesting. I see one optimization:

For x= Ubound(a) To Lbound(a)+index+1 Step -1
a(x)=a(x-1)
Next x
a(x)=insert
MichaelW
Posts: 3500
Joined: May 16, 2006 22:34
Location: USA

Postby MichaelW » Apr 25, 2011 4:16

A better optimization would be to make the array large enough to hold all of the values, append each new value to the end, and then do an insertion sort of the filled part of the array. This would eliminate the slow redim, and with only one element out of place the insertion sort would be fast.
frisian
Posts: 249
Joined: Oct 08, 2009 17:25

Postby frisian » Apr 30, 2011 14:53

@Dodicat

Like your program specially the way you visualize the sort process.

But I have some remarks about a few things.

This is a matter of taste
In some places Swap bar_colour(i),bar_colour(j)
is follow by drawbars(a(),bar_colour()) like in Bubblesort
in the Sub MD this not the case.
When there is a Swap bar_colour(i),bar_colour(j) it should
always be follow by drawbars(a(),bar_colour()) (and a delay
otherwise the screen would start to flash).

This is also a matter of taste.
Timing as sort routine and also visualize the sort process don't go
together. So times should be considered as a indication.
(Timing small array's can give very different results as when timing
large array's ).


In Bubble sort you have If (array(p1)) >= (array(p2)) Then
if the value in array(p1) = array(p2) then there is no need for a swap
so If (array(p1)) > (array(p2)) Then is enough.

In the sub MD there the line If j>LBound(a) Then but
one aspect of quicksort is splitting the array in a smaller one and
calling itself to sort the subsection so it should be If j>g then
the array size stays the same so test for lower boundary of the
subsection and not the lower boundary of the array

The subroutine MD has a problem with a reversed array and a already sorted
array but curiously enough not with a array where every element is the same, it
becomes very slow, and in all three cases it need a lot of memory. Weird thing
is I have tested two other quicksort routine's that are fast in all cases and
work with the default stack size.
Information on the internet suggest the quicksort has problems with
array that are sorted (normal or reversed). They suggest to mix it up
and then send it to quicksort.
Strange knowing that I have two different routines that don't have problems.

Here are my timing for a array size of 50000 for the MD routine and two other
quicksort routines

Code: Select all

                     Array size = 50000

               reversed    random     sorted      equal
  MDquicksort  4.137 sec   0.011 sec  3.535 sec  0.008 sec
       YQSort  0.005 sec   0.012 sec  0.005 sec  0.008 sec
   QuickSort2  0.004 sec   0.010 sec  0.004 sec  0.007 sec


link to webpage to randomize a sorted or nearly sorted array
http://en.literateprograms.org/Quicksort_%28Visual_Basic_.NET%29

source for YQSort and Quicksort2, the program is a timing/visual sort program outdated and some of the quicksort routine's call a other quicksort routine instead of themself.
http://www.freebasic-portal.de/porticula/sort-testbas-schnellste-routinen-513.html

YQsort will sort up or down and every FB Type
http://ytwinky.freebasic-portal.de/freebasic/qsort.bas
Use this sort for my program's, simple but does the job
kiyotewolf
Posts: 1009
Joined: Oct 11, 2008 7:42
Location: ABQ, NM
Contact:

Postby kiyotewolf » May 27, 2011 4:16

I wanna port this to a TRS-80 COCO 2 to watch endlessly for fun.



:M

Return to “Tips and Tricks”

Who is online

Users browsing this forum: MSN [Bot] and 37 guests