if {0} {
     set a [lambda {a b} { expr {$a + $b} }]
     $a 1 2
     a 1 2 ;# ambiguous command name "a"...
 }

 # funtcl --
 #
 #   Morphs the current interpreter into one based on functional programming
 #   ideas. Does a number of things:
 #   - Unifies command and variable namespaces (optional)
 #   - Defines a [lambda] command for defining first-class function values
 #   - Redefines [proc] in terms of lambda
 #   - Supplies some common higher-order functions
 #

 package provide funtcl 0.2

 namespace eval funtcl {
     namespace export lambda map filter foldl foldr compose fix curry
     #namespace export proc
 }
 # First up - create the lambda command
 interp alias {} ::funtcl::lambda {} list ::funtcl::apply
 interp alias {} ::funtcl::curry {} list

 # Apply - used for the lambda. This and the next proc go to rather absurd
 # lengths to make this work just like a proc - no variables are visible to the
 # body of the lambda other than those which are defined by argument passing,
 # and any which are retreived through global/upvar etc. The lambda always
 # executes in the funtcl namespace though...
 proc funtcl::apply {arglist body args} {
     # This bit of magic ensures that only args defined in the arglist actually
     # get defined (as far as the body is concerned).
     ApplyArgs [K $body [unset body]] \
         [K $arglist [unset arglist]] [K $args [unset args]]
 }

 # Sets up variables in the callers scope according to the argument spec given,
 # and the actual arguments passed. This should behave exactly like Tcl's
 # argument passing to procedures.
 proc funtcl::ApplyArgs {body argspec arglist} {
     set index 0
     array set ret {}
     foreach item $argspec {
         if {$index < [llength $arglist]} {
             if {[lindex $item 0] eq "args" &&
                 $index == ([llength $argspec]-1)} {
                 # Deal with remaining args
                 set ret(args) [lrange $arglist $index end]
                 set index [llength $arglist]
             } else {
                 set ret([lindex $item 0]) [lindex $arglist $index]
             }
         } elseif {[llength $item] == 2} {
             set ret([lindex $item 0]) [lindex $item 1]
         } else {
             # Possibly not enough args
             if {$item eq "args" && $index == ([llength $argspec]-1)} {
                 # ok
                 set ret(args) [list]
             } else {
                 # Build up a good error message
                 set err "wrong # args: should be \""
                 # Grab how we were invoked from [info level]
                 set cmdname [lindex [info level -1] 0]
                 append err $cmdname
                 foreach item $argspec {
                     if {[llength $item] == 1} {
                         append err " $item"
                     } else {
                         append err " ?${item}?"
                     }
                 }
                 append err "\""
                 error $err
             }
         }
         incr index
     }
     # Any left over?
     if {$index < [llength $arglist]} {
         if {[lindex $argspec end 0] eq "args"} {
             for {set i $index} {$i < [llength $arglist]} {incr i} {
                 lappend ret(args) [lindex $arglist $i]
             }
         } else {
             error "too many args to lambda"
         }
     }
     # Add these all to caller's scope
     foreach {name value} [array get ret] {
         upvar 1 $name n
         set n $value
     }
     # Finally, uplevel the body
     uplevel 1 $body
 }

 # "Fix" a lambda to a proc. Also works with curried commands.
 proc funtcl::fix {name lambda} {
     uplevel 1 [list interp alias {} $name {} $lambda]
 }

 # Redefine proc in terms of set and lambda
 proc funtcl::proc {name arglist body} {
     uplevel 1 [list set $name [lambda $arglist $body]]
 }

 # Maps a function to each element of a list, and returns a list of the
 # results.
 proc funtcl::map {func list} {
     set ret [list]
     foreach item $list {
         lappend ret [eval $func [list $item]]
     }
     return $ret
 }

 # Filters a list, returning only those items which pass the filter.
 proc funtcl::filter {func list} {
     set ret [list]
     foreach item $list {
         if {[eval $func [list $item]]} {
             lappend ret $item
         }
     }
     return $ret
 }

 # Useful higher-order functions which replace common uses of recursion
 # foldl (fold left)
 # foldl - 0 {1 2 3} -> ((0-1)-2)-3
 proc funtcl::foldl {func default list} {
     set res $default
     foreach item $list {
         set res [eval $func [list $res $item]]
     }
     return $res
 }

 # foldr (fold right)
 # foldr + 0 {1 2 3} -> 1+(2+(3+0))
 proc funtcl::foldr {func default list} {
     set tot $default
     # Go in reverse
     for {set i [llength $list]} {$i > 0} {incr i -1} {
         set tot [eval $func [list [lindex $list [expr {$i-1}]] $tot]]
     }
     return $tot
 }

 # compose - compose two functions together
 # [compose f g] $args -> f [g $args]
 proc funtcl::compose {f g} {
     return [lambda {args} "$f \[eval [list $g] \$args\]"]
 }
 # The K combinator - obscure, but very useful.
 proc funtcl::K {a b} { set a }

 # The unknown handler which makes the magic work...
 proc funtcl::unknown {cmd args} {
     # Uncomment these lines to unify command/var namespaces
     #if {![catch {uplevel 1 set $cmd} val]} {
     #    # It's a varname in callers scope - deref and try again
     #    uplevel 1 [list $val] $args
     #} elseif {![catch {uplevel #0 set $cmd} val]} {
     #    # Varname at global scope
     #    uplevel 1 [list $val] $args
     #} elseif {[llength $cmd] > 1}
     if {[llength $cmd] > 1} {
         # Try to expand and try again
         uplevel 1 $cmd $args
     } else {
         # Call Tcl's usual unknown handler
         uplevel 1 [list funtcl::orig_unknown $cmd] $args
     }
 }

 # Save the original unknown command for later use
 catch {
     rename ::unknown funtcl::orig_unknown
     # Alias it to our version...
     interp alias {} ::unknown {} ::funtcl::unknown
 }

 % package require funtcl
 0.1
 % namespace import -force funtcl::*
 % set + [lambda {a b} { expr {$a + $b} }]
 ::funtcl::apply {a b} { expr {$a + $b} }
 % # Use the foldr function to make a sum command
 % set sum [curry foldr + 0]
 foldr + 0
 % sum {1 2 3}
 6
 % # Use compose, to create a command which sums a sorted list (!)
 % set sum_sorted [compose sum lsort]
 ::funtcl::apply args {sum [eval [list lsort] $args]}
 % sum_sorted {3 4 1}
 8
 % # Demonstrate how [proc] is now defined in terms of lambda
 % proc foo {} { puts "Hello, World!" }
 ::functcl::apply {} { puts "Hello, World!" }

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References