Posted to tcl by mjanssen at Fri Sep 18 14:31:47 GMT 2009view raw

  1. # FP (http://www.stanford.edu/class/cs242/readings/backus.pdf)[1]
  2. # Note that is very easy to add a FP framework in Tcl (it would even be
  3. easier if
  4. # leading words were autoexpanded
  5.  
  6. # define $name which will be $expanded to body
  7. # would be unnecessary if leading words were expanded
  8. proc Def {name body} {
  9. proc $name x "{*}$body \$x"
  10. }
  11.  
  12. # print x
  13. proc print {options x} {
  14. puts {*}$options $x
  15. return $x
  16. }
  17.  
  18. # the Backus paper defines integers a objects.
  19. # Change unknown to provide this
  20. catch {interp hide {} unknown}
  21. proc unknown args {
  22. set first [lindex $args 0]
  23. if {[string is integer $first]} {
  24. return $first
  25. } else {
  26. interp invokehidden {} unknown {*}$args
  27. }
  28. }
  29.  
  30. # primitives functions
  31.  
  32. # bottom
  33. proc bottom {cause} {
  34. return -code error -level 1 $cause
  35. }
  36.  
  37. # selector, counting starts a 1
  38. proc @ {idx x} {
  39. lindex $x $idx-1
  40. }
  41.  
  42. # tail
  43. proc tl {x} {
  44. lrange $x 1 end
  45. }
  46.  
  47. # identity
  48. proc id {x} {
  49. set x
  50. }
  51.  
  52. # equality
  53. proc eq {x} {
  54. if {[llength $x] != 2} {
  55. bottom "eq requires two element sequence"
  56. }
  57. set y [lindex $x 0]
  58. set z [lindex $x 1]
  59. expr {$y == $z}
  60. }
  61.  
  62. # comparison
  63. proc < {x} {
  64. if {[llength $x] != 2} {
  65. bottom "eq requires two element sequence"
  66. }
  67. set y [lindex $x 0]
  68. set z [lindex $x 1]
  69. expr {$y < $z}
  70. }
  71.  
  72.  
  73. proc < {x} {
  74. if {[llength $x] != 2} {
  75. bottom "eq requires two element sequence"
  76. }
  77. set y [lindex $x 0]
  78. set z [lindex $x 1]
  79. expr {$y < $z}
  80. }
  81.  
  82. # distribute x(1) to the left of the elements of x(2)
  83. proc distl {x} {
  84. set res {}
  85. set y [lindex $x 0]
  86. set zs [lindex $x 1]
  87. foreach z $zs {
  88. lappend res [list $y $z]
  89. }
  90. return $res
  91. }
  92.  
  93. # distribute x(2) to the right of the elements of x(1)
  94. proc distr {x} {
  95. set res {}
  96. set z [lindex $x 1]
  97. set ys [lindex $x 0]
  98. foreach y $ys {
  99. lappend res [list $y $z]
  100. }
  101. return $res
  102. }
  103.  
  104. # length of x
  105. proc length {x} {
  106. return [llength $x]
  107. }
  108.  
  109. # math ops
  110. proc + {x} {
  111. if {[llength $x] != 2} {
  112. bottom "+ requires two element sequence"
  113. }
  114. set y [lindex $x 0]
  115. set z [lindex $x 1]
  116. expr {$y + $z}
  117. }
  118.  
  119. proc * {x} {
  120. if {[llength $x] != 2} {
  121. bottom "* requires two element sequence"
  122. }
  123. set y [lindex $x 0]
  124. set z [lindex $x 1]
  125. expr {$y * $z}
  126. }
  127.  
  128. proc - {x} {
  129. if {[llength $x] != 2} {
  130. bottom "- requires two element sequence"
  131. }
  132. set y [lindex $x 0]
  133. set z [lindex $x 1]
  134. expr {$y - $z}
  135. }
  136.  
  137. proc / {x} {
  138. if {[llength $x] != 2} {
  139. bottom "/ requires two element sequence"
  140. }
  141. set y [lindex $x 0]
  142. set z [lindex $x 1]
  143. expr {$y / $z}
  144. }
  145.  
  146. proc apndl {x} {
  147. set y [lindex $x 0]
  148. set z [lindex $x 1]
  149. list $z {*}$y
  150. }
  151.  
  152. proc apndr {x} {
  153. set y [lindex $x 0]
  154. set z [lindex $x 1]
  155. list {*}$y $z
  156. }
  157.  
  158. # transpose a matrix (a sequence of sequences)
  159. proc iota n {
  160. set res {}
  161. for {set i 0} {$i<$n} {incr i} {lappend res $i}
  162. set res
  163. }
  164.  
  165. proc trans {x} {
  166. set cols [iota [llength [lindex $x 0]]]
  167. foreach row $x {
  168. foreach element $row col $cols {
  169. lappend $col $element
  170. }
  171. }
  172. set res {}
  173. foreach col $cols {lappend res [set $col]}
  174. set res
  175.  
  176. }
  177.  
  178.  
  179. # functionals
  180.  
  181. # composition
  182. proc o {args} {
  183. set x [lindex $args end]
  184. set funcs [lrange $args 0 end-1]
  185. set res $x
  186. foreach f [lreverse $funcs] {
  187. set res [{*}$f $res]
  188. }
  189. return $res
  190. }
  191.  
  192. # construction
  193. proc {,} {args} {
  194. set x [lindex $args end]
  195. set funcs [lrange $args 0 end-1]
  196. set res {}
  197. foreach f $funcs {
  198. lappend res [{*}$f $x]
  199. }
  200. return $res
  201. }
  202.  
  203. # insert (aka foldl)
  204. proc insert {f x} {
  205. set res {}
  206. if {[llength $x]==1 } {
  207. set res $x
  208. } {
  209. set res [$f [list [hd $x] [insert $f [tl $x]]]]
  210. }
  211. return $res
  212. }
  213.  
  214. # apply to all (aka map)
  215. proc a {f x} {
  216. set res {}
  217. foreach el $x {
  218. lappend res [{*}$f $el]
  219. }
  220. return $res
  221. }
  222.  
  223. # binary to unary
  224. proc bu {f x y} {
  225. {*}$f [list $x $y]
  226. }
  227.  
  228. # conditional execution of $f or $g based on $p:$x
  229. proc cond {p f g x} {
  230. if {[{*}$p $x]} {
  231. set res [{*}$f $x]
  232. } else {
  233. set res [{*}$g $x]
  234. }
  235. return $res
  236. }
  237.  
  238. # additional functionals not defined in [1]
  239.  
  240. # apply (:) is not available in FP because functions are not objects
  241. # we have EIAS so we can add it
  242. proc : {x} {
  243. set f [lindex $x 0]
  244. set x [lindex $x 1]
  245. {*}$f $x
  246. }
  247. catch {interp hide {} split}
  248.  
  249. proc split {c x} {
  250. interp invokehidden {} split $x $c
  251. }
  252.  
  253. #####################################################################
  254.  
  255. # examples
  256.  
  257. Def Display {print {}}
  258. Def DisplayElements {a Display}
  259.  
  260. Def ex {o Display :}
  261.  
  262. Def hd {@ 1}
  263.  
  264. # innerproduct
  265. Def IP {o {insert +} {a *} {trans}}
  266. ex {IP {{1 2 3} {6 5 4}}}
  267.  
  268. # factorial
  269. Def sub1 {o - {, id 1}}
  270. Def eq0 {o eq {, id 0}}
  271. Def fact {cond eq0 1 {o * {, id {o fact sub1}}}}
  272. ex {fact 12}
  273.  
  274. # mean
  275. Def mean {o / {, {insert +} length}}
  276. ex {mean {1 2 3 4}}
  277. ex {mean {1. 2 3 4}}
  278.  
  279. # contrast to http://wiki.tcl.tk/13125
  280. proc double x {expr {double($x)}}
  281. Def sum {insert +}
  282. Def mean {o / {, sum {o double length}}}
  283. ex {mean {1 2 3 4}}
  284.  
  285. # matrix multiplication
  286. Def aaIP {a {a IP}}
  287. Def MM {o aaIP {a distl} distr {, {@ 1} {o trans {@ 2}}}}
  288. ex {MM {{{1 2} {3 4}} {{5 6} {7 8}}}}
  289.  
  290. # some stuff from the language shootout
  291.  
  292. # Ackerman function
  293. Def m {@ 1}
  294. Def n {@ 2}
  295. Def m-1 {o sub1 m}
  296. Def n-1 {o sub1 n}
  297. Def m==0 {o eq0 m}
  298. Def n==0 {o eq0 n}
  299. Def n+1 {o + {, n 1}}
  300. Def Ack {cond {m==0} n+1 { cond {n==0} { o Ack {, m-1 1}} {o Ack {, m-1 {o
  301. Ack {, m n-1}}}}}}
  302. ex {Ack {3 3}}
  303.  
  304. # Fibonacci number
  305. Def <2 {o < {, id 2}}
  306. Def -2 {o - {, id 2}}
  307. Def -1 {o - {, id 1}}
  308. Def Fib {cond <2 1 {o + {, {o Fib -2} {o Fib -1}}}}
  309.  
  310. ex {Fib 16}
  311.  
  312. # Tak function
  313. Def x {@ 1}
  314. Def y {@ 2}
  315. Def z {@ 3}
  316. Def y<x {o < {, y x}}
  317. Def x-1 {o sub1 x}
  318. Def y-1 {o sub1 y}
  319. Def z-1 {o sub1 z}
  320. Def Tak1 {o Tak {, x-1 y z}}
  321. Def Tak2 {o Tak {, y-1 z x}}
  322. Def Tak3 {o Tak {, z-1 x y}}
  323.  
  324. Def Tak {cond y<x {o Tak {, Tak1 Tak2 Tak3}} z}
  325.  
  326. ex {Tak {3 2 1}}
  327.  
  328. Def DisplayShoutout {o Display {, {@ 1} {o : tl}}}
  329. Def Bench {o {print -nonewline} : {, time id}}
  330.  
  331. Bench {
  332. DisplayShoutout {Ack(3,3): Ack {3 3}}
  333. # disabled because takes ages (2 minutes on my system)
  334. # DisplayShoutout {Fib(30.0): Fib 30.0}
  335. DisplayShoutout {Tak(6,4,2): Tak {6 4 2}}
  336. DisplayShoutout {Fib(3): Fib 3}
  337. DisplayShoutout {Tak(3.0,2.0,1.0): Tak {3.0 2.0 1.0}}
  338. }
  339. Display { microseconds per iteration}
  340.  
  341. # read a file
  342. Def readfile {o {split \n} {@ 1} {, read close} open}
  343. Def displayfile {o DisplayElements readfile}
  344. displayfile c:/boot.ini
  345.  
  346. # append two lists
  347. Def ynil {o eq0 {o length {@ 2}}}
  348. Def y {@ 2}
  349. Def hy {o hd y}
  350. Def ty {o tl y}
  351. Def ahead {o apndr {, x {o hd y}}}
  352. Def append {cond ynil x {o append {, ahead ty}}}
  353. ex {append {{1 2 3} {4 5 6}}}
  354.  
  355. set a {}
  356.