KBK - After burning myself on hot curry, I started wasting entirely too much time on an engine that builds up recursive function theory from a minimalist set of primitives.
# In order to keep my sanity, I found myself needing to trace what the engine did, so my source file begins with
set tracemax 10000
set tracen 0
proc trace args {
global tracen tracemax
if { [incr tracen] > $tracemax } exit
puts [format %*s%s [info level] {} $args]
}
proc trace args {}# The fundamental problem with hot curry is that eager evaluation gets in the way of searching for fixed points. Hence we do our own lazy evaluator. The evaluator can be extremely simple, since every function that it recognizes has a single argument!
proc lazyEval args {
# if we've got a list as the first arg, flatten it.
set f [lindex $args 0]
while { 1 } {
trace evaluating $args
if { [llength $f] > 1 || [string match {{*}} $f] } {
trace expanding $f
set args [eval [list lreplace $args 0 0] $f]
set f [lindex $args 0]
} elseif { [llength $args] > 1 } {
set f [lindex $args 0]
set g [lindex $args 1]
trace applying $f to $g
set result [$f $g]
trace replacing $f $g -> $result
set args [eval [list lreplace $args 0 1] $result]
set f [lindex $args 0]
} else {
break
}
}
# return the single arg
trace result $args
return $args
}# It's convenient to have anonymous lambdas. Alas, there isn't any graceful way to implement lambda in Tcl. Here's a hack that leaks memory.
variable lambdaIndex 0
proc lambda { x y } {
variable lambdaIndex
variable lambdaCache
set key [list $x $y]
if { ! [info exists lambdaCache($key)] } {
set pname lambda[incr lambdaIndex]
set lambdaCache($key) $pname
proc $pname $x $y
}
return $lambdaCache($key)
}# We curry the K and S combinators by hand. Note that some special handling is needed because the arguments are unevaluated - we are doing lazy evaluation, after all!
# K x y = x
proc K x { lambda y "lazyEval $x" }# S f g x = f x (g x)
proc S f { lambda g "[list S2 $f] \$g" }
proc S2 { f g } { lambda x "[list S3 $f $g] \$x" }
proc S3 { f g x } {
trace evaluating curried S $f $g $x
set toEval [list lazyEval $f $x [list $g $x]]
set result [eval $toEval]
trace returning $result
return $result
}# Now, if we've done everything right, we should see that S K K is the identity operation.
puts [lazyEval S K K this-should-pass-unchanged] # -> prints this-should-pass-through-unchanged
# Let's define lazy, curried, versions of the four arithmetic operators.
proc + x { lambda y "[list ++ $x] \$y" }
proc ++ { x y } {
trace evaluating + $x $y
set realX [uplevel 1 [list lazyEval $x]]
set realY [uplevel 1 [list lazyEval $y]]
set result [expr { $realX + $realY }]
trace returning $result
return $result
}
proc - x { lambda y "[list -- $x] \$y" }
proc -- { x y } {
trace evaluating - $x $y
set realX [uplevel 1 [list lazyEval $x]]
set realY [uplevel 1 [list lazyEval $y]]
set result [expr { $realX - $realY }]
trace returning $result
return $result
}
proc * x { lambda y "[list ** $x] \$y" }
proc ** { x y } {
trace evaluating * $x $y
set realX [uplevel 1 [list lazyEval $x]]
set realY [uplevel 1 [list lazyEval $y]]
set result [expr { $realX * $realY }]
trace returning $result
return $result
}
proc / x { lambda y "[list // $x] \$y" }
proc // { x y } {
trace evaluating / $x $y
set realX [uplevel 1 [list lazyEval $x]]
set realY [uplevel 1 [list lazyEval $y]]
set result [expr { $realX / $realY }]
trace returning $result
return $result
}
puts [lazyEval + 6 2]
puts [lazyEval - 6 2]
puts [lazyEval * 6 2]
puts [lazyEval / 6 2]
# print 8, 4, 12, and 3 respectively# We want to be able to define new combinators. The define procedure is a little bit of syntactic sugar around [interp alias]:
proc define {key args} {
trace [list interp alias {} $key {} lazyEval] $args
eval [list interp alias {} $key {} lazyEval] $args
}# OK, now we have enough in hand to define some of the basic combinators.
# The identity function, I x == x
define I S K K puts [lazyEval I this-should-pass-through-unchanged] # prints this-should-pass-through-unchanged
# The composition operator B f g x = f (g x)
define B S {K S} K
puts [lazyEval B {+ 1} {* 2} 3]
# prints 7# The alternative curry C f x y = f y x
define C S {B B S} {K K}
puts [lazyEval C - 5 8]
# prints 3# Apply a function to a constant T x f = f x
define T C I
puts [lazyEval T 3 {- 10}]
# prints 7# Duplicate an argument to a function W f x = f x x
define W C S I puts [lazyEval W * 6] # prints 36
# While it isn't strictly necessary, it's helpful to have a compiler to abstract free variables from expressions. The basic translations are: # * abstract (f g) x => S (abstract f x) (abstract g x) # * abstract a x ==> K a # * abstract x x ==> I # We also apply a couple of minor optimizations: # * S (K a) I ==> a # * S (K a) (K b) ==> (a b)
proc abstract { f x } {
trace abstracting $x from $f
set retval [if { [llength $f] > 1 } {
Opt [list S \
[abstract [lrange $f 0 end-1] $x] \
[abstract [lindex $f end] $x]]
} elseif { [string equal $f $x] } {
list I
} else {
list K $f
}]
trace returning $retval
return $retval
}
proc Opt x {
trace optimizing $x
set f [lindex $x 0]
while { [llength $f] > 1 || [string match {{*}} $f] } {
trace rewriting initial function $f
set x [eval [list lreplace $x 0 0] $f]
trace rewritten $x
set f [lindex $x 0]
}
if { [string equal $f S] } {
if { [llength $x] >= 3 } {
foreach { f a b } $x break
if { [llength $a] == 2
&& [string equal [lindex $a 0] K] } {
if { [string equal $b I] } {
trace rewriting as [lreplace $x 0 2 [lindex $a 1]]
return [lreplace $x 0 2 [lindex $a 1]]
} elseif { [llength $b] == 2
&& [string equal [lindex $b 0] K] } {
set r [list K [list [lindex $a 1] [lindex $b 1]]]
trace rewriting as $r
return $r
}
}
}
}
trace returning $x
return $x
}# Our functions dispense with the [if] statement; instead, a Boolean value is a combinator with two arguments. true evaluates its first argument and discards the second; false discards the first and evaluates the second.
define true K
define false K {S K K}
proc zero? n {
trace evaluating [info level 0]
set realN [uplevel 1 lazyEval $n]
if { $realN == 0 } {
set result true
} else {
set result false
}
trace returning $result
return $result
}# We can test this out quickly:
puts [lazyEval zero? 0 it-is-zero it-isn't-zero] # prints it-is-zero puts [lazyEval zero? 1 it-is-zero it-isn't-zero] # prints it-isn't-zero
# OK, now things can get interesting. Let's define Turing's fixed point combinator Y. The Y combinator searches for a fixed point of a function f, that is, a value of x such that x = f x.
define A B {S I} {S I I}
define Y A A# How does this work?
# Y f = A A f # = B (S I) (S I I) A F # = (S I) ((S I I) A) f # = (S I) (S I I A) f # = (S I) (I A (I A)) f # = S I (A A) f # = I f ((A A) f) # = f (A A f) # = f (Y f)
# Who cares? Well, let's come up with a traditional recursive definition for factorial: f(n) = (zero? n 1 (* n (f (- n 1)))). In other words, "if n is zero, return 1, otherwise return n*f(n-1)." Make this function accept a second parameter, which is expected to be the function itself.
set f1 [abstract [abstract { zero? n 1 { * n { f { - n 1 } } } } n] f]
puts [list f1 = $f1]
# prints a long expression with many S's and K's.
set fact1 [linsert $f1 0 define fact1]
eval $fact1# Now, let's see what evaluating Y fact1 2 does:
# Y fact1 2 = fact1 (Y fact1) 2 # = (* 2 (fact1 (Y fact1) 1)) # = (* 2 (* 1 (fact1 (Y fact1) 0))) # = (* 2 (* 1 1))
# Wow, recursion without explicit function names! Let's test it out
define factorial Y fact1 puts [lazyEval factorial 5] # prints 120