Heapsort, up/down, integer, with Tagged array

[ppf]

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]

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]

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]

dodicat

your qs

Code: Select all

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

should be

Code: Select all

Swap array(I),array(J)

[dodicat]

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]

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