Replace any recursion by unlimited iteration with own stack

Post your FreeBASIC tips and tricks here. Please don’t post your code without including an explanation.
fxm
Posts: 9559
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Replace any recursion by unlimited iteration with own stack

Postby fxm » Sep 01, 2011 20:13

To avoid limitation due to the system stack size, you can always (more or less easily) replace a recursive algorithm by an iterative algorithm by pushing the parameters that would normally be passed to the recursive function onto an own unlimited stack. In fact, you are replacing the program stack by one of your own (not limited in size):

- Just make the accumulator variable a local one.

- Just check which values are saved across recursive calls, those are the ones that have to be local to the recursive function, and replace the calls with a cycle where you will push them on a stack.

- When the stack is empty the recursive function would have been terminated.



Example: Computation of the combination coefficients nCp (binomial coefficients calculation) and display of the Pascal's triangle

In the following example, I used as stack the one that I proposed in a previous topic of this forum:
UDT: Dynamic Queue/Stack for data-type (numeric/string/user)
http://www.freebasic.net/forum/viewtopic.php?t=18415

The first function 'Combination_recursion' is the recursive form.
(not a tail recursion because there are two recursive calls with summation in the last active statement)

The second function 'Combination_iteration_stack' is the iterative form using an own stack.

In the two functions, I conserved a similar structure to enlighten the conversion method.
From recursive function to iterative stacking function:
- Ahead, declaration adding of 3 local variables for parameters stacking (2) plus the accumulator (1).
- Pushing the two initial parameters values in the stack.
- Entering in the Do While ... Loop to empty the stack.
- Pulling parameters from the stack.
- 'Return 1' of the 'Then' is replaced by 'cumul = cumul + 1'.
- 'Return Combination_recursion(n - 1, p) + Combination_recursion(n - 1, p - 1)' of the 'Else' is replaced by 'S.stack_push(ns - 1) : S.stack_push(ps) : S.stack_push(ns - 1) : S.stack_push(ps - 1)'.

Code: Select all

Function Combination_recursion (Byval n As Uinteger, Byval p As Uinteger) As Longint
  If p = 0 Or p = n then
    Return 1
  Else
    Return Combination_recursion(n - 1, p) + Combination_recursion(n - 1, p - 1)
  End If
End Function

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

#Include "UDT_dynamic_queue_stack.bi"
UDT_dynamic_queue_stack(Uinteger)
Dim Shared S As UDT_dynamic_queue_stack_Uinteger

Function Combination_iteration_stack (Byval n As Uinteger, Byval p As Uinteger) As Longint
  Dim cumul As Longint = 0
  Dim ns As Uinteger
  Dim ps As Uinteger
  S.stack_push(n)
  S.stack_push(p)
  Do While S.size > 0
    ps = S.stack_pull
    ns = S.stack_pull
    If ps = 0 Or ps = ns then
      cumul = cumul + 1
    Else
      S.stack_push(ns - 1)
      S.stack_push(ps)
      S.stack_push(ns - 1)
      S.stack_push(ps - 1)
    End If
  Loop
  Return cumul
End Function

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

Sub Display(Byval Combination As Function (Byval n As Uinteger, Byval p As Uinteger) As Longint, Byval n As Integer)
  For I As Uinteger = 0 To n
    For J As Uinteger = 0 To I
      Locate , 6 * J + 3 * (n - I) + 3
      Print Combination(I, J);
    Next J
    Print
  Next I
End Sub

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

Screen 12
Print
Print " recursion";
Display(@Combination_recursion, 12)
Print
Print
Print " iteration with own stack";
Display(@Combination_iteration_stack, 12)
Sleep


A classic iteration without using stack does not seem to be easy to code (because it is not a tail recursion), if not all completely recalculate the Pascal's triangle for any nCp value requested!
See below this third function 'Combination_iteration_classic' added to the previous program:

Code: Select all

Function Combination_recursion (Byval n As Uinteger, Byval p As Uinteger) As Longint
  If p = 0 Or p = n then
    Return 1
  Else
    Return Combination_recursion(n - 1, p) + Combination_recursion(n - 1, p - 1)
  End If
End Function

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

#Include "UDT_dynamic_queue_stack.bi"
UDT_dynamic_queue_stack(Uinteger)
Dim Shared S As UDT_dynamic_queue_stack_Uinteger

Function Combination_iteration_stack (Byval n As Uinteger, Byval p As Uinteger) As Longint
  Dim cumul As Longint = 0
  Dim ns As Uinteger
  Dim ps As Uinteger
  S.stack_push(n)
  S.stack_push(p)
  Do While S.size > 0
    ps = S.stack_pull
    ns = S.stack_pull
    If ps = 0 Or ps = ns then
      cumul = cumul + 1
    Else
      S.stack_push(ns - 1)
      S.stack_push(ps)
      S.stack_push(ns - 1)
      S.stack_push(ps - 1)
    End If
  Loop
  Return cumul
End Function

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

