benchmark sorts

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
dafhi
Posts: 1303
Joined: Jun 04, 2005 9:51

benchmark sorts

Postby dafhi » Dec 03, 2017 10:06

Code: Select all

'' benchmark sorts - 2020 Jan 22 - by dafhi

'' 2 very fast quicksorts compared


Type vector3d
  As double         x,y,z
  as uinteger       color
End Type

' -------------------------------------
Type my_SORT_TYPE   as vector3d
' -------------------------------------


'' comment out the .z for plain var type
#define dot   .z

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

  #define sort_type     as my_sort_type

namespace sorts '' using namespace with intent to create "private" global vars

  dim sort_type       sw                'swap var
  type my_dot_type    as typeof(sw dot)
  #define dot_type    as my_dot_type
 
  #undef int
 
  #define int         as Integer
 
 
  '' normally pushed to stack (which can be faster)
  Dim int j, i
 
 
  #macro ifswap(x,y)
    if a(y)dot direction a(x)dot then
      swap a(x),a(y)
    endif
  #EndMacro
 

  '' excellent with quicksort
  sub bidi_sel_sort( a() SORT_TYPE, l int, r int )
    while l<r
      dim int lo=l
      j=l
      for i int = l+1 to r
        if a(i)dot direction a(lo)dot then: lo=i
        elseif a(j)dot direction a(i)dot then: j=i
        endif
      Next
      ifswap(l, lo):  if j=l then j=lo
      ifswap(j, r):  l+=1: r-=1
    wend
  End Sub

 
  #macro SetQSort2(datatype,fname,dot)
    Sub fname(a() as datatype, L int, r int) '' Munair quicksort modified
      if (r-L) < 13 then bidi_sel_sort a(), L, r:  exit sub
      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
          ifswap(i,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
   
  setqsort2( my_sort_type, QS2, dot )
 

  #macro SetQsort(datatype,fname,dot)
      Sub fname(a() As datatype,L as integer,r as integer) '' dodicat quicksort modified
      if (r-L) < 18 then bidi_sel_sort a(), L, r:  exit sub
      ifswap( L, (L+r)\2 ) '' L becomes pivot
      Dim as integer i = L:  j = r
      While I < J  '' modified 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+=1: J-=1
      wend
      If J > L Then fname(a(),L,J)
      If I < r Then fname(a(),I,r)
  End Sub
  #endmacro
 
  setqsort( my_sort_type, dodi_q, dot )
 

end namespace



' ------- timing

Const                 SortElements = 9 * 599

dim shared as long    ub_times = 15


sub RandomData(a() SORT_TYPE)
  for i int = 0 to ubound(a)
    a(i)dot = rnd
  Next
End Sub


function Sorted(a() SORT_TYPE) as boolean
  var b = a(0)dot, correct = true
  for p as my_SORT_TYPE ptr = @a(1) to @a(ubound(a))
    if p->z direction b then correct=FALSE: exit for
    b = p->z
  Next
  if not correct then
   for p as my_SORT_TYPE ptr = @a(0) to @a(ubound(a))
     ? p->z; " ";
   Next: ?
  end if: return correct
end function


type tTimings
  as long           ub = -1
  as double         a(any)
  as string         mesg
  declare operator  cast as string
  declare operator  cast as double
  declare operator  cast as single
End Type
operator tTimings.cast as string:  return str(a(ub/2))
End Operator
operator tTimings.cast as double:  return a(ub/2)
End Operator
operator tTimings.cast as single:  return a(ub/2)
End Operator


sub Sort_Times(A() As double,UB int=-1,LB int=0)
  if lb>ub then lb=lbound(a): ub=ubound(a)
  var lo=lb: for i int=lb+1 to ub: if a(i) < a(lo) then lo=i
  next: swap a(lb), a(lo)
  For i int=lb+1 To ub-1
    dim int j=i+1: if a(j) < a(i) then
      dim as double sw=a(j): j=i: while sw < a(j)
        a(j+1)=a(j): j-=1: wend: a(j+1)=sw: endif: Next
End Sub


dim shared as double  times(ub_times)


#Macro mac_timer(algo,ret, algorithm_name)
  ret.mesg = algorithm_name & " "
  for i int = 0 to ub_times
    RandomData a()
    dim as double t = timer
      algo
    times(i) = timer - t
    If not Sorted( a() ) then ? "sort error! "; ret.mesg
  Next: Sort_Times times()
  ret.ub+=1
  redim preserve ret.a(ret.ub)
  ret.a(ret.ub) = times(ub_times/2)
  Sort_Times ret.a()
#EndMacro

' ---------------


#Define flr(x) (((x)*2.0-0.5)shr 1) '' Stonemonkey's floor()

function round(in as single, places as ubyte = 2) as string
  dim int mul = 10 ^ places
  return str(csng(flr(in * mul + .5) / mul))
End Function



sub Main
 
  dim int    ub = SortElements - 1
  dim SORT_TYPE a(ub)
  dim as tTimings   tA, tB

  sleep 250
  randomize
 
 
  #define sort_a mac_timer( dodi_q( a(), 0, ubound(a) ), tA, "dodicat qsort" )
 
  #define sort_b mac_timer( qs2( a(), 0, ubound(a) ), tB, "qs2" )
 
  using sorts ''namespace
 
  ? " sorting .."

  for i as long = 1 to 31
    sleep 15
    if rnd<.5 then 'algorithm sequence can make a difference
      sort_a
      sort_b
    else
      sort_b
      sort_a
    endif
  next
  cls
 
  var s = 0f, mesg = " "
  if tA<tB then
    s = tA / tB: mesg = tA.mesg
  else
    s = tB / tA: mesg = tB.mesg
  EndIf
  ?
  ? " winner:  "; mesg
  ?
  ? s; " .. "; round(1 / s, 3); "x"

  sleep
end sub

Main
Last edited by dafhi on Jan 23, 2020 4:59, edited 14 times in total.
paul doe
Posts: 1028
Joined: Jul 25, 2017 17:22
Location: Argentina

Re: benchmark sorts

Postby paul doe » Dec 03, 2017 11:05

Nice! Very useful, thanks.
You have two warnings in the code:

Code: Select all

FbTemp.bas(219) warning 3(1): Passing different pointer types, at parameter 1 (algo) of PARTITION()
FbTemp.bas(221) warning 3(1): Passing different pointer types, at parameter 1 (algo) of PARTITION()


The last parameter of both signatures should be the same, either both long, or both integer, for FB to stop complaining ;)

