• no if statement.
• no while loops. In fact, no control structures at all, except as shown below.
• no named variables.
• no named user functions (Well, we'll use named functions for shorthand, but they're solely string substitutions. They don't take arguments. We *could* just expand them recursively.)
• not even any arithmetic! (Well, hardly any, we cheat a little bit on input and output...)

S a b c = a c { b c }
K a b   = a

define I S K K

proc traceP args {
    foreach arg $args {
        puts [format %*s%s [info level] {} [uplevel 1 [list subst $arg]]]
    }
}
proc traceP args {}

proc lazyEval args {
    while { [llength $args] > 1 || [string match {{*}} $args] } {
        traceP {reducing $args}
        set nargs [eval [list lreplace $args 0 1] \
            [uplevel 1 [lrange $args 0 1]]]
        traceP {result is $nargs}
        if { [string equal $nargs $args] } break
        set args $nargs
    }
    return $args
}

proc curry { name arglist body } {
    interp alias {} $name {} _curry_impl $name [llength $arglist]
    proc ${name}_impl $arglist $body
    trace add command $name delete [list _curry_nuke $name]
}

proc _curry_impl { name len args } {
    set nArgs [llength $args]
    set L_1 [expr { $len - 1 }]
    if { $nArgs >= $len } {
        set toEval [linsert [lrange $args 0 $L_1] 0 ${name}_impl]
        set rest [lrange $args $len end]
        set result [eval $toEval]
        traceP {[linsert [lrange $args 0 $L_1] 0 $name] -> $result}
        set retval [eval [list linsert $rest 0] $result]
        return $retval
    } else {
        list [linsert $args 0 ${name}]
    }
}

proc _curry_nuke { name args } {
    catch {
        rename ${name}_impl {}
    }
}
proc unknown args [string map [list @ [info body unknown]] {
    set arg0 [lindex $args 0]
    if { [llength $arg0] > 1 } {
        return [uplevel 1 $arg0 [lrange $args 1 end]]
    }
@}]

proc demonstrate { string } {
    puts [list $string = [lazyEval $string]]
}

 S f g x = f x { g x }
 K x y = x

curry S {f g x} { 
    list $f $x [list $g $x]
}
curry K { x y } { list $x }

demonstrate {S K K x}
demonstrate {S K K { S K K } { S K K x }}
#                      Both of the above expressions evaluate to x.

proc macro { name value } {
    curry $name {} $value
}
macro I { S K K }

macro B { S { K S } K }

macro C { S { B B S } { K K } }

macro T { C I }

macro W { C S I }

macro M { S I I }

set fast 1;
if { $fast } {
    curry I x { set x }
    curry B { f g x } { list $f [list $g $x] }
    curry C { f x y } { list $f $y $x }
    curry T { x f } { list $f $x }
    curry W { f x } { list $f $x $x }
}

• lambda x (f g) ==> S (lambda x f) (lambda x g)
• lambda x a ==> K a
• lambda x x ==> I

 * S {K p}              ==> B p
 * B p {K q}            ==> K { p q }
 * B p I                ==> p
 * S p I                ==> W p
 * S p {K q}            ==> C p q
 * C I                  ==> T
 * W I                  ==> M

set ::patterns {
    { S { K %p } }                     { B %p }
    { B %p { K %q } }                  { K { %p %q } }
    { B %p I }                         %p
    { S %p I }                         { W %p }
    { S %p { K %q } }                  { C %p %q }
    { C I }                            T
    { W I }                            M
}

proc lambda { x f } {
    traceP {[info level 0]}
    if { [llength $f] > 1 } {
       # lambda x.f g = S (lambda x.f) (lambda x.g)
       set retval [list S \
           [lambda $x [lrange $f 0 end-1]] \
           [lambda $x [lindex $f end]]]
    } elseif { [string equal $f $x] } {
        # lambda x.x = I
        set retval I
    } else {
        # lambda x.f = K f
        set retval [list K $f]
    }
    return [opt $retval]
}

proc unbrace list {
    while { [llength $list] == 1 && [string match {{*}} $list] } {
        set list [lindex $list 0]
    }
    return $list
}

proc unbrace0 list {
    set list [unbrace $list]
    while { [llength [lindex $list 0]] > 1
        || [string match {{*}} [lindex $list 0]] } {

        set list [eval [list lreplace $list 0 0] [unbrace [lindex $list 0]]]
    }
    return $list
}

proc opt { list } {
    traceP {[info level 0]}
    set improved 1
    while { $improved } {
        set list [unbrace0 $list]
        set improved 0
        foreach { pattern replacement } $::patterns {
            array unset matchVars
            if { [matches $list $pattern matchVars] } {
                set list [change $list $pattern $replacement matchVars]
                set improved 1
                break
            }
       }
   }
   return $list
}

proc matches { list pattern matchArray } {
    upvar 1 $matchArray matchVars
    traceP {[info level 0]}
    if { [llength $pattern] > [llength $list] } {
        return 0
    }
    foreach component $pattern candidate $list {
        if { [string equal {} $component] } {
            break
        }
        if { [llength $component] > 1 } {
            set candidate [unbrace0 $candidate]
            if { [llength $candidate] != [llength $component]
                || ! [matches $candidate $component matchVars] } {

                return 0
            }
        } elseif { [string match {%*} $component] } {
            if { [info exists matchVars($component)] } {
                if { [string compare $candidate $matchVars($component)] } {
                    return 0
                }
            } else {
                set matchVars($component) $candidate
            }
        } else {
            if { [string compare $candidate $component] } {
                return 0
            }
        }
    }
    traceP YES!!!
    return 1
}

proc change { list pattern replacement matchArray } {
    upvar 1 $matchArray matchVars
    traceP {[info level 0]}
    set retval [eval [list lreplace $list 0 [expr { [llength $pattern] - 1}]] \
        [makeReplacement $replacement matchVars]]
    traceP {[info level 0] returns $retval}
    return $retval
}

proc makeReplacement { replacement matchArray } {
    traceP {[info level 0]}
    upvar 1 $matchArray matchVars
    if { [llength $replacement] > 1 } {
        set retval {}
        foreach item $replacement {
            lappend retval [makeReplacement $item matchVars]
        }
    } elseif { [string match {%*} $replacement] } {
        set retval $matchVars($replacement)
    } else {
        set retval $replacement
    }
    traceP {[info level 0] returns [unbrace0 $retval]}
    return [unbrace0 $retval]
}

# S' p q r s  =  p { q s } { r s }
set sPrime [lambda p [lambda q [lambda r [lambda s { p { q s } { r s } }]]]]
puts "S' = $sPrime"
# We'll define the function using the definition printed above.
macro S' { B { B S } B }

# And we can add another optimization rule:
lappend ::patterns { S { B %p %q } }     { S' %p %q }

# C' p q r s  = p q s r

set cPrime [lambda p [lambda q [lambda r [lambda s { p q s r }]]]]
puts "C' = $cPrime"
macro C' { B C }
lappend ::patterns { S' %p %q { K %r } } { C' %p %q %r }
lappend ::patterns { B C }               C'

# B* p q r s = p { q { r s } }

set bStar [lambda p [lambda q [lambda r [lambda s { p { q { r s } } }]]]]
puts "B* = $bStar"
macro B* { C { B B { B B B } } B }
lappend ::patterns { B %p { B %q %r } }   { B* %p %q %r }

# Just as with the other combinators, we squeeze out a bit more performance by writing Tcl functions instead:

if { $fast } {
    curry S' { p q r s } { list $p [list $q $s] [list $r $s] }
    curry C' { p q r s } { list $p $q $s $r }
    curry B* { p q r s } { list $p [list $q [list $r $s]] }
}

set true [lambda x [lambda y x]]
set false [lambda x [lambda y y]]
puts "true = $true; false = $false"
macro true K
macro false { K I }

if 0 {
    We can check this on paper: Consider:
        true a b == K a b 
                 == a
        false a b == K I a b
                  == I b
                  == b

}

#We can also check it electronically:
demonstrate {true yes no}
#                      prints yes
demonstrate {false yes no}
#                      prints no

if 0 {
    Now, believe it or not, we have enough machinery, starting from just S and
    K and using nothing else, to define a form of arithmetic.  We will define a
    family of combinators, called the ''Church numerals'' after the logician
    Alonzo Church. 

    A Church numeral ''n'' is a combinator that applies a given function ''n''
    times to a given argument:

        0 f x = x
        1 f x = f x
        2 f x = f ( f x )
        n f x = f ( f ( f ( ... ( x ) ... ) ) )
                \______  ______/
                       \/
                    n times
        Since 

            K I f x = I x = x

        , we can say that 

            0 == K I
}

macro 0 { K I }

if 0 {
    Now comes the cheating: we need something to apply ''n'' times.  Let's
    define a function 'inc' that adds one to its argument.  This function will
    be used only to generate output. We aren't going to cheat and use it to do
    arithmetic.
}


curry inc {n} { expr {[lazyEval $n] + 1} }

# And we can increment 0 zero times, showing that it's, of course still zero.

demonstrate {0 inc 0}
#                      prints 0

if 0 {
    We can add one to a number without cheating.  We can define an operation,
    ''+1'', that adds one to a Church numeral by applying the target function
    one more time.

     +1 = S B
     +1 f n x = S B f n x
              = B f { n f } x
              = f { n f x }
}

macro +1 { S B }

# And in doing so, we've learned to count!

macro 1 {+1 0}
macro 2 {+1 1}
macro 3 {+1 2}

demonstrate {3 inc 0}
#                      prints 3

if 0 {
    Knowing how to count, we can figure out how to add.  Adding ''m'' to ''n''
    means that we increment ''n'' ''m'' times.  In other words, we apply the
    ''+1'' function ''m'' times.  We'll start using our [[lambda]] procedure to
    help come up with appropriate definitions.
}

set vPlus [lambda m [lambda n { m +1 n }]]
puts [list vPlus = $vPlus]
#                      prints vPlus = {T +1}
macro + {T +1}

if 0 {
    Let's prove by hand that + does what we want:

        T +1 m n = m +1 n = ( +1 applied to n m times )

    And we can test it out with some actual integers:
}

macro 4 {+ 2 2}
macro 5 {+ 2 3}
macro 8 {+ 4 4}
demonstrate {4 inc 0}
demonstrate {5 inc 0}
demonstrate {8 inc 0}
#                      prints 4, 5, and 8, rather unsurprisingly.

if 0 {
    Wow, we know how to add, starting from only ''S'' and ''K''. Let's add on
    multiplication.  Just as we add by repeated increments, we multiply by
    repeated addition; if we start with zero and add ''n'' ''m'' times, we
    should get ''mn'':
}

set vTimes [lambda m [lambda n {m {+ n} 0}]]
puts [list vTimes = $vTimes]
#                      prints vTimes = {C {C' {C B +}} 0}
macro * { C { C' { C B + } } 0 }

# I'm not going to bother proving this one; let's just assume that it works and try a few multiplications:

demonstrate {* 2 3 inc 0}
demonstrate {* 3 3 inc 0}

if 0 {
    Subtraction is trickier, so much so that I'll digress for a moment into
    some more basics.  We are going to need to form ''ordered pairs'' (''x'',
    ''y'') and take them apart again.  We have enough stuff about to do this:
    an ordered pair (''x'', ''y'') is a function that accepts a Boolean ''s''
    and returns ''x'' if ''s'' is true, ''y'' otherwise.
}

set pair [lambda x [lambda y [lambda s { s x y }]]]
puts "pair = $pair"
macro pair { C' T }

# The head of a pair is the result of passing 'true' to it as a parameter;
# the tail of the pair is the result of passing 'false'.

set hd [lambda pair {pair true}]
set tl [lambda pair {pair false}]
puts "hd = $hd; tail = $tl"
macro hd { T true }
macro tl { T false }

# A few quick demonstrations:

demonstrate {hd {pair a b}}
demonstrate {tl {pair a b}}
demonstrate {hd {pair a {pair b c}}}
demonstrate {hd {tl {pair a {pair b c}}}}
demonstrate {tl {tl {pair a {pair b c}}}}

if 0 {
    And now we can define more interesting functions, like factorial. 
    Factorial 0 is 1; factorial ''n'' is ''n'' times factorial ''n''-1. 
    Let's define the iteration step as a function that accepts the ordered pair (''n'', ''n''!)
    and returns the next ordered pair (''n''+1, [[''n''+1]]! ). 
    The factorial function extracts the tail of the ''n''th ordered pair.
}

set factIter [lambda p { factIter2 { + 1 { hd p } } { tl p } }]
puts "factIter = $factIter"
set factIter2 [lambda n [lambda f { pair n { * f n } }]]
puts "factIter2 = $factIter2"
set factorial [lambda n {tl {n factIter {pair 0 1}}}]
puts "factorial = $factorial"
macro factIter { S { B* factIter2 { + 1 } hd } tl }
macro factIter2 { S' B pair { C * } }
macro factorial { B tl { C { T factIter } { pair 0 1 } } }
demonstrate { factorial 0 inc 0 }
demonstrate { factorial 1 inc 0 }
demonstrate { factorial 2 inc 0 }
demonstrate { factorial 3 inc 0 }
# The next one is just TOO slow.
# demonstrate { factorial 4 inc 0 }

if 0 {
    Now that we have pairs (and therefore lists), we can start on subtraction,
    using a trick invented by the logician Stephen Kleene. 
    We are going to construct the list of numbers ''n'', ''n''-1, ..., 0. 
    ''n''-''k'' is the ''k''th element of this list.
}

# The list of zero such numbers has a head of 0:

set list0 [lazyEval { pair 0 nil }]
puts "list0 = $list0"
macro list0 { C' T 0 nil }

# We can make the ''n''th list inductively from the ''n''-1st, by tacking ''n'' on the front:

set nextList [lambda list { pair { +1 { hd list } } list }]
puts "nextList = $nextList"
macro nextList { W { B* pair +1 hd } }
 
# The list of integers from ''n'' down to zero is simply ''nextList'' applied ''n'' times to ''list0'':

set downFrom [lambda n { n nextList list0 }]
puts "downFrom = $downFrom"
macro downFrom { C { T nextList } list0 }

# And, as promised, ''n-k'' is the ''k''th element of the list descending from ''n'':

set minus [lambda n [lambda k { hd { k tl { downFrom n } } }]]
puts "minus = $minus"
macro - { B* { B hd } { C { T tl } } downFrom }

# Does minus work?

demonstrate { - 8 3 inc 0 }
#  prints { - 8 3 inc 0 } = 5

# Let's also use another trick to test a number for zero.

set isZero [lambda n { n { K false } true }]
puts "isZero = $isZero"
macro zero? {C {T {K false}} true}
demonstrate {zero? 0 yes no}
demonstrate {zero? 1 yes no}
demonstrate {zero? 8 yes no}

if 0 {
    OK, now we're going to start on the Fibonacci numbers.  We could use a
    trick like the one we used for factorial to iterate, but let's try to do it
    recursively, with the rules:

        fib 0 = 0
        fib 1 = 1
        fib n = fib( n-1 ) + fib( n-2 )

    Wait a second.  How on Earth are we going to do that recursion without
    named functions?  We need some sort of trick to pass a function to itself.

    What if we had a combinator Y that had the property:

        Y f x = f ( Y f ) x ?
    With this combinator, we can do a recursive function by having it accept
    itself as a parameter; it actually gets (Yf) instead of f, but that's ok,
    because Yf will just be expanded again.

    Say again? Well, let's do the recursive definition of factorial as a warm-up:
}

set rFact [lambda f [lambda n {
   zero? n 
   1
   {
        * n { f { - n 1 } }
   }
}]]
puts "rFact = $rFact"
macro rFact { B* { S { C zero? 1 } } { S * } { C B { C - 1 } } }

if 0 {
    Now,
        Y rfact 3 = rfact ( Y rfact ) 3
                  = * 3 ( Y rfact 2 )
                  = * 3 ( rfact ( Y rfact ) 2 )
                  = * 3 ( * 2 ( Y rfact 1 ) )
                  = * 3 ( * 2 ( rfact ( Y rfact ) 1 ) )
                  = * 3 ( * 2 ( * 1 ( Y rfact 0 ) ) )
                  = * 3 ( * 2 ( * 1 ( rfact ( Y rfact ) 0 ) ) )
                  = * 3 ( * 2 ( * 1 1 ) )
                  = * 3 ( * 2 1 )
                  = * 3 2
                  = 6

    But where can we find this magical Y combinator? Well, it turns out that
    there is such a beast:
}


curry Y {} { M { B { S I } M } }

if 0 {
    What??? Well, let's run through it:

        Y f x = M { B { S I } M } f x
              = B { S I } M { B { S I } M } f x
              = S I { M { B { S I } M } f x
              = S I Y f x                       <- because Y = M { B { S I } M }
              = I f { Y f } x
              = f { Y f } x

    and this is ''exactly'' what we want.
}

demonstrate { Y rFact 3 inc 0 }

if 0 {
    And the 'rFact' here is just a convenience, not really a named function.
    It still works if we expand it in line.
}

demonstrate { Y { B* { S { C zero? 1 } } { S * } { C B { C - 1 } } } 3 inc 0 }

# And now, as promised, the Fibonacci sequence, defined recursively:

set fib [lambda fib [lambda n {
    zero? n 
    0 {
        zero? { - n 1 }
        1 { 
            + { fib { - n 1 } } { fib { - n 2 } }
        }

    }
}]]
puts "fib = $fib"
curry fib {} $fib
for { set i 0 } { $i < 5 } { incr i } {
    demonstrate [list Y fib $i inc 0]
}

# All these Church numerals are horribly slow to evaluate, of course. 
# Let's define more conventional integers:

for { set i 0 } { $i < 9 } { incr i } {
    catch { rename $i {} }
}
curry + { x y } { [expr { [lazyEval $x] + [lazyEval $y] }] }
curry - { x y } { [expr { [lazyEval $x] - [lazyEval $y] }] }
curry * { x y } { [expr { [lazyEval $x] * [lazyEval $y] }] }
curry +1 { x } { [expr { 1 + [lazyEval $x] } ] }
curry zero? { x y n } { 
    if { [lazyEval $x] == 0 } {
        return $y
    } else {
        return $n
    }
}

if 0 {
    We want integers to continue to iterate, so that all the macros we defined
    above will still work.  Another patch to [[unknown]] does so:
}

proc unknown args [string map [list @ [info body unknown]] {
    set arg0 [lindex $args 0]
    if { [llength $arg0] == 1 && [string is integer $arg0] } {
        if { [llength $args] == 1 } {
            return $arg0
        } else {
            return [linsert $args 0 n-times]
        }
    }
@}]

curry n-times { n f x } {
    set n [lazyEval $n]
    for { set i 0 } { $i < $n } { incr i } {
        set y $f
        lappend y $x
        set x $y
    }
    return $x
}

# And we see that Tcl's integers behave as Church numerals with our new 'unknown':

for { set i 0 } { $i < 10 } { incr i } {
    demonstrate [list Y fib $i]
    demonstrate [list Y rFact $i]
    demonstrate [list factorial $i]
}

• The Unlambda language is based on S, K, and an apply operator.

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