Heapsort, up/down, integer, with Tagged array

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
ppf
Posts: 79
Joined: Oct 10, 2017 6:41

Heapsort, up/down, integer, with Tagged array

Postby ppf » Dec 30, 2019 22:24

Founded on rosetta webpage this nice code of 'heapSort' algo:

Code: Select all

Sub siftdown(hs() As Long, start As ULong, end_ As ULong)
    Dim As ULong root = start
    Dim As Long lb = LBound(hs)
 
    While root * 2 + 1 <= end_
        Dim As ULong child = root * 2 + 1
        If (child + 1 <= end_) AndAlso (hs(lb + child) < hs(lb + child + 1)) Then
            child = child + 1
        End If
        If hs(lb + root) < hs(lb + child) Then
            Swap hs(lb + root), hs(lb + child)
            root = child
        Else
            Return
        End If
    Wend
End Sub
 
Sub heapsort(hs() As Long)
    Dim As Long lb = LBound(hs)
    Dim As ULong count = UBound(hs) - lb + 1
    Dim As Long start = (count - 2) \ 2
    Dim As ULong end_ = count - 1
 
    While start >= 0
        siftdown(hs(), start, end_)
        start = start - 1
    Wend
 
    While end_ > 0
        Swap hs(lb + end_), hs(lb)
        end_ = end_ - 1
        siftdown(hs(), 0, end_)
    Wend
End Sub


To be usable, I added
- test for elements<2 (no sense for sorting)
- Up/Down direction
- Tagged array (just for my old PowerBasic styled app code compatibility - sort one array by another)
- array hs() - 'long' changed to 'integer' for my needs

Changes are easy to find and adaptable for your own intent.
In my old app with new Multisort feature I slowly replace old CombSort routines with HeapSort.
In previous days no problem, it works Ok.


Happy New Year 2020


Code: Select all

Sub siftdownIntegr(hs() As integer, start As ULong, end_ As ULong,TaggedA() As Integer,direction As string)
    Dim As ULong root = start
    Dim As Long lb = LBound(hs)
 
    While root * 2 + 1 <= end_
        Dim As ULong child = root * 2 + 1
        If (child + 1 <= end_) AndAlso (hs(lb + child) < hs(lb + child + 1)) Then
            child = child + 1
        End If
        If hs(lb + root) < hs(lb + child) Then
            Swap hs(lb + root), hs(lb + child)
            Swap TaggedA(lb + root), TaggedA(lb + child)   'tagged - new
            root = child
        Else
            Return
        End If
    Wend
End Sub

Sub siftUpIntegr(hs() As integer, start As ULong, end_ As ULong,TaggedA() As Integer,direction As string)
    Dim As ULong root = start
    Dim As Long lb = LBound(hs)
 
    While root * 2 + 1 <= end_
        Dim As ULong child = root * 2 + 1
        If (child + 1 <= end_) AndAlso (hs(lb + child) > hs(lb + child + 1)) Then       
            child = child + 1
        End If

        If hs(lb + root) > hs(lb + child) Then       
            Swap hs(lb + root), hs(lb + child)
            Swap TaggedA(lb + root), TaggedA(lb + child)   'tagged - new
            root = child
        Else
            Return
        End If
    Wend
End Sub