Function Combination_iteration_classic (Byval n As Uinteger, Byval p As Uinteger) As Longint
  Dim array(n, n) As Longint
  For I As Uinteger = 0 To n
    For J As Uinteger = 0 To I
      If J = 0 Or J = I Then
        array(I, J) = 1
      Else
        array(I, J) = array(I - 1, J) + array(I - 1, J - 1)
      End If
    Next J
  Next I
  Return array(n, p)
End Function

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

Sub Display(Byval Combination As Function (Byval n As Uinteger, Byval p As Uinteger) As Longint, Byval n As Integer)
  For I As Uinteger = 0 To n
    For J As Uinteger = 0 To I
      Locate , 6 * J + 3 * (n - I) + 3
      Print Combination(I, J);
    Next J
    Print
  Next I
End Sub

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

Screenres 640, 480
Print
Print " recursion";
Display(@Combination_recursion, 12)
Print
Print
Print
Print " iteration with own stack";
Display(@Combination_iteration_stack, 12)
Print
Print
Print
Print " iteration without stack";
Display(@Combination_iteration_classic, 12)
Sleep



Other graphical example

Code: Select all

Sub Draw_circle_recursion(Byval x As Integer, Byval y As Integer, Byval r As Integer)
  Circle (x, y), r
  If r > 16 Then
    Draw_circle_recursion(x + r / 2, y, r / 2)
    Draw_circle_recursion(x - r / 2, y, r / 2)
    Draw_circle_recursion(x, y + r / 2, r / 2)
    Draw_circle_recursion(x, y - r / 2, r / 2)
  End If
End Sub

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

#Include "UDT_dynamic_queue_stack.bi"
UDT_dynamic_queue_stack(Integer)
Dim Shared S As UDT_dynamic_queue_stack_Integer

Sub Draw_circle_iteration_stack(Byval x As Integer, Byval y As Integer, Byval r As Integer)
  Dim xs As Integer
  Dim ys As Integer
  Dim rs As Integer
  S.stack_push(x)
  S.stack_push(y)
  S.stack_push(r)
  Do While S.size > 0
    rs = S.stack_pull
    ys = S.stack_pull
    xs = S.stack_pull
    Circle (xs, ys), rs
    If rs > 16 Then
      S.stack_push(xs + rs / 2)
      S.stack_push(ys)
      S.stack_push(rs / 2)
      S.stack_push(xs - rs / 2)
      S.stack_push(ys)
      S.stack_push(rs / 2)
      S.stack_push(xs)
      S.stack_push(ys + rs / 2)
      S.stack_push(rs / 2)
      S.stack_push(xs)
      S.stack_push(ys - rs / 2)
      S.stack_push(rs / 2)
    End If
  Loop
End Sub

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

Screen 12
Locate 2, 2
Print "recursion"
Draw_circle_recursion(160, 160, 150)
Locate 10, 60
Print "iteration with stack"
Draw_circle_iteration_stack(480, 320, 150)
Sleep



[Edit]
Structure of the function 'Combination_iteration_stack' slightly modified to better fit with the recursive structure of the function 'Combination_recursion', in order to well enlighten the principle of replacing a recursive algorithm by an iterative stacking algorithm (see explanation above).
Last edited by fxm on Sep 05, 2011 17:59, edited 4 times in total.
dafhi
Posts: 1335
Joined: Jun 04, 2005 9:51

Postby dafhi » Sep 02, 2011 12:27

I love your work. Not that I understand any of it
dodicat
Posts: 6390
Joined: Jan 10, 2006 20:30
Location: Scotland

Postby dodicat » Sep 02, 2011 21:15

Hi fxm
Nice work, I like your recursive combinations.
I'm still trying to avoid eating stack by other methods (work in progress).

However, I'm sure that you would be disappointed if I didn't return some brutish code, you normally despair at it, this time combinations, desperately handled, but will show you the number of devils who have lived in this world right up to the present date.
(A bit of fun remember, mutually exclusive of your work)

@Dafhi, excluding yourself of course.

Code: Select all


Function minus(NUM1 As String,NUM2 As String) As String
    Dim  SUBQmod(0 To 19) As Ubyte
    Dim SUBbool(0 To 19) As Ubyte
    For z As Integer=0 To 19
    SUBQmod(z)=Cubyte(z Mod 10+48)
    SUBbool(z)=Cubyte(-(10>z))
Next z
        Dim As Byte swapflag           
        Dim sign As String * 1
        Dim bigger As Byte
      Dim As Long  lenf=Len(NUM1)
      Dim As Long  lens=Len(NUM2)
         #macro compare(numbers)
If Lens>lenf Then bigger= -1:Goto fin
    If Lens<lenf Then bigger =0:Goto fin
    If NUM2>NUM1 Then
        bigger=-1
    Else
        bigger= 0
    End If
    fin:
