Backus FP paper

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