Posted to tcl by kbk at Mon Nov 02 18:06:22 GMT 2009view raw

  1. namespace path {::tcl::mathop ::tcl::unsupported}
  2.  
  3. puts [apply {f {list apply $f $f}} {f {list apply $f $f}}]
  4.  
  5. # Lambda is defined as constructing an invocation of [apply]
  6.  
  7. interp alias {} lambda {} apply {args {list apply $args}}
  8.  
  9. # The I combinator simply returns its argument
  10.  
  11. interp alias {} I {} return -level 0
  12.  
  13. # The U combinator passes a function as an argument to itself.
  14.  
  15. proc U {f args} {tailcall {*}$f $f {*}$args}
  16.  
  17. # recursive factorial
  18.  
  19. puts [U [lambda {f x} {
  20. if {$x == 0} {
  21. I 1
  22. } else {
  23. * $x [U $f [- $x 1]]
  24. }
  25. }] 6]
  26.  
  27. # iterative factorial
  28.  
  29. puts [U [lambda {f x {y 1}} {
  30. if {$x == 0} {
  31. I $y
  32. } else {
  33. tailcall U $f [- $x 1] [* $y $x]
  34. }
  35. }] 6]
  36.  
  37. # fold a lambda!
  38.  
  39. puts [U [lambda {foldl base op list} {
  40. if {[llength $list] == 0} {
  41. I $base
  42. } else {
  43. tailcall U $foldl \
  44. [{*}$op $base [lindex $list 0]] \
  45. $op \
  46. [lrange $list 1 end]
  47. }
  48. }] \
  49. {0 1} \
  50. [lambda {p q} {
  51. list [+ [lindex $p 0] $q] \
  52. [* [lindex $p 1] $q]}] \
  53. {1 2 3 4 5}]
  54.  
  55. # fold - left associative
  56.  
  57. proc foldl {base op list} {
  58. if {[llength $list] == 0} {
  59. I $base
  60. } else {
  61. tailcall foldl [{*}$op $base [lindex $list 0]] $op [lrange $list 1 end]
  62. }
  63. }
  64. puts [foldl 0 + {1 2 3 4 5}]
  65. puts [foldl 0 [lambda {x y} {+ $x $y}] {1 2 3 4 5}]
  66.  
  67. proc fact3 {n c} {
  68. if {$n == 0} {
  69. {*}$c 1
  70. } else {
  71. tailcall fact3 [- $n 1] \
  72. [list apply {{n c f} {
  73. puts [list continuation $c will get the product of $n and $f]
  74. {*}$c [* $n $f]
  75. }} $n $c]
  76. }
  77. }
  78. fact3 6 puts