#endmacro
compare(numbers)
If bigger Then
sign="-"
Swap NUM2,NUM1
Swap lens,lenf
swapflag=1
Endif
       
        Dim diff As Long=lenf-lens-Sgn(lenf-lens)
        Dim As String three=NUM1
       Dim As String  two=String(lenf-lens,"0")+NUM2
        Dim As String one=NUM1
        Dim As Long n2
        Dim As Ubyte takeaway,subtractcarry
        Dim As Ubyte ten=10
        subtractcarry=0
        Do
         For n2=lenf-1 To diff Step -1
           takeaway= one[n2]-two[n2]+ten-subtractcarry
           three[n2]=SUBQmod(takeaway)
            subtractcarry=SUBbool(takeaway)
        Next n2
        If subtractcarry=0 Then Exit Do
        If n2=-1 Then Exit Do
        For n2=n2 To 0 Step -1
            takeaway= one[n2]-two[n2]+ten-subtractcarry
            three[n2]=SUBQmod(takeaway)
            subtractcarry=SUBbool(takeaway)
            Next n2
        Exit Do
        Loop
        three=Ltrim(three,"0")
        If three="" Then Return "0"
        If swapflag=1 Then Swap NUM1,NUM2
       Return sign+three
End Function
Function _divide(n1 As String,n2 As String,decimal_places As Long,dpflag As String="s") As String
          Dim As String number=n1,divisor=n2
     If dpflag<>"s" Then dpflag="raw"   
        Dim runcount As Long
        '_______  LOOK UP TABLES ______________
        Dim Qmod(0 To 19) As Ubyte:Dim atQmod As Ubyte Pointer
        Dim bool(0 To 19) As Ubyte:Dim atbool As Ubyte Pointer
        For z As Integer=0 To 19
    Qmod(z)=Cubyte(z Mod 10+48)
    bool(z)=Cubyte(-(10>z))
Next z
atQmod=@Qmod(0)
atbool=@bool(0)
 Dim answer As String   'THE ANSWER STRING 
 Dim atanswer As Ubyte Pointer
 
'_______ SET THE DECIMAL WHERE IT SHOULD BE AT _______
Dim As String part1,part2
#macro set(decimal)
#macro insert(s,char,position)
If position > 0 And position <=Len(s) Then
 part1=Mid$(s,1,position-1)
 part2=Mid$(s,position)
 s=part1+char+part2
 Endif
 #endmacro
 insert(answer,".",decpos)
  answer=thepoint+zeros+answer
 If dpflag="raw" Then
    answer=Mid(answer,1,decimal_places)
    Endif
 #endmacro
 '______________________________________________
 '__________ SPLIT A STRING ABOUT A CHARACTRR __________
 Dim As String var1,var2
    Dim pst As Long
      #macro split(stri,char,var1,var2)
    pst=Instr(stri,char)
    var1="":var2=""
    If pst<>0 Then
    var1=Rtrim(Mid(stri,1,pst),".")
    var2=Ltrim(Mid(stri,pst),".")
Else
    var1=stri
    Endif
    #endmacro
   
       #macro Removepoint(s)
       split(s,".",var1,var2)
#endmacro
'__________ GET THE SIGN AND CLEAR THE -ve __________________
Dim sign As String
          If Left(number,1)="-" Xor Left (divisor,1)="-" Then sign="-"
            If Left(number,1)="-" Then  number=Ltrim(number,"-")
            If Left (divisor,1)="-" Then divisor=Ltrim(divisor,"-")
             
'DETERMINE THE DECIMAL POSITION BEFORE THE DIVISION
Dim As Long lennint,lenddec,lend,lenn,difflen
split(number,".",var1,var2)
lennint=Len(var1)
split(divisor,".",var1,var2)
lenddec=Len(var2)

If Instr(number,".") Then
    Removepoint(number)
    number=var1+var2
    Endif
If Instr(divisor,".") Then
    Removepoint(divisor)
    divisor=var1+var2
    Endif
Dim As Long numzeros
numzeros=Len(number)
number=Ltrim(number,"0"):divisor=Ltrim (divisor,"0")
numzeros=numzeros-Len(number)
lend=Len(divisor):lenn=Len(number)
If lend>lenn Then difflen=lend-lenn
Dim decpos As Long=lenddec+lennint-lend+2-numzeros 'THE POSITION INDICATOR
'Dim answer As String   'THE ANSWER STRING
Dim _sgn As Byte=-Sgn(decpos)
 If _sgn=0 Then _sgn=1
 Dim As String thepoint=String(_sgn,".") 'DECIMAL AT START (IF)
 Dim As String zeros=String(-decpos+1,"0")'ZEROS AT START (IF) e.g. .0009
 If Len(zeros) =0 Then dpflag="s"
 Dim As Long runlength
 If Len(zeros) Then
     runlength=decimal_places
     answer=String(Len(zeros)+runlength+10,"0")
     atanswer=@answer[0]
     'atanswer=@answer
    If dpflag="raw" Then
        runlength=1
        answer=String(Len(zeros)+runlength+10,"0")
        atanswer=@answer[0]
        'atanswer=@answer
        If decimal_places>Len(zeros) Then
            runlength=runlength+(decimal_places-Len(zeros))
            answer=String(Len(zeros)+runlength+10,"0")
            atanswer=@answer[0]
            'atanswer=@answer
            Endif
            Endif
 