Sub heapsortInt(hs() As integer,TaggedA() As Integer,direction As string)
    Dim As Long lb = LBound(hs)
    Dim As ULong count = UBound(hs) - lb + 1
    Dim As Long start = (count - 2) \ 2
    Dim As ULong end_ = count - 1
 'no sense of sorting for elements<2 (log this incident)
 if count<2 then ? " heapsortInt .. <2 elements .. ended (press key)":sleep: exit sub   'just change this as file write log
   
 Select Case direction   'ascend - descend
  Case "ascend"   
    While start >= 0
        siftdownIntegr(hs(), start, end_, TaggedA(), direction)
        start = start - 1
    Wend
 
    While end_ > 0
        Swap hs(lb + end_), hs(lb)
        Swap TaggedA(lb + end_), TaggedA(lb)   'tagged - new
        end_ = end_ - 1
        siftdownIntegr(hs(), 0, end_, TaggedA(), direction)
    Wend
   
  Case "descend"   
    While start >= 0
        siftUpIntegr(hs(), start, end_, TaggedA(), direction)       
        start = start - 1
    Wend
 
    While end_ > 0
        Swap hs(lb + end_), hs(lb)
        Swap TaggedA(lb + end_), TaggedA(lb)   'tagged - new
        end_ = end_ - 1
        siftUpIntegr(hs(), 0, end_, TaggedA(), direction)       
    Wend   
  Case Else
      ? "heapSortInt ascend - descend bad parameter ..  (press key)":sleep
 End Select   
End Sub


Usage - e.g.

Code: Select all

dim a(1234567) as integer
dim b(1234567) as integer   
'...fill arrays with values
heapsortInt(a(),b(),"descend")         'sort a() array in "down" direction AND ALSO sort tagged b() array by a() array
dodicat
Posts: 6237
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Heapsort, up/down, integer, with Tagged array

Postby dodicat » Dec 31, 2019 2:18

Happy New Year ppf.
Compare heapsort with ordinary quicksort, and for fun, the chucklesort.

Code: Select all

Sub siftdownIntegr(hs() As integer, start As ULong, end_ As ULong,TaggedA() As Integer,direction As string)
    Dim As ULong root = start
    Dim As Long lb = LBound(hs)
 
    While root * 2 + 1 <= end_
        Dim As ULong child = root * 2 + 1
        If (child + 1 <= end_) AndAlso (hs(lb + child) < hs(lb + child + 1)) Then
            child = child + 1
        End If
        If hs(lb + root) < hs(lb + child) Then
            Swap hs(lb + root), hs(lb + child)
            Swap TaggedA(lb + root), TaggedA(lb + child)   'tagged - new
            root = child
        Else
            Return
        End If
    Wend
End Sub

Sub siftUpIntegr(hs() As integer, start As ULong, end_ As ULong,TaggedA() As Integer,direction As string)
    Dim As ULong root = start
    Dim As Long lb = LBound(hs)
 
    While root * 2 + 1 <= end_
        Dim As ULong child = root * 2 + 1
        If (child + 1 <= end_) AndAlso (hs(lb + child) > hs(lb + child + 1)) Then       
            child = child + 1
        End If

        If hs(lb + root) > hs(lb + child) Then       
            Swap hs(lb + root), hs(lb + child)
            Swap TaggedA(lb + root), TaggedA(lb + child)   'tagged - new
            root = child
        Else
            Return
        End If
    Wend
End Sub

Sub heapsortInt(hs() As integer,TaggedA() As Integer,direction As string)
    Dim As Long lb = LBound(hs)
    Dim As ULong count = UBound(hs) - lb + 1
    Dim As Long start = (count - 2) \ 2
    Dim As ULong end_ = count - 1
 'no sense of sorting for elements<2 (log this incident)
 if count<2 then ? " heapsortInt .. <2 elements .. ended (press key)":sleep: exit sub   'just change this as file write log
   
 Select Case direction   'ascend - descend
  Case "ascend"   
    While start >= 0
        siftdownIntegr(hs(), start, end_, TaggedA(), direction)
        start = start - 1
    Wend
 
    While end_ > 0
        Swap hs(lb + end_), hs(lb)
        Swap TaggedA(lb + end_), TaggedA(lb)   'tagged - new
        end_ = end_ - 1
        siftdownIntegr(hs(), 0, end_, TaggedA(), direction)
    Wend
   
  Case "descend"   
    While start >= 0
        siftUpIntegr(hs(), start, end_, TaggedA(), direction)       
        start = start - 1
    Wend
 
    While end_ > 0
        Swap hs(lb + end_), hs(lb)
        Swap TaggedA(lb + end_), TaggedA(lb)   'tagged - new
        end_ = end_ - 1
        siftUpIntegr(hs(), 0, end_, TaggedA(), direction)       
    Wend   
  Case Else
      ? "heapSortInt ascend - descend bad parameter ..  (press key)":sleep
 End Select   