Code: Select all

'' this is the comb_sort signature
Sub comb_sort(A() As mysorttype, lb As integer=0, ub As integer=0, k as long=1)

'' and this is the ytQS2 signature
sub ytQS2(a() as mysorttype, lb as integer=0, ub as integer=0, q as integer=1)
srvaldez
Posts: 2177
Joined: Sep 25, 2005 21:54

Re: benchmark sorts

Postby srvaldez » Dec 03, 2017 15:12

on my Mac with optimize level -Ofast

Code: Select all

 winner:  ytQS2 

 0.5809945 .. 1.72x
jj2007
Posts: 1287
Joined: Oct 23, 2016 15:28
Location: Roma, Italia
Contact:

Re: benchmark sorts

Postby jj2007 » Dec 03, 2017 16:20

dafhi wrote:update 2 - adjusted timing window


Code: Select all

  var s = 0f, mesg = ""
  if tA<tB then
    s = tA / tB: mesg = tA.mesg
  else
    s = tB / tA: mesg = tB.mesg
  EndIf

I get some errors here for s=...:

Code: Select all

\TmpFile.bas(230) error 24: Invalid data types
J:\AllBasics\FreeBasic\tmp\TmpFile.bas(232) error 180: Invalid assignment/conversion
J:\AllBasics\FreeBasic\tmp\TmpFile.bas(234) error 180: Invalid assignment/conversion
srvaldez
Posts: 2177
Joined: Sep 25, 2005 21:54

Re: benchmark sorts

Postby srvaldez » Dec 03, 2017 16:34

no problems here, tested with FB versions 1.04, 1.05 and 1.06 both 32 and 64 bit, what version are you using?
MrSwiss
Posts: 3329
Joined: Jun 02, 2013 9:27
Location: Switzerland

Re: benchmark sorts

Postby MrSwiss » Dec 03, 2017 16:41

Code: Select all

function Sorted(a() as MySortType) as uinteger
  var b = a(0)dot
  for p as MySortType ptr = @a(1) to @a(ubound(a))
    if b b2 p->z then return FALSE
    b = p->z
  Next: return TRUE
end function
Seeing the return type: uinteger (which size? FBC 32 = ULong, FBC 64 = ULongInt) and,
return TRUE -- ???
IMHO, a return TRUE is only correct, with a Boolean type (return parameter)!

While a signed int. (any size) might be acceptable, any unsigned int. should at least,
trow a: WARNING: "incompatible variable assignment" ... (trying to assign: -1).
dafhi
Posts: 1303
Joined: Jun 04, 2005 9:51

Re: benchmark sorts

Postby dafhi » Dec 03, 2017 18:28

jj2007 - hopefully MrSwiss caught the error (which I fixed)

srvaldez - I use O 3
jj2007
Posts: 1287
Joined: Oct 23, 2016 15:28
Location: Roma, Italia
Contact:

Re: benchmark sorts

Postby jj2007 » Dec 03, 2017 21:45

