Lambda rewrite. Tree traversals eliminated, controlled evaluation, lazy name replacement and beta-reduction

contrib/lambda/core.factor

@@ -59,20 +59,20 @@ IN: lambda
     drop "Type HELLO and wait 10 seconds to see me flex my io muscles.\n" print-return ;
 
 : ALIENSUCC ( node -- node )
-    variable-node-var "a" append <variable-node> ;
+    var-node-name "a" append <var-node> ;
 
 : ALIENPRED ( node -- node )
-    variable-node-var dup length 1 - swap remove-nth <variable-node> ;
+    var-node-name dup length 1 - swap remove-nth <var-node> ;
 
 : ALIENISZERO ( node -- node )
     ;
 
 : PRINTCHAR ( node -- node )
     #! takes a base one num and prints its char equivalent
-    variable-node-var length "alienbaseonenum" length - ch>string print-return ;
+    var-node-name length "alienbaseonenum" length - ch>string print-return ;
 
 : READCHAR ( node -- node )
     #! reads one character of input and stores it as a base one num
-    "alienbaseonenum" read1 [ "a" append ] times <variable-node> ;
+    "alienbaseonenum" read1 [ "a" append ] times <var-node> ;
 
     

contrib/lambda/lambda.TODO

@@ -5,6 +5,10 @@ Unit tests
 More graceful parse error handling
 Factor out tree traversing into its own lib
 
+Redesign
+--------
+Why doesn't PRED work?
+
 Core
 ----
 ISNIL

contrib/lambda/lambda.factor

@@ -1,41 +1,28 @@
 #! An interpreter for lambda expressions, by Matthew Willis
-REQUIRES: lazy-lists ;
+USING: io strings hashtables sequences namespaces kernel ;
-USING: lazy-lists io strings hashtables sequences namespaces kernel ;
 IN: lambda
 
-: bound-vars ( -- lazy-list ) 65 lfrom [ ch>string ] lmap ;
+: lambda-print ( name/expr -- )
-
+    dup string? 
-: canonical-string ( expr -- string )
+    [   dup lambda-names get hash expr>string " " swap 
-    #! pretty print in canonical form, for use with reverse lookups
-    bound-vars swap expr>string ;
-
-: original-string ( expr -- string )
-    #! pretty print with vars named as inputed
-    nil swap expr>string ;
-
-: lambda-print ( names expr/name -- names )
-    dup string? [ over dupd hash original-string " " swap 
         append append "DEF " swap append 
-    ] [ original-string "=> " swap append 
+    ] [ expr>string "=> " swap append 
     ] if print flush ;
 
-: lambda-eval ( names parse-result -- names name/expr )
+: lambda-define ( parse-result -- name/expr )
     #! Make sure not to evaluate definitions.
-    first2 over [ 
+    first2 over [ over lambda-names get set-hash ] [ nip ] if ;
-        swap rot [ set-hash ] 2keep swap
-    ] [
-        pick swap replace-names swap drop evaluate
-    ] if ;
 
-: lambda-boot ( -- names )
+: lambda-eval ( name/expr -- name/expr )
+    dup string? [ normalize ] unless ;
+
+: lambda-boot ( -- )
     #! load the core lambda library
-    H{ } clone dup lambda-core 
+    H{ } clone lambda-names set lambda-core
-    [ lambda-parse lambda-eval lambda-print drop ] each-with ;
+    [ lambda-parse lambda-define lambda-eval lambda-print ] each ;
-
+ 
-: (lambda) ( names -- names )
+: lambda ( -- )
+    lambda-names get [ lambda-boot ] unless
     readln dup "." = [ drop ] [
-        lambda-parse lambda-eval lambda-print (lambda)
+        lambda-parse lambda-define lambda-eval lambda-print lambda
-    ] if ;
+    ] if ;
-
-: lambda ( -- names )
-    lambda-boot (lambda) ;

contrib/lambda/nodes.factor

@@ -6,168 +6,127 @@ IN: lambda
 
 : dip swap slip ; inline
 
-TUPLE: lambda-node expr original canonical ;
+SYMBOL: lambda-names
+TUPLE: lambda-node self expr name ;
 TUPLE: apply-node func arg ;
