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