Posted to tcl by kbk at Fri Jun 12 21:26:28 GMT 2009view pretty
# In this perverse implementation of the Fibonacci sequence, every function
# call is either a tailcall or an invocation of [list] to construct a closure.
# There is no direct recursion, instead, control is handled in continuation
# passing style. Note the strange use of [lindexc] to implement a conditional.
namespace path ::tcl::mathop
proc TRACE {} {
puts [format %*s%s [info level] {} [info level [- [info level] 1]]]
}
proc TRACE args {}
proc fib {n {c {{x} {set x}}}} { # apply c to nth element of fibonacci seq
TRACE
tailcall <c $n 2 [list [list nlt2 [list n $n] [list c $c]] {
fib0 $nlt2 $n $c
}]
}
proc fib0 {nlt2 n c} { # apply c to nth element of fibonacci seq, nlt2 is (n < 2)
TRACE
tailcall lindexc {fib1 apply} $nlt2 [list [list f [list n $n] [list c $c]] {
tailcall $f $c $n
}]
}
proc fib1 {c n} { # apply c to nth element of fibonacci sequence (n >= 2)
TRACE
tailcall -c $n 1 [list [list nm1 [list n $n] [list c $c]] {
tailcall fib2 $nm1 $n $c
}]
}
proc fib2 {nm1 n c} { # apply c to nth element of fibonacci sequence
# n-1 has been completed and placed in $nm1
TRACE
tailcall -c $n 2 [list [list nm2 [list nm1 $nm1] [list c $c]] {
tailcall fib3 $nm1 $nm2 $c
}]
}
proc fib3 {nm1 nm2 c} { # apply c to nth element of Fibonacci sequence.
# n-1 and n-2 have been computed and placed in nm1
# and nm2
TRACE
tailcall fib $nm1 [list [list fibnm1 [list nm2 $nm2] [list c $c]] {
tailcall fib4 $fibnm1 $nm2 $c
}]
}
proc fib4 {fibnm1 nm2 c} { # apply c to nth element of Fibonacci sequence.
# (n-1)st element is known.
TRACE
tailcall fib $nm2 [list [list fibnm2 [list fibnm1 $fibnm1] [list c $c]] {
tailcall +c $fibnm1 $fibnm2 $c
}]
}
proc lindexc {lst idx c} { # apply c to [lindex $lst $idx]
TRACE
tailcall apply $c [lindex $lst $idx]
}
proc <c {x y c} { # apply c to the result of x<y
TRACE
tailcall apply $c [< $x $y]
}
proc +c {x y c} { # apply c to the sum of x and y
TRACE
tailcall apply $c [+ $x $y]
}
proc -c {x y c} { # apply c to the difference of x and y
TRACE
tailcall apply $c [- $x $y]
}
for {set i 0} {$i <= 10} {incr i} {
puts [fib $i]
}