[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