### 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