-TUPLE: variable-node var ;
+TUPLE: var-node name ; #! var is either a var, name, or pointer to a lambda-node
+TUPLE: beta-node expr lambdas ; #! a namespace node
 TUPLE: alien-node word ;
 
-DEFER: substitute
+M: lambda-node equal? eq? ;
-C: lambda-node ( var expr implicit-empty-lambda-node -- lambda-node )
-    #! store the expr, replacing every occurence of var with
-    #! a pointer to this lambda-node
-    [ <variable-node> -rot substitute ] 3keep nip swapd
-    [ set-lambda-node-expr ] keep 
-    [ set-lambda-node-original ] keep ;
 
-GENERIC: (traverse)
+GENERIC: bind-var
-: (pre) ( data-array pre-post node -- data-array pre-post new-node )
+M: lambda-node bind-var ( binding lambda -- ) 
-    [ swap first execute ] 3keep drop rot ;
+    lambda-node-expr bind-var ; 
 
-: (post) ( data-array pre-post node -- new-node )
+M: apply-node bind-var ( binding apply -- )
-    swap second execute ;
+    [ apply-node-func bind-var ] 2keep apply-node-arg bind-var ;
-    
-#! Traverses the tree while executing pre and post order words
-M: lambda-node (traverse) ( data-array words lambda-node -- node )
-    (pre)
-    [ [ lambda-node-expr (traverse) ] keep set-lambda-node-expr ] 3keep 
-    (post) ; 
 
-M: apply-node (traverse) ( data-array words apply-node -- node )
+M: var-node bind-var ( binding var-node -- )
-    (pre)
+    2dup var-node-name swap lambda-node-name = 
-    [ [ apply-node-func (traverse) ] keep set-apply-node-func ] 3keep
+    [ set-var-node-name ] [ 2drop ] if ;
-    [ [ apply-node-arg (traverse) ] keep set-apply-node-arg ] 3keep
-    (post) ;
 
-M: variable-node (traverse) ( data-array words variable-node -- node )
+M: alien-node bind-var ( binding alien -- ) 2drop ;
-    (pre) (post) ;
 
-M: alien-node (traverse) ( data-array word alien-node -- node ) nip nip ;
+C: lambda-node ( expr var lambda -- lambda )
+    swapd [ set-lambda-node-name ] keep
+    [ set-lambda-node-expr ] 2keep
+    dup [ set-lambda-node-self ] keep
+    [ swap bind-var ] keep ;
 
-: traverse ( node data-array {pre,post} -- node )
+GENERIC: beta-push
-    rot (traverse) ;
+#! push the beta further down the syntax tree
-
+#!  this is how lambda achieves lazy beta reduction and efficient cloning.
-: pre-order ( node data-array word -- node )
+#!  everything outside of the beta must have been cloned.
-    { nip } curry traverse ;
+M: lambda-node beta-push ( beta lambda -- lambda )
-    
+    clone dup lambda-node-expr pick set-beta-node-expr
-: post-order ( node data-array word -- node )
-    { nip } swap add traverse ;
-
-GENERIC: (clone-pre)
-M: lambda-node (clone-pre) ( data lambda-node -- node )
-    #! leave a copy of the original lambda node on the stack
-    #! for later substitution
-    nip dup clone ; 
-
-M: apply-node (clone-pre) ( data apply-node -- node ) nip clone ;
-
-M: variable-node (clone-pre) ( data variable-node -- node ) nip clone ;
-
-GENERIC: (clone-post)
-M: lambda-node (clone-post) ( data lambda-node -- node )
-    nip [ dup <variable-node> -rot lambda-node-expr substitute  ] keep 
     [ set-lambda-node-expr ] keep ;
-    
-M: apply-node (clone-post) ( data apply-node -- node ) nip ;
 
-M: variable-node (clone-post) ( data variable-node -- node ) nip ;
+M: apply-node beta-push ( beta apply -- apply )
+    #! push the beta into each branch, cloning the beta
+    swap dup clone 
+    pick apply-node-func swap [ set-beta-node-expr ] keep swap
+    rot apply-node-arg swap [ set-beta-node-expr ] keep
+    <apply-node> ;
 