Else
decimal_places=decimal_places+decpos
runlength=decimal_places
answer=String(Len(zeros)+runlength+10,"0")
atanswer=@answer[0]
 Endif
'___________DECIMAL POSITION DETERMINED (A  pure joy!) _____________

'SET UP THE VARIABLES AND START UP CONDITIONS
number=number+String(difflen+decimal_places,"0")

        Dim count As Short'=0
        Dim temp As String
        Dim copytemp As String
        Dim topstring As String
        Dim copytopstring As String
        Dim As Long lenf,lens
        Dim As Ubyte takeaway,subtractcarry
        Dim As Ubyte ten=10
        Dim As Ubyte fortyeight=48
        Dim As Ubyte zero=0
        Dim As Ubyte _one=1
        Dim As Ubyte Pointer ptemp
        Dim As Long n3,diff
        Dim As String one,two
       If Ltrim(divisor,"0")="" Then Return "Error :division by zero"   
        lens=Len(divisor)
         topstring=Left(number,lend)
         copytopstring=topstring
        Do
            count=zero
        Do
            count=count+_one
            copytemp=temp
   
            Do
 '___________________ QUICK SUBTRACTION loop _________________             
           
lenf=Len(topstring)
If Not lens<lenf Then
If Lens>lenf Then
temp= "done"
 Exit Do
Endif
If divisor>topstring Then
temp= "done"
Exit Do
Endif
Endif

  diff=lenf-lens-Sgn(lenf-lens)
       
        temp=topstring
        ptemp=@temp[0]
        two=String(lenf-lens,"0")+divisor
        one=topstring
        subtractcarry=zero
       
        For n3=lenf-1 To diff Step -1
            takeaway= one[n3]-two[n3]+ten-subtractcarry
            ptemp[n3]=atQmod[takeaway]
            subtractcarry=atbool[takeaway]
        Next n3
        If subtractcarry=zero Then Exit Do
         If n3=-1 Then Exit Do
        For n3=n3 To 0 Step -1
            takeaway= one[n3]-two[n3]+ten-subtractcarry
             ptemp[n3]=atQmod[takeaway]
            subtractcarry=atbool[takeaway]
            'if subtractcarry=zero then exit do
            Next n3
        Exit Do
       
        Loop 'single run
        temp=Ltrim(temp,"0")
       
        If temp="" Then temp= "0"
               
            topstring=temp
        Loop Until temp="done"
     ' INDIVIDUAL CHARACTERS CARVED OFF ________________       
        runcount=runcount+1
       If count=1 Then
           topstring=copytopstring+Mid(number,lend+runcount,1)
           Else
       topstring=copytemp+Mid(number,lend+runcount,1)
   End If
       copytopstring=topstring
       topstring=Ltrim(topstring,"0")
       atanswer[runcount-1]=count-_one+fortyeight 'build the answer by the pointer
       If topstring="" And runcount>Len(n1)+1 Then
           Exit Do
           Endif
   Loop Until runcount=runlength+1
   ' END OF RUN TO REQUIRED DECIMAL PLACES
   set(decimal) 'PUT IN THE DECIMAL POINT
  'THERE IS ALWAYS A DECIMAL POINT SOMEWHERE IN THE ANSWER
  'NOW GET RID OF IT IF IT IS REDUNDANT
       answer=Rtrim(answer,"0")
       answer=Rtrim(answer,".")
       answer=Ltrim(answer,"0")
       If answer="" Then Return "0"
   Return sign+answer
End Function



#macro plus(_num1,_num2)
Do
    _flag=0
    #macro finish()
    answer=Ltrim(answer,"0")
    If _flag=1 Then Swap _num2,_num1
    Exit Do
    #endmacro
    If Len(_num2)>Len(_num1) Then
        Swap _num2,_num1
        _flag=1
    Endif
       
        diff=Len(_num1)-Len(_num2)
        answer="0"+_num1
        addcarry=0
        For n_=Len(_num1)-1 To diff Step -1
            addup=_num2[n_-diff]+_num1[n_]-96
            answer[n_+1]=ADDQmod(addup+addcarry)
            addcarry=ADDbool(addup+addcarry)
        Next n_
        If addcarry=0 Then
            finish()
        Endif
            If n_=-1 Then
                answer[0]=addcarry+48
                finish()
            Endif
                For n_=n_ To 0 Step -1
                    addup=_num1[n_]-48
                    answer[n_+1]=ADDQmod(addup+addcarry)
                    addcarry=ADDbool(addup+addcarry)
                Next n_
                answer[0]=addcarry+48
                finish()
                Exit Do
            Loop
            #endmacro