End Sub

'===========================

#macro SetQsort(datatype,fname,dot)
    Sub fname(array() As datatype,begin As Long,Finish As Long)
    Dim As Long i=begin,j=finish
    Dim As datatype x =array(((I+J)\2))
    While  I <= J
    if direction=down then
        While array(I)dot > X dot:I+=1:Wend
        While array(J)dot < X dot:J-=1:Wend
    else
        While array(I)dot < X dot:I+=1:Wend
        While array(J)dot > X dot:J-=1:Wend
    end if
    If I<=J Then Swap array(I)dot,array(J)dot: I+=1:J-=1 
    wend
    If J > begin Then fname(array(),begin,J)
    If I < Finish Then fname(array(),I,Finish)
End Sub
#endmacro

Enum
    up
    down
End Enum
Dim Shared As Byte direction=up

'...fill arrays with values
#macro fill(a)
randomize 1
for n as long=lbound(a) to ubound(a)
    a(n)=rnd*1000000
next
#endmacro


#macro show(a)
for n as long=lbound(a) to 50
    print a(n);" ";
next
print:print
for n as long=ubound(a)-50 to ubound(a)
    print a(n);" ";
next
print

#endmacro


type chuck
    as long n(any)
    as long repeat(any)
end type

sub chucklesort(f() as integer,lb as long,ub as long)
    dim as long count=lb
    dim as longint max= -2147483647,min=2147483647 'arbitrary limits
    for n as long=lb to ub
        if max<f(n) then max=f(n)
        if min>f(n) then min=f(n)
    next
    dim as chuck d
    redim d.n(min to max),d.repeat(min to max)
   for n as long=lb to ub
        d.n(f(n))=f(n):d.repeat(f(n))+=1
    next
    for n as long=lbound(d.n) to ubound(d.n)
   for z as long=1 to d.repeat(n)
     f(count)=d.n(n):count+=1
     next z
    next
    if direction=down then 'reverse
For n As long=Lbound(f) To Int((Lbound(f)+Ubound(f))/2):Swap f(n),f(Ubound(f)+Lbound(f)-n):Next
    end if

end sub


redim a(1234567) as integer
redim b(1234567) as integer
fill(a)



dim as double t1=timer,t2
heapsortInt(a(),b(),"descend")
t2=timer
show(a)

print t2-t1;" seconds  Heapsort"
print

'create a quicksort sub
SetQsort(integer,Qsortinteger,)
direction=down

fill(a)
t1=timer
Qsortinteger(a(),lbound(a),ubound(a))
t2=timer

show(a)


print t2-t1;" seconds  quicksort"
print

fill(a)
t1=timer
chucklesort(a(),lbound(a),ubound(a))
t2=timer

show(a)


print t2-t1;" seconds  chucklesort"
sleep



 
ppf
Posts: 79
Joined: Oct 10, 2017 6:41

Re: Heapsort, up/down, integer, with Tagged array

Postby ppf » Dec 31, 2019 2:50

Happy New Year dodicat.

Great, benchmarks are main task for me in near future.
Glad for your valuable codes all the time and help !!
dafhi
Posts: 1329
Joined: Jun 04, 2005 9:51

Re: Heapsort, up/down, integer, with Tagged array

Postby dafhi » Jan 23, 2020 0:55

dodicat

your qs

Code: Select all

Swap array(I)dot,array(J)dot

should be

Code: Select all

Swap array(I),array(J)
dodicat
Posts: 6237
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: Heapsort, up/down, integer, with Tagged array

Postby dodicat » Jan 23, 2020 12:49

