Posted to tcl by patthoyts at Fri Jun 12 13:30:31 GMT 2009view raw

  1. # Recursive functions are a bad thing if there is a lot of recursion
  2. # to be done. Tail recursion is the way to speed up recursion and can
  3. # sometimes express things more simply than iterative approaches while
  4. # still being as fast as iteration.
  5. #
  6. # For instance the following 3 versions of the fibonacci function use
  7. # iterative, recursive or tail-recursive approaches. Lets see:
  8. #
  9. # C:\opt\tcl\src>tclkitsh86 fibonacci.tcl -estimate 100
  10. # 354224848179263111168 32.6
  11. #
  12. # C:\opt\tcl\src>tclkitsh86 fibonacci.tcl -iterative 100
  13. # 354224848179261915075 153.0
  14. #
  15. # C:\opt\tcl\src>tclkitsh86 fibonacci.tcl -tailcall 100
  16. # 354224848179261915075 550.0
  17. #
  18. # C:\opt\tcl\src>tclkitsh86 fibonacci.tcl -memoized 100
  19. # 354224848179261915075 955.2
  20. #
  21. # NOTE that I didn't dare to try -rec 100 as it is too slow and will run out
  22. # of stack for n=100.
  23.  
  24. # Tail-recursive
  25. proc fibT {n} {
  26. proc fib' {a b n} {
  27. if {$n < 1} {
  28. return $a
  29. } elseif {$n == 1} {
  30. return $b
  31. } else {
  32. tailcall fib' $b [expr {$a + $b}] [expr {$n - 1}]
  33. }
  34. }
  35. return [fib' 0 1 $n]
  36. }
  37.  
  38. # Fully recursive
  39. proc fibR {n} {
  40. if {$n < 3} then {
  41. expr 1
  42. } else {
  43. expr {[fibR [expr {$n-1}]]+[fibR [expr {$n-2}]]}
  44. }
  45. }
  46.  
  47. # Iterative
  48. proc fibI n {
  49. if {$n < 2} {return $n}
  50. set prev 1
  51. set fib 1
  52. for {set i 2} {$i < $n} {incr i} {
  53. lassign [list $fib [incr fib $prev]] prev fib
  54. }
  55. return $fib
  56. }
  57.  
  58. # Estimated version - good up to about 70
  59. proc fibE {n} {expr {round((.5 + .5*sqrt(5)) ** $n / sqrt(5))}}
  60.  
  61. # Memoized - ie: cache the calculated numbers
  62. # RS version...
  63. proc memoize {} {
  64. global memo
  65. set cmd [info level -1]
  66. if {[info level] > 2 && [lindex [info level -2] 0] eq "memoize"} return
  67. if { ! [info exists memo($cmd)]} {set memo($cmd) [eval $cmd]}
  68. return -code return $memo($cmd)
  69. }
  70. proc fibM {n} {
  71. memoize
  72. expr {$n < 3 ? 1 : [fibM [expr {$n - 1}]] + [fibM [expr {$n - 2}]]}
  73. }
  74.  
  75. # Now NEM's version ...
  76. proc xmemoize f {
  77. variable $f [dict create]
  78. rename $f _cache_$f
  79. interp alias {} $f {} xremember $f
  80. }
  81. proc xremember {f args} {
  82. upvar #0 $f cache
  83. if {![dict exists $cache $args]} {
  84. dict set cache $args [uplevel 1 [linsert $args 0 _cache_$f]]
  85. }
  86. dict get $cache $args
  87. }
  88. proc func {name params body} { proc $name $params [list expr $body] }
  89. func fibN n {
  90. $n < 2 ? $n
  91. : [fibN [expr {$n-1}]] +
  92. [fibN [expr {$n-2}]]
  93. }
  94. xmemoize fibN
  95.  
  96.  
  97. if {!$tcl_interactive} {
  98. set cmd fibT
  99. if {[llength $argv] > 1} {
  100. switch -glob -- [lindex $argv 0] {
  101. "-t*" { set cmd fibT }
  102. "-i*" { set cmd fibI }
  103. "-r*" { set cmd fibR }
  104. "-e*" { set cmd fibE }
  105. "-m*" { set cmd fibM }
  106. "-n*" { set cmd fibN }
  107. default {
  108. puts "usage: fib ?-tail-recursive? ?-estimated?\
  109. ?-iterative? ?-recursive? ?-memoized? number"
  110. }
  111. }
  112. set argv [lrange $argv 1 end]
  113. }
  114. set t [time {set r [catch [linsert $argv 0 $cmd] err]} 5]
  115. if {$r} {puts $errorInfo} else {puts "$err [lindex $t 0]"}
  116. exit $r
  117. }