#macro mult(num1,num2)
            flag=0
            If Len(num2)>Len(num1) Then
                flag=1
                Swap num2,num1
            End If
            three="0"&num1
            accum="0"
            For n1 As Integer=Len(num2)-1 To 0 Step -1
                multcarry=0
                For n2 As Integer=Len(num1)-1 To 0 Step -1
                    multadd=multaddtable(num2[n1],num1[n2])
                    three[n2+1]= threetable(multadd,multcarry)
                    multcarry=multcarrytable(multadd,multcarry)
                Next n2
                three[0]=multcarry+48
                plus(three,accum)
                accum=answer
                three=three+"0"
            Next n1
            If flag=1 Then Swap num2,num1
            #endmacro
Function Factorial( n As String) As String
Dim  As Ubyte multcarrytable( 81,9),threetable( 81,9),multaddtable(48 To 57,48 To 57)
Dim As Ubyte ADDQmod(0 To 19),ADDbool(0 To 19)
                For x As Integer=48 To 57
                    For y As Integer=48 To 57
                        multaddtable(x,y)=(x-48)*(y-48)
                    Next y
                Next x
                For x As Integer=0 To 81
                    For y As Integer=0 To 9
                        threetable(x,y)=((x + y) Mod 10)+48
                        multcarrytable(x,y)=(x+y-(x+y) Mod 10)\10
                    Next y
                Next x
                For z As Integer=0 To 19
                    ADDQmod(z)=(z Mod 10+48)
                    ADDbool(z)=(-(10<=z))
                Next z
               
                Dim  As Ubyte addup,addcarry
                Dim As Integer multadd,multcarry,diff,n_
                Dim As Byte flag,_flag
                Dim As String accum,three,answer,z="0",fact="1",one=fact
                If Ltrim(n,"0")="" Then Return fact
                Do
                    plus(z,one)
                    z=answer
                    mult(fact,z)
                    fact = accum
                Loop Until z=n
                Return fact
            End Function
           
            Function combination_brute(b  As String,s As String) As String
                If b = "0" Or b = s then return "1"
                Dim As String temp1,temp2,temp3,ans
               Dim  As Ubyte multcarrytable( 81,9),threetable( 81,9),multaddtable(48 To 57,48 To 57)
Dim As Ubyte ADDQmod(0 To 19),ADDbool(0 To 19)
                For x As Integer=48 To 57
                    For y As Integer=48 To 57
                        multaddtable(x,y)=(x-48)*(y-48)
                    Next y
                Next x
                For x As Integer=0 To 81
                    For y As Integer=0 To 9
                        threetable(x,y)=((x + y) Mod 10)+48
                        multcarrytable(x,y)=(x+y-(x+y) Mod 10)\10
                    Next y
                Next x
                For z As Integer=0 To 19
                    ADDQmod(z)=(z Mod 10+48)
                    ADDbool(z)=(-(10<=z))
                Next z
               
                Dim  As Ubyte addup,addcarry
                Dim As Integer multadd,multcarry,diff,n_
                Dim As Byte flag,_flag
                Dim As String accum,three,answer,z="0",fact="1",one=fact
                'ANS=factorial(big)/factorial(small)*factorial(big-small)
                temp1=factorial(b)     'factorial (big)
                temp2=factorial(s)     'factorial (small)
                temp3=minus(b,s)       '(big-small)
                temp3=factorial(temp3) 'factorial(big-small)
                mult(temp2,temp3) 
                temp3=accum            'factorial(small)*factorial(big-small)
                ans=_divide(temp1,temp3,10)'ANS
                Return ans
                End Function
           
            Dim As Double t1,t2
            Dim As String ans
            t1=Timer
            ans=combination_brute("2011","666")
            t2=Timer
            print
            Print ans
            print
            Print "Time ";t2-t1
            Sleep
           
fxm
Posts: 9559
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Postby fxm » Sep 02, 2011 21:34

Quick Sort algorithm: recursion replaced by iteration with own unlimited stack

- Simple Quick Sort algorithm with pivot = left/right.
- 200 unsorted ubytes get by memory allocation, then random initialization.

Quick Sort by recursion:

Code: Select all

Dim shared As Ubyte Ptr t
t = Allocate(200 * Sizeof(Ubyte))
Randomize
For I As Integer = 0 To 199
  t[i] = Int(Rnd * 256)
Next I

Sub QuickSort_recursion(Byval L As Integer, Byval R As Integer)
  Dim As Integer pivot = L
  Dim As Integer I = L
  Dim As Integer J = R
  Do
    If t[I] >= t[J] then
      Swap t[I], t[J]
      pivot = L + R - pivot
    End If
    If pivot = L then
      J = J - 1
    Else
      I = I + 1
    End If
  Loop Until I = J
  If L < I - 1 Then
    QuickSort_recursion(L, I - 1)
  End If
  If R > J + 1 Then
    QuickSort_recursion(J + 1, R)
  End If
End Sub



Print "raw memory"
For K As Integer = 0 To 199
  Print Using "####"; t[K];
Next K
Print

QuickSort_recursion(0, 199)

Print "sorted memory by recursion"
For K As Integer = 0 To 199
  Print Using "####"; t[K];
Next K

Sleep
Deallocate(t)