srvaldez wrote:no problems here, tested with FB versions 1.04, 1.05 and 1.06 both 32 and 64 bit, what version are you using?


FreeBASIC Compiler - Version 1.05.0 (01-31-2016), built for win32 (32bit)
Copyright (C) 2004-2016 The FreeBASIC development team.
standalone

Code: Select all

  var s = 0f, mesg = ""
  if tA<tB then
    s = tA / tB: mesg = tA.mesg
  else
    s = tB / tA: mesg = tB.mesg
  EndIf

Code: Select all

TmpFile.bas(232) error 24: Invalid data types
TmpFile.bas(234) error 180: Invalid assignment/conversion
TmpFile.bas(236) error 180: Invalid assignment/conversion

The culprit is mesg; it works with

Code: Select all

  dim mesg as string=""
  var s = 0f

Code: Select all

 winner:  ytQS2
 0.7036515 .. 1.42x
dafhi
Posts: 1303
Joined: Jun 04, 2005 9:51

Re: benchmark sorts

Postby dafhi » Nov 21, 2018 14:46

updated with Munair's quicksort
dodicat
Posts: 6084
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: benchmark sorts

Postby dodicat » Nov 21, 2018 16:50

Here is how I generalise the standard quicksort.

Code: Select all


'=========================================
#define up <,>
#define down >,<
#macro SetQsort(datatype,fname,b1,b2,dot)
Sub fname(array() As datatype,begin As Long,Finish As Ulong)
    Dim As Long i=begin,j=finish
    Dim As datatype x =array(((I+J)\2))
    While  I <= J
        While array(I)dot b1 X dot:I+=1:Wend
            While array(J)dot b2 X dot:J-=1:Wend
                If I<=J Then Swap array(I),array(J): I+=1:J-=1
            Wend
            If J > begin Then fname(array(),begin,J)
            If I < Finish Then fname(array(),I,Finish)
        End Sub
        #endmacro
 '===========================================       
        #macro printout(a)
        For n As Long=Lbound(a) To Ubound(a)
            #if typeof(a)<>udt
            Print n, a(n)
            #else
            Print n,a(n).x,a(n).y,a(n).z,a(n).s
            #endif
        Next
        Print
        #endmacro
       
       
        randomize
        'set up required sorts 
        SetQsort(Integer,sortintegerup,up,)
        SetQsort(Double,sortdoubledown,down,)
        SetQsort(String,sortstringup,up,)
       
        Type udt
            As single x,y,z
            as string * 2 s
        End Type
       
        SetQsort(udt,sortudtZup,up,.z)
  '----------------------------------     
        Dim As Integer i(3 To 9)
        For n As Long=3 To 9
            i(n)=Rnd*20
        Next
        sortintegerup(i(),3,9)
        printout(i)
       
        Dim As Double j(5)
        For n As Long=0 To 5
            j(n)=Rnd*20
        Next
        sortdoubledown(j(),0,5)
        printout(j)
       
        Dim As String k(...)={"Free","Commercial","Students","Expensive"}
        sortstringup(k(),Lbound(k), Ubound(k))
        printout(k)
       
       
        Dim As udt z(1 To 4)
        For n As Long=1 To 4
            z(n)=Type(Rnd*10,Rnd*10,Rnd*10,str(n))
        Next
       
        printout(z)
        sortudtZup(z(),1,4)
        printout(z)
       
        Sleep
       
       
       
         
D.J.Peters
Posts: 7904
Joined: May 28, 2005 3:28

Re: benchmark sorts

Postby D.J.Peters » Nov 21, 2018 21:31

@dodicat here are how you can make your macro faster for free

B>A is faster than A<=B
DON'T use SWAP
use the native INTEGER for array index and loop counters (32 vs 64-bit)
...

Joshy

Code: Select all

#macro SetQsort(datatype,fname,b1,b2,dot)
Sub fname(array() As datatype,begin As integer,Finish As integer)
  Dim As integer iLeft=begin,iRight=finish
  Dim As datatype tmp,x = array(((begin+finish)\2))
  While iRight>iLeft ' !!! I <= J
    While array(iLeft )dot b1 x dot:iLeft +=1:Wend
    While array(iRight)dot b2 x dot:iRight-=1:Wend
    if iLeft>iRight then exit while 
    ' !!! If I<=J Then
      ' !!! Swap array(I),array(J)
    tmp=array(iLeft) : array(iLeft)=array(iRight) : array(iRight)=tmp
    iLeft+=1:iRight-=1
    ' !!! end if 
  Wend
  If iRight > begin  Then fname(array(),begin,iRight)
  If iLeft  < Finish Then fname(array(),iLeft,Finish)
End Sub
#endmacro
dodicat
Posts: 6084
Joined: Jan 10, 2006 20:30
Location: Scotland