-: clone-node ( node -- clone )
+M: var-node beta-push ( beta var -- expr )
-    f { (clone-pre) (clone-post) } traverse ;
+    #! substitute the variable with the appropriate entry from the
+    #! beta namespace
+    tuck var-node-name swap beta-node-lambdas hash dup
+    [ nip ] [ drop ] if ;
 
-GENERIC: variable-eq?
+M: beta-node beta-push ( beta inner-beta -- beta )
-M: string variable-eq? ( var string -- bool ) = ;
+    #! combines the namespaces of two betas
+    dup beta-node-lambdas rot beta-node-lambdas hash-union
+    swap [ set-beta-node-lambdas ] keep ;
 
-M: lambda-node variable-eq? ( var lambda-node-pointer -- bool ) eq? ;
+M: alien-node beta-push ( beta alien -- alien ) nip ;
 
-GENERIC: (substitute)
+: beta-reduce ( apply -- beta )
-M: lambda-node (substitute) ( data-array lambda-node -- node ) nip ;
+    #! construct a beta-node which carries the namespace of the lambda
-
+    dup apply-node-arg swap apply-node-func dup lambda-node-expr -rot
-M: apply-node (substitute) ( data-array apply-node -- node ) nip ;
+    lambda-node-self H{ } clone [ set-hash ] keep <beta-node> ;
-    
-M: variable-node (substitute) ( data-array variable-node -- node )
-    #! ( variable-node == var ) ? expr | variable-node
-    #! this could use multiple dispatch!
-    [ first2 ] dip ( expr var variable-node -- )
-    [ variable-node-var variable-eq? ] keep swap ( expr variable-node cond )
-    [ swap ] unless drop ;  
-
-: substitute ( expr var node -- node )
-    -rot 2array \ (substitute) post-order ;
-
-: beta-reduce ( apply-node -- expr )
-    #! "pass" expr to the lambda-node, returning a reduced expression
-    dup apply-node-arg swap apply-node-func 
-    clone-node dup lambda-node-expr substitute ;
-
-: eta-reduce ( lambda-node -- expr ) 
-    lambda-node-expr apply-node-func ;
 
 DEFER: evaluate
-: alien-reduce ( apply-node -- expr )
+: left-reduce ( apply -- apply/f )
-    #! execute the factor word in the alien-node
+    #! we are at an application node -- evaluate the function
-    dup apply-node-arg evaluate 
+    dup apply-node-func evaluate dup
-    swap apply-node-func alien-node-word "lambda" lookup execute ;
+    [ swap [ set-apply-node-func ] keep ]
+    [ nip ] if ;
 