Quick Sort by iteration with stack (see my previous post for stack usage):
( http://www.freebasic.net/forum/viewtopic.php?t=18415 )

Code: Select all

Dim shared As Ubyte Ptr t
t = Allocate(200 * Sizeof(Ubyte))
Randomize
For I As Integer = 0 To 199
  t[i] = Int(Rnd * 256)
Next I

#Include "UDT_dynamic_queue_stack.bi"
UDT_dynamic_queue_stack(integer)
Dim Shared As UDT_dynamic_queue_stack_integer S

Sub QuickSort_stacking(Byval L As Integer, Byval R As Integer)
  Dim As Integer Ls
  Dim As Integer Rs
  S.stack_push(L)
  S.stack_push(R)
  Do While S.size > 0
    Rs = S.stack_pull
    Ls = S.stack_pull
    Dim pivot As Integer = Ls
    Dim As Integer I = Ls
    Dim As Integer J = Rs
    Do
      If t[I] >= t[J] then
        Swap t[I], t[J]
        pivot = Ls + Rs - pivot
      End If
      If pivot = Ls then
        J = J - 1
      Else
        I = I + 1
      End If
    Loop Until I = J
    If Ls < I - 1 Then
      S.stack_push(Ls)
      S.stack_push(I - 1)
    End If
    If Rs > J + 1 Then
      S.stack_push(J + 1)
      S.stack_push(Rs)
    End If
  Loop
End Sub



Print "raw memory"
For K As Integer = 0 To 199
  Print Using "####"; t[K];
Next K
Print

QuickSort_stacking(0, 199)

Print "sorted memory by iteration with stack"
For K As Integer = 0 To 199
  Print Using "####"; t[K];
Next K

Sleep
Deallocate(t)


[Edit]
- Addition of a random initialization of the allocated memory, because when you allocate much memory the ubytes are often set to 0 or set to nonrandom values.
- Addition of link to 'UDT: Dynamic Queue/Stack for data-type (numeric/string/user)'.
- Addition of memory deallocation (good practice!)
Last edited by fxm on Sep 03, 2011 8:42, edited 6 times in total.
dodicat
Posts: 6390
Joined: Jan 10, 2006 20:30
Location: Scotland

Postby dodicat » Sep 02, 2011 22:27

Some recursive routines can just use goto instead of recursion, yours seems to, but the Quicksort I normally use, I'm having difficulty with:
Here's yours.

Code: Select all

Dim shared As Ubyte Ptr t
t = Allocate(200 * Sizeof(Ubyte))

Sub QuickSort_recursion(Byval L As Integer, Byval R As Integer)
  Dim As Integer pivot = L
  Dim As Integer I = L
  Dim As Integer J = R
  Do
    If t[I] >= t[J] then
      Swap t[I], t[J]
      pivot = L + R - pivot
    End If
    If pivot = L then
      J = J - 1
    Else
      I = I + 1
    End If
  Loop Until I = J
  If L < I - 1 Then
    QuickSort_recursion(L, I - 1)
  End If
  If R > J + 1 Then
    QuickSort_recursion(J + 1, R)
  End If
End Sub


Sub QuickSort_GOTO(Byval L As Integer, Byval R As Integer)
  Dim As Integer pivot = L
  Dim As Integer I = L
  Dim As Integer J = R
  pivot=L
  start:
  I=L
  J=R
  Do
    If t[I] >= t[J] then
      Swap t[I], t[J]
      pivot = L + R - pivot
    End If
    If pivot = L then
      J = J - 1
    Else
      I = I + 1
    End If
  Loop Until I = J
  If L < I - 1 Then
      R=I-1
      goto start
   
  End If
  If R > J + 1 Then
      L=J+1
      goto start
   
  End If
End Sub


Print "raw memory"
For K As Integer = 0 To 199
  Print Using "####"; t[K];
Next K
Print

QuickSort_GOTO(0, 199)

Print "sorted memory by GOTO"
For K As Integer = 0 To 199
  Print Using "####"; t[K];
Next K

Sleep
 
fxm
Posts: 9559
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Postby fxm » Sep 03, 2011 5:19

dodicat wrote:Some recursive routines can just use goto instead of recursion, yours seems to, but the Quicksort I normally use, I'm having difficulty with:
Here's yours.

Code: Select all

Dim shared As Ubyte Ptr t
t = Allocate(2000 * Sizeof(Ubyte))
Randomize
For I As Integer = 0 To 1999
  t[i] = Int(Rnd * 256)
Next I

Sub QuickSort_recursion(Byval L As Integer, Byval R As Integer)
  Dim As Integer pivot = L
  Dim As Integer I = L
  Dim As Integer J = R
  Do
    If t[I] >= t[J] then
      Swap t[I], t[J]
      pivot = L + R - pivot
    End If
    If pivot = L then
      J = J - 1
    Else
      I = I + 1
    End If
  Loop Until I = J
  If L < I - 1 Then
    QuickSort_recursion(L, I - 1)
  End If
  If R > J + 1 Then
    QuickSort_recursion(J + 1, R)
  End If
End Sub


Sub QuickSort_GOTO(Byval L As Integer, Byval R As Integer)
  Dim As Integer pivot = L
  Dim As Integer I = L
  Dim As Integer J = R
  pivot=L
  start:
  I=L
  J=R
  Do
    If t[I] >= t[J] then
      Swap t[I], t[J]
      pivot = L + R - pivot
    End If
    If pivot = L then
      J = J - 1
    Else
      I = I + 1
    End If
  Loop Until I = J
  If L < I - 1 Then
      R=I-1
      goto start
   
  End If
  If R > J + 1 Then
      L=J+1
      goto start
   
  End If
End Sub


Print "raw memory"
For K As Integer = 0 To 199
  Print Using "####"; t[K];
Next K
Print

QuickSort_GOTO(0, 199)

Print "sorted memory by GOTO"
For K As Integer = 0 To 199
  Print Using "####"; t[K];
Next K

Sleep
Deallocate(t)

Your 'GOTO' iteration does not work because it does not take into account the case of multiple-recursion:
- When both 'QuickSort_recursion(L, I - 1)' and 'QuickSort_recursion(J + 1, R)' are recursively called (case L < I - 1 and R > J + 1).
- Should be forced in this case a double GOTO reentering, each with the right associated parameters.

IMHO, there is no solution using 'GOTO' (idem for my two previous examples).
Only tail recursion (at more any one terminal recursion in the sequence) can be replaced by an iteration using only 'GOTO'.
The advantage of using a own stack is precisely the ability to emulate the re-entrance.


PS:
In my previous post (and yours above), I added a random initialization of the allocated memory, because when you allocate much memory the ubytes are often set to 0 or set to nonrandom values, plus memory deallocation (good practice!).
dodicat
Posts: 6390
Joined: Jan 10, 2006 20:30
Location: Scotland

Postby dodicat » Sep 03, 2011 11:25

Hi fxm
You are probably right about GOTO, however, it's fun trying to eke it out in various ways.
For example, conditions set just before leaving the sub will throw the partially sorted array back into touch , to have yet another purge.
I'm sure that these conditions could be optimized better than here.
It works ok, but slows down Quicksort, which defeats the purpose.
I'll post no more here for it is slightly off topic, I don't want to throw off would be members viewing your post.

Code: Select all

sub qsort(a() as double,L as integer,R as integer)
    dim as integer L2=L,R2=R
  Dim As Integer pivot = L,I,J
  dim as double max=-1e200,min=1e200
  for z as integer=L to R
      if max<a(z) then max=a(z)
      if min>a(z) then min=a(z)
  next z
  start:
   I = L
  J = R
  Do
    If a(I) >= a(J) then
      Swap a(I), a(J)
      pivot = L + R - pivot
    End If
    If pivot = L then
      J = J - 1
    Else
      I = I + 1
    End If
  Loop Until I = J
  If L < I - 1 Then
      R=I-1
      goto start
  End If
  If R > J + 1 Then
      L=J+1
      goto start
  End If
  'END CONDITIONS
  if a(Ubound(a))<> max or a(lbound(a))<> min then
      L=L2:R=R2
  goto start
  end if
end sub

dim as integer n=10000'0
dim  as double b(1 to N)
for z as integer=1 to n
    'b(z)=n-z
    b(z)=(rnd*100)
next z

qsort(b(),lbound(b),ubound(b))

for z as integer=1 to 20
    print b(z)
next z
print "..."
print
for z as integer=ubound(b)-20 to ubound(b)
    print b(z)
next z
print

Sleep
fxm
Posts: 9559
Joined: Apr 22, 2009 12:46
Location: Paris suburbs, FRANCE

Postby fxm » Sep 05, 2011 11:29

In my first post of this topic, I slightly modified the structure of the function 'Combination_iteration_stack' to better fit with the recursive structure of the function 'Combination_recursion', in order to well enlighten the principle of replacing a recursive algorithm by an iterative stacking algorithm.

My other examples ('Draw_circle_iteration_stack' and 'QuickSort_stacking') being already well structured.



In order to be more explicit, see below a second example based on the Fibonacci series : F(n) = F(n-1) + F(n-2), with F(0) = 0 and F(1) = 1.

Between the two functions, I conserved a similar structure to enlighten the conversion method.
From recursive function to iterative stacking function:
- Ahead, declaration adding of 2 local variables for parameter stacking plus the accumulator.
- Pushing the initial parameter value in the stack.
- Entering in the Do While ... Loop to empty the stack.
- Pulling parameter from the stack.
- 'Return n' of the 'Then' is replaced by 'cumul = cumul + ns'.
- 'Return Fibonacci_recursion(n - 1) + Fibonacci_recursion(n - 2)' of the 'Else' is replaced by 'S.stack_push(ns - 1) : S.stack_push(ns - 2)'.

Fibonacci series

Code: Select all

Function Fibonacci_recursion (Byval n As Uinteger) As Longint
  If n = 0 Or n = 1 then
    Return n
  Else
    Return Fibonacci_recursion(n - 1) + Fibonacci_recursion(n - 2)
  End If
End Function

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

#Include "UDT_dynamic_queue_stack.bi"
UDT_dynamic_queue_stack(Uinteger)
Dim Shared S As UDT_dynamic_queue_stack_Uinteger

Function Fibonacci_iteration_stack (Byval n As Uinteger) As Longint
  Dim cumul As Longint = 0
  Dim ns As Uinteger
  S.stack_push(n)
  Do While S.size > 0
    ns = S.stack_pull
    If ns = 0 Or ns = 1 then
      cumul = cumul + ns
    Else
      S.stack_push(ns - 1)
      S.stack_push(ns - 2)
    End If
  Loop
  Return cumul
End Function

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

Function Fibonacci_iteration_classic (Byval n As Uinteger) As Longint
  Dim array(n) As Longint
  For I As Uinteger = 0 To n
    If I = 0 Or I = 1 Then
      array(I) = I
    Else
      array(I) = array(I - 1) + array(I - 2)
    End If
  Next I
  Return array(n)
End Function

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

Sub Display(Byval Fibonacci As Function (Byval n As Uinteger) As Longint, Byval n As Integer)
  For I As Uinteger = 0 To n
    If I Mod 8 = 0 Then
      Print
    End If
    Locate , 10 * (I Mod 8)
    Print Fibonacci(I);
  Next I
End Sub

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

'Screen 12
Print
Print " recursion";
Display(@Fibonacci_recursion, 31)
Print
Print
Print
Print " iteration with own stack";
Display(@Fibonacci_iteration_stack, 31)
Print
Print
Print
Print " iteration without stack";
Display(@Fibonacci_iteration_classic, 31)
Print
Sleep
see this previous post for stack usage:
http://www.freebasic.net/forum/viewtopic.php?t=18415



Fibonacci series linearizing

We can remark in the above example that the execution time duration for the highest values (recursive or iterative stacking algorithm) becomes no more negligible:
Indeed, to compute F(n), there are 2^(n-1) calls: about one milliard for n=31.

We can then try to linearize the recursive algorithm, using a recursive function which have 2 other parameters corresponding to the previous value and the last value of the series, let f(a, b, n).
We obtain:
for (n-1): a = F(n-2), b = F(n-1)
for (n): F(n-1) = b, F(n) = F(n-1) + F(n-2) = a + b
and
for (1): F(0) = 0 , F(1) = 1

Consequently, for this new function f(a, b, n), the recursion becomes f(b, a+b, n-1), and there are only (n-1) calls.
This iterative stacking algorithm is also modified accordingly.

Linearized Fibonacci series
(with even one more line computed)

Code: Select all

Function Fibonacci_recursion_2 (Byval a As Uinteger, Byval b As Uinteger, Byval n As Uinteger) As Longint
  If n <= 1 Then
    Return b * n
  Else
    Return Fibonacci_recursion_2(b, a + b, n - 1)
  End If
End Function

Function Fibonacci_recursion_L (Byval n As Uinteger) As longint
  Function = Fibonacci_recursion_2( 0, 1, n)
End Function

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

#Include "UDT_dynamic_queue_stack.bi"
UDT_dynamic_queue_stack(Uinteger)
Dim Shared S As UDT_dynamic_queue_stack_Uinteger

Function Fibonacci_iteration_stack_L (Byval n As Uinteger) As Longint
  Dim cumul As Longint = 0
  Dim an As Uinteger
  Dim bn As Uinteger
  Dim ns As Uinteger
  S.stack_push(0)
  S.stack_push(1)
  S.stack_push(n)
  Do While S.size > 0
    ns = S.stack_pull
    bn = S.stack_pull
    an = S.stack_pull
    If ns <= 1 then
      cumul = cumul + bn * ns
    Else
      S.stack_push(bn)
      S.stack_push(an + bn)
      S.stack_push(ns - 1)
    End If
  Loop
  Return cumul
End Function

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

Function Fibonacci_iteration_classic (Byval n As Uinteger) As Longint
  Dim array(n) As Longint
  For I As Uinteger = 0 To n
    If I = 0 Or I = 1 Then
      array(I) = I
    Else
      array(I) = array(I - 1) + array(I - 2)
    End If
  Next I
  Return array(n)
End Function

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

Sub Display(Byval Fibonacci As Function (Byval n As Uinteger) As Longint, Byval n As Integer)
  For I As Uinteger = 0 To n
    If I Mod 8 = 0 Then
      Print
    End If
    Locate , 10 * (I Mod 8)
    Print Fibonacci(I);
  Next I
End Sub

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

'Screen 12
Print
Print " recursion";
Display(@Fibonacci_recursion_L, 39)
Print
Print
Print
Print " iteration with own stack";
Display(@Fibonacci_iteration_stack_L, 39)
Print
Print
Print
Print " iteration without stack";
Display(@Fibonacci_iteration_classic, 39)
Print
Sleep


[Edit]
Adding of the Fibonacci series recursion linearizing method to improve the execution time duration.

Return to “Tips and Tricks”

Who is online

Users browsing this forum: No registered users and 3 guests