hi dafhi.
Originally ppf wanted to sort data a few columns at a time from a datasheet.
This would equate to sorting udt's by chosen fields, thus the dot.
I agree, normally you might want to swap the whole udt, for example 3D positions by the .z field.
I can easily add another choice in the macro.

Code: Select all

#macro SetQsort(datatype,fname,dot)
    Sub fname(array() As datatype,begin As Long,Finish As Long)
    Dim As Long i=begin,j=finish
    Dim As datatype x =array(((I+J)\2))
    While  I <= J
    if direction=down then
        While array(I)dot > X dot:I+=1:Wend
        While array(J)dot < X dot:J-=1:Wend
    else
        While array(I)dot < X dot:I+=1:Wend
        While array(J)dot > X dot:J-=1:Wend
    end if
    if mode=onefield then
    If I<=J Then Swap array(I)dot,array(J)dot: I+=1:J-=1
    else
     If I<=J Then Swap array(I),array(J): I+=1:J-=1
    end if
    wend
    If J > begin Then fname(array(),begin,J)
    If I < Finish Then fname(array(),I,Finish)
End Sub
#endmacro

Enum
    up
    down
    all
    onefield
End Enum
Dim Shared As Byte direction=up,mode=all

type udt
    as long i
    as string s
end type

Function range(f As Long,l As Long) As Long
    Return  Int(Rnd*((l+1)-(f)))+f
End Function

Sub printout(x() As udt,msg as string="",numelements as long=5)
    print msg
    Print "field 1";Tab(20);"field  2"'
    print
    For n As Long=Lbound(x) To numelements
        Print x(n).i;Tab(20);x(n).s
    Next n
    Print
    Print ". . ."
    Print
    For n As Long=Ubound(x)-numelements To Ubound(x)
        Print x(n).i;Tab(20);x(n).s
    Next n
    print
End Sub

#define q range(97,122)

redim as udt u(1 to 1000000)
for n as long=1 to 1000000
    u(n).i=rnd*1000000
    u(n).s=chr(q,q,q,q,q)
next
printout(u(),"raw original")

SetQSort(udt,stringsort,.s)
SetQSort(udt,longsort,.i)

mode=onefield:direction=up
stringsort(u(),lbound(u),ubound(u))
printout(u(),"string field only sorted up")
mode=all:direction=down
longsort(u(),lbound(u),ubound(u))
printout(u(),"All fields sorted by field 1 down")
print "done"
sleep

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

Re: Heapsort, up/down, integer, with Tagged array

Postby dafhi » Jan 24, 2020 4:21

hmm.

running a speed comp on your qs, i'm seeing about 1.5% gain

Code: Select all

    var i=l: j=r '' shared var j
    While  I <= J
      While a(I)dot direction a(l) dot:I+=1:Wend
      While a(l) dot direction a(J)dot:J-=1:Wend
      If I<J Then Swap a(I),a(J)
      I -= i<=j
      J += i<=j
    wend
[update] your original is 1% faster w/ few unique

heres mine

Code: Select all

#define direction <
' ---------------

#undef int

#define int         as Integer
#define sng         as single
#define dbl         as double
 
'' normally pushed to stack (which can be mildly faster)
Dim shared int j, i
 
#macro ifswap(x,y)
  if a(y)dot direction a(x)dot then
    swap a(x),a(y)
  endif
#EndMacro
 
 
#macro SetQsort3(datatype,fname,dot)
    Sub fname(a() as datatype, L int, r int) '' Munair quicksort modified
      ifswap(L,r) '' L becomes pivot
      if L < r - 1 then
        var j = r:  i = L
        whiLe i < j
          j -= 1: whiLe a(L)dot direction a(j)dot: j-=1: wend
          i += 1: while a(i)dot direction a(L)dot: i+=1: wend
          if j<=i then i=j: exit while
          swap a(i),a(j)
        Wend
        ifswap(L,j)
        i -= 1:  if L < i then fname a(), L, i
        j += 1:  if j < r then fname a(), j, r
      endif
    End Sub
#endmacro

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 3 guests