Posted to tcl by mjanssen at Fri Sep 18 14:31:47 GMT 2009view raw
- # FP (http://www.stanford.edu/class/cs242/readings/backus.pdf)[1]
- # Note that is very easy to add a FP framework in Tcl (it would even be
- easier if
- # leading words were autoexpanded
- # define $name which will be $expanded to body
- # would be unnecessary if leading words were expanded
- proc Def {name body} {
- proc $name x "{*}$body \$x"
- }
- # print x
- proc print {options x} {
- puts {*}$options $x
- return $x
- }
- # the Backus paper defines integers a objects.
- # Change unknown to provide this
- catch {interp hide {} unknown}
- proc unknown args {
- set first [lindex $args 0]
- if {[string is integer $first]} {
- return $first
- } else {
- interp invokehidden {} unknown {*}$args
- }
- }
- # primitives functions
- # bottom
- proc bottom {cause} {
- return -code error -level 1 $cause
- }
- # selector, counting starts a 1
- proc @ {idx x} {
- lindex $x $idx-1
- }
- # tail
- proc tl {x} {
- lrange $x 1 end
- }
- # identity
- proc id {x} {
- set x
- }
- # equality
- proc eq {x} {
- if {[llength $x] != 2} {
- bottom "eq requires two element sequence"
- }
- set y [lindex $x 0]
- set z [lindex $x 1]
- expr {$y == $z}
- }
- # comparison
- proc < {x} {
- if {[llength $x] != 2} {
- bottom "eq requires two element sequence"
- }
- set y [lindex $x 0]
- set z [lindex $x 1]
- expr {$y < $z}
- }
- proc < {x} {
- if {[llength $x] != 2} {
- bottom "eq requires two element sequence"
- }
- set y [lindex $x 0]
- set z [lindex $x 1]
- expr {$y < $z}
- }
- # distribute x(1) to the left of the elements of x(2)
- proc distl {x} {
- set res {}
- set y [lindex $x 0]
- set zs [lindex $x 1]
- foreach z $zs {
- lappend res [list $y $z]
- }
- return $res
- }
- # distribute x(2) to the right of the elements of x(1)
- proc distr {x} {
- set res {}
- set z [lindex $x 1]
- set ys [lindex $x 0]
- foreach y $ys {
- lappend res [list $y $z]
- }
- return $res
- }
- # length of x
- proc length {x} {
- return [llength $x]
- }
- # math ops
- proc + {x} {
- if {[llength $x] != 2} {
- bottom "+ requires two element sequence"
- }
- set y [lindex $x 0]
- set z [lindex $x 1]
- expr {$y + $z}
- }
- proc * {x} {
- if {[llength $x] != 2} {
- bottom "* requires two element sequence"
- }
- set y [lindex $x 0]
- set z [lindex $x 1]
- expr {$y * $z}
- }
- proc - {x} {
- if {[llength $x] != 2} {
- bottom "- requires two element sequence"
- }
- set y [lindex $x 0]
- set z [lindex $x 1]
- expr {$y - $z}
- }
- proc / {x} {
- if {[llength $x] != 2} {
- bottom "/ requires two element sequence"
- }
- set y [lindex $x 0]
- set z [lindex $x 1]
- expr {$y / $z}
- }
- proc apndl {x} {
- set y [lindex $x 0]
- set z [lindex $x 1]
- list $z {*}$y
- }
- proc apndr {x} {
- set y [lindex $x 0]
- set z [lindex $x 1]
- list {*}$y $z
- }
- # transpose a matrix (a sequence of sequences)
- proc iota n {
- set res {}
- for {set i 0} {$i<$n} {incr i} {lappend res $i}
- set res
- }
- proc trans {x} {
- set cols [iota [llength [lindex $x 0]]]
- foreach row $x {
- foreach element $row col $cols {
- lappend $col $element
- }
- }
- set res {}
- foreach col $cols {lappend res [set $col]}
- set res
- }
- # functionals
- # composition
- proc o {args} {
- set x [lindex $args end]
- set funcs [lrange $args 0 end-1]
- set res $x
- foreach f [lreverse $funcs] {
- set res [{*}$f $res]
- }
- return $res
- }
- # construction
- proc {,} {args} {
- set x [lindex $args end]
- set funcs [lrange $args 0 end-1]
- set res {}
- foreach f $funcs {
- lappend res [{*}$f $x]
- }
- return $res
- }
- # insert (aka foldl)
- proc insert {f x} {
- set res {}
- if {[llength $x]==1 } {
- set res $x
- } {
- set res [$f [list [hd $x] [insert $f [tl $x]]]]
- }
- return $res
- }
- # apply to all (aka map)
- proc a {f x} {
- set res {}
- foreach el $x {
- lappend res [{*}$f $el]
- }
- return $res
- }
- # binary to unary
- proc bu {f x y} {
- {*}$f [list $x $y]
- }
- # conditional execution of $f or $g based on $p:$x
- proc cond {p f g x} {
- if {[{*}$p $x]} {
- set res [{*}$f $x]
- } else {
- set res [{*}$g $x]
- }
- return $res
- }
- # additional functionals not defined in [1]
- # apply (:) is not available in FP because functions are not objects
- # we have EIAS so we can add it
- proc : {x} {
- set f [lindex $x 0]
- set x [lindex $x 1]
- {*}$f $x
- }
- catch {interp hide {} split}
- proc split {c x} {
- interp invokehidden {} split $x $c
- }
- #####################################################################
- # examples
- Def Display {print {}}
- Def DisplayElements {a Display}
- Def ex {o Display :}
- Def hd {@ 1}
- # innerproduct
- Def IP {o {insert +} {a *} {trans}}
- ex {IP {{1 2 3} {6 5 4}}}
- # factorial
- Def sub1 {o - {, id 1}}
- Def eq0 {o eq {, id 0}}
- Def fact {cond eq0 1 {o * {, id {o fact sub1}}}}
- ex {fact 12}
- # mean
- Def mean {o / {, {insert +} length}}
- ex {mean {1 2 3 4}}
- ex {mean {1. 2 3 4}}
- # contrast to http://wiki.tcl.tk/13125
- proc double x {expr {double($x)}}
- Def sum {insert +}
- Def mean {o / {, sum {o double length}}}
- ex {mean {1 2 3 4}}
- # matrix multiplication
- Def aaIP {a {a IP}}
- Def MM {o aaIP {a distl} distr {, {@ 1} {o trans {@ 2}}}}
- ex {MM {{{1 2} {3 4}} {{5 6} {7 8}}}}
- # some stuff from the language shootout
- # Ackerman function
- Def m {@ 1}
- Def n {@ 2}
- Def m-1 {o sub1 m}
- Def n-1 {o sub1 n}
- Def m==0 {o eq0 m}
- Def n==0 {o eq0 n}
- Def n+1 {o + {, n 1}}
- Def Ack {cond {m==0} n+1 { cond {n==0} { o Ack {, m-1 1}} {o Ack {, m-1 {o
- Ack {, m n-1}}}}}}
- ex {Ack {3 3}}
- # Fibonacci number
- Def <2 {o < {, id 2}}
- Def -2 {o - {, id 2}}
- Def -1 {o - {, id 1}}
- Def Fib {cond <2 1 {o + {, {o Fib -2} {o Fib -1}}}}
- ex {Fib 16}
- # Tak function
- Def x {@ 1}
- Def y {@ 2}
- Def z {@ 3}
- Def y<x {o < {, y x}}
- Def x-1 {o sub1 x}
- Def y-1 {o sub1 y}
- Def z-1 {o sub1 z}
- Def Tak1 {o Tak {, x-1 y z}}
- Def Tak2 {o Tak {, y-1 z x}}
- Def Tak3 {o Tak {, z-1 x y}}
- Def Tak {cond y<x {o Tak {, Tak1 Tak2 Tak3}} z}
- ex {Tak {3 2 1}}
- Def DisplayShoutout {o Display {, {@ 1} {o : tl}}}
- Def Bench {o {print -nonewline} : {, time id}}
- Bench {
- DisplayShoutout {Ack(3,3): Ack {3 3}}
- # disabled because takes ages (2 minutes on my system)
- # DisplayShoutout {Fib(30.0): Fib 30.0}
- DisplayShoutout {Tak(6,4,2): Tak {6 4 2}}
- DisplayShoutout {Fib(3): Fib 3}
- DisplayShoutout {Tak(3.0,2.0,1.0): Tak {3.0 2.0 1.0}}
- }
- Display { microseconds per iteration}
- # read a file
- Def readfile {o {split \n} {@ 1} {, read close} open}
- Def displayfile {o DisplayElements readfile}
- displayfile c:/boot.ini
- # append two lists
- Def ynil {o eq0 {o length {@ 2}}}
- Def y {@ 2}
- Def hy {o hd y}
- Def ty {o tl y}
- Def ahead {o apndr {, x {o hd y}}}
- Def append {cond ynil x {o append {, ahead ty}}}
- ex {append {{1 2 3} {4 5 6}}}
- set a {}