-GENERIC: evaluate
+: alien-reduce ( apply -- node/f )
-M: lambda-node evaluate ( lambda-node -- node ) 
+    #! we have come to an alien application, which requires us to
-    #! eta-reduction
+    #! fully normalize the argument before proceeding
-    dup lambda-node-expr apply-node? [ 
+    dup apply-node-arg evaluate dup
-        dup lambda-node-expr apply-node-arg 
+    [ swap [ set-apply-node-arg ] keep ]
-        variable-node? [
+    [ #! right side is normalized, we are ready to do the alien application
-            dup dup lambda-node-expr apply-node-arg variable-node-var 
+        drop dup apply-node-arg swap apply-node-func
-            eq? [ 
+        alien-node-word "lambda" lookup execute
-                eta-reduce evaluate 
-            ] when
-        ] when
-    ] when ;
-
-M: apply-node evaluate ( apply-node -- node )
-    #! beta-reduction
-    #! TODO: fix the weird recursion here
-    dup apply-node-func alien-node?
-    [ alien-reduce evaluate ]
-    [
-        dup apply-node-func lambda-node?
-        [ beta-reduce evaluate ] 
-        [
-            dup apply-node-func evaluate swap [ set-apply-node-func ] keep
-            dup apply-node-func lambda-node? [ evaluate ] when
-        ] if
     ] if ;
 
-M: variable-node evaluate ( variable-node -- node ) ;
+GENERIC: evaluate
+#! There are 
+#!   beta-reduction, beta-pushing, and name replacing.
+: normalize ( expr -- expr )
+    dup evaluate [ nip normalize ] when* ;
+    
+M: lambda-node evaluate ( lambda -- node/f ) drop f ;
 
-M: alien-node evaluate ( alien-node -- node ) ;
+M: apply-node evaluate ( apply -- node )
+    dup apply-node-func lambda-node?
+    [ beta-reduce ] 
+    [ 
+        dup apply-node-func alien-node?
+        [ alien-reduce ]
+        [ left-reduce ] if
+    ] if ;
 
-GENERIC: (replace-names)
+M: var-node evaluate ( var -- node/f ) 
-DEFER: replace-names 
+    var-node-name lambda-names get hash ;
-M: lambda-node (replace-names) ( names-hash l-node -- node ) nip ;
 
-M: apply-node (replace-names) ( names-hash a-node -- node ) nip ;
+M: beta-node evaluate ( beta -- node/f ) 
+    dup beta-node-expr beta-push ;
 
-M: variable-node (replace-names) ( names-hash v-node -- node )
+M: alien-node evaluate ( alien -- node/f ) drop f ;
-    [ variable-node-var swap hash ] 2keep pick not 
-    [ 2nip ] [ drop swap clone-node replace-names ] if ;
-
-: replace-names ( names-hash node -- node )
-    swap \ (replace-names) post-order ;
-
-: set-temp-label ( available-vars lambda-node -- available-vars label lambda-node )
-    over nil? 
-    [ [ lambda-node-original ] keep [ set-lambda-node-canonical ] 2keep ]
-    [ [ uncons swap ] dip [ set-lambda-node-canonical ] 2keep ] if ;
 
 GENERIC: expr>string
-M: lambda-node expr>string ( available-vars lambda-node -- string )
+M: lambda-node expr>string ( lambda-node -- string )
-    set-temp-label swapd lambda-node-expr expr>string swap 
+    [ 
-    [ "(" , , ". " , , ")" , ] { } make concat ;
+        dup "(" , lambda-node-name , ". " , 
+        lambda-node-expr expr>string , ")" , 
+    ] { } make concat ;
 
-M: apply-node expr>string ( available-vars apply-node -- string ) 
+M: apply-node expr>string ( apply-node -- string ) 
-    [ apply-node-arg expr>string ] 2keep apply-node-func expr>string
+    [ 
-    [ "(" , , " " , , ")" , ] { } make concat ;
+        dup "(" , apply-node-func expr>string , " " , 
+        apply-node-arg expr>string , ")" , 
+    ] { } make concat ;
 
-M: variable-node expr>string ( available-vars variable-node -- string ) 
+M: var-node expr>string ( variable-node -- string ) 
-    nip variable-node-var dup string? [ lambda-node-canonical ] unless ;
+    var-node-name dup string? [ lambda-node-name ] unless ;
 
-M: alien-node expr>string ( available-vars alien-node -- string )
+M: alien-node expr>string ( alien-node -- string )
-    nip [ "[" , alien-node-word , "]" , ] { } make concat ;
+    [ "[" , alien-node-word , "]" , ] { } make concat ;
+
+M: beta-node expr>string ( beta -- string )
+    [ "beta<" , beta-node-expr expr>string , ">" , ] { } make concat ;

contrib/lambda/parser.factor

@@ -33,7 +33,7 @@ IN: lambda
 : <id>
     #! parses an identifier (string for now)
     #! TODO: do we need to enter it into a symbol table?
-    <letter> <alphanumeric> <*> <&:> [ concat <variable-node> ] <@ ;
+    <letter> <alphanumeric> <*> <&:> [ concat <var-node> ] <@ ;
 
 : <name>
     #! parses a name, which is used in replacement
@@ -46,7 +46,7 @@ DEFER: <expr>
     #! lambda expression.
     "(" token <id> sp &> "." token sp <& 
     <expr> sp <&> ")" token sp <&
-    [ [ first variable-node-var ] keep second <lambda-node> ] <@ ;
+    [ [ first var-node-name ] keep second <lambda-node> ] <@ ;
 
 : <apply>
     #! parses (<expr> <expr>), the function application
@@ -60,7 +60,7 @@ DEFER: <expr>
 
 : <expr>
     [ <id> call ] [ <lambda> call ] [ <apply> call ] <|> <|>
-    <name> [ <variable-node> ] <@ <|> <alien> <|> ;
+    <name> [ <var-node> ] <@ <|> <alien> <|> ;
 
 : <line>
     ":" token <name> &> <expr> sp <&> f succeed <expr> <&>