Re: benchmark sorts

Postby dodicat » Nov 22, 2018 14:07

Thanks D.J.Peters.
Your method is faster when using optimised gcc.
Also faster when using -gen gas.
Unoptimised gcc seems to be slower on 32 bits and about the same on 64 bits.
Swap is slower -agreed.
Integer, even on 64 bits is faster than long -- agreed.

10 runs for each method.

Code: Select all

 

#define up <,>
#define down >,<
#macro SetQsort(datatype,fname,b1,b2,dot)
Sub fname(array() As datatype,begin As integer,Finish As integer)
  Dim As integer iLeft=begin,iRight=finish
  Dim As datatype  x = array(((begin+finish)\2))
  dim as datatype tmp
  While iRight>iLeft ' !!! I <= J
    While array(iLeft )dot b1 x dot:iLeft +=1:Wend
    While array(iRight)dot b2 x dot:iRight-=1:Wend
    if iLeft>iRight then exit while 
    ' !!! If I<=J Then
      ' !!! Swap array(I),array(J)
      ''swap array(iLeft),array(iright) 'slow
    tmp=array(iLeft) : array(iLeft)=array(iRight) : array(iRight)=tmp
    iLeft+=1:iRight-=1
    ' !!! end if 
  Wend
  If iRight > begin  Then fname(array(),begin,iRight)
  If iLeft  < Finish Then fname(array(),iLeft,Finish)
End Sub
#endmacro

#macro SetQsort2(datatype,fname,b1,b2,dot)
Sub fname(array() As datatype,begin As integer,Finish As integer)
    Dim As integer i=begin,j=finish
    Dim As datatype x =array(((I+J)\2))
    While  I <= J
        While array(I)dot b1 X dot:I+=1:Wend
            While array(J)dot b2 X dot:J-=1:Wend
                If I<=J Then Swap array(I),array(J): I+=1:J-=1
            Wend
            If J > begin Then fname(array(),begin,J)
            If I < Finish Then fname(array(),I,Finish)
        End Sub
        #endmacro
       


type v3
    as single x,y,z
end type

dim as double addtimes

setqsort2(v3,sortz2,down,.z)
setqsort(v3,sortz,down,.z)


sub set(x() as v3)
    randomize 1
redim  x(5000000)
for n as long=0 to ubound(x)
    x(n)=type(rnd,rnd,rnd)
next
end sub

redim as v3 x()

set(x())
sortz2(x(),0,ubound(x))  'warm up

print "original"
for n as long=1 to 10
set(x())
dim as double t=timer,t2
sortz2(x(),0,ubound(x))
t2=timer
addtimes+=t2-t
print t2-t
next n
print
print "total + check value "; addtimes,x(111222).z
sleep 50
print
print
addtimes=0
print "D.J.Peters"
for n as long=1 to 10
set(x())
dim as double t=timer,t2
sortz(x(),0,ubound(x))
t2=timer
addtimes+=t2-t
print t2-t
next n
print
print "total + check value "; addtimes,x(111222).z
sleep

 
D.J.Peters
Posts: 7904
Joined: May 28, 2005 3:28

Re: benchmark sorts

Postby D.J.Peters » Nov 22, 2018 15:30

@dafhi why do you ignore the FreeBASIC pointer quick sort in your benchmark ?

Joshy
dafhi
Posts: 1303
Joined: Jun 04, 2005 9:51

Re: benchmark sorts

Postby dafhi » Nov 22, 2018 18:43

when I developed 'ytQSort2' it took me at least 2 days to get it working. quicksort, it would seem, is one of my achilles' heels.

D. J. Peters when I run your pointer sort (latest WinFBE which uncludes fbc 1.06) it still shows Munair's version faster.
Have you tried your sort with my profiler?

Code: Select all

dim shared as SORT_TYPE sw_temp

'
' https://www.freebasic.net/forum/viewtopic.php?f=7&t=27173
'
sub quicksortPointer(l as SORT_TYPE ptr, r as SORT_TYPE ptr)
  'if (r - l <= 1) then return
  dim as SORT_TYPE ptr  p=l+1, ii=p
  'dim as SORT_TYPE t=any
  while (p <= r)
     if (*(p)dot < *(l)dot) then sw_temp=*p: *p=*ii: *ii=sw_temp: ii+=1
'     if (*(p)dot < *(l)dot) then swap *ii,*p: ii+=1
    p+=1
  wend
  p=ii-1:sw_temp=*l:*l=*p:*p=sw_temp
  'swap *l, *p
  if l<p then quicksortPointer(l, p)
  if ii<r then quicksortPointer(ii, r)
end sub

..
   #define sort_b mac_timer( quicksortpointer( @a(0), @a(ubound(a)) ), tB, "qs_djp" )


Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 1 guest