Added alien support, added core library

contrib/lambda/core.factor

@@ -0,0 +1,65 @@
+USING: lazy-lists io strings sequences math namespaces kernel ;
+IN: lambda
+
+: lambda-core ( -- expr-string-array )
+    {
+        ":0 (one.(zero.zero))"
+        ":SUCC (num.(one.(zero.(one((num one) zero)))))"
+    }
+    
+    0 lfrom 100 swap ltake list>array
+    [ 
+        [ ":" , dup 1 + number>string , " (SUCC " , number>string ,
+        ")" , ] { } make concat
+    ] map append
+    
+    0 lfrom 26 swap ltake list>array
+    [
+        [ ":" , dup 65 + ch>string , " " , number>string , ] { } make concat
+    ] map append
+    
+    {
+        ":LF 10"
+        ":FALSE (t.(f.f))"
+        ":TRUE (t.(f.t))"
+        ":ISZERO (num.((num (pred. FALSE)) TRUE))"
+        ":ADD (num.(other.((num SUCC) other)))"
+        ":MULT (num.(other.((num (ADD other)) 0)))"
+        ":PRED (n.(f.(x.(((n (g.(h.(h(g f))))) (u. x)) (u.u)))))"
+        ":SUBFROM (num.(other.((num PRED) other)))"
+        ":FACT (fact.(num.(((ISZERO num) 1) ((MULT num) (fact (PRED num))))))"
+        ":YCOMBINATOR (func.((y. (func (y y)))(y. (func (y y)))))"
+        ":FACTORIAL (YCOMBINATOR FACT)"
+        ":CONS (car.(cdr.(which.((which car) cdr))))"
+        ":CAR (cons.(cons TRUE))"
+        ":CDR (cons.(cons FALSE))"
+        ":PCONS (pcons.(num.(cons.(((ISZERO num) (PRINTSPECIAL LF)) ((PRINTCHAR (CAR cons)) ((pcons (PRED num)) (CDR cons)))))))"
+        ":PRINTCONS (YCOMBINATOR PCONS)"
+        ":NUMTOCHAR (num. ((ADD 48) num))"
+        ":ALPHATOCHAR (num. ((ADD 65) num))"
+        ":PRINTNUM (num.([PRINTCHAR] (ALIENNUM (NUMTOCHAR num))))"
+        ":PRINTCHAR (char.([PRINTCHAR] (ALIENNUM (ALPHATOCHAR char))))"
+        ":PRINTSPECIAL (special.([PRINTCHAR] (ALIENNUM special)))"
+        ":ALIEN0 alienbaseonenum"
+        ":ALIENNUM (num.((num [ALIENSUCC]) ALIEN0))"
+        ":HELLOCONS ((CONS H) ((CONS E) ((CONS Y) nil)))"
+        ":HELLO ((PRINTCONS 3) HELLOCONS)"
+        "(([HELLO] nil) ([INFO] nil)"
+    } append ;
+
+: print-return ( -- node )
+    write "(nil.nil)" lambda-parse second ;
+    
+: HELLO ( node -- node )
+    drop "\nHello and Welcome to Lambda!\n" print-return ;
+
+: INFO ( node -- node )
+    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> ;
+
+: PRINTCHAR ( node -- node )
+    #! takes a base one num and prints its char equivalent
+    variable-node-var length "alienbaseonenum" length - ch>string print-return ;
+    

contrib/lambda/lambda.TODO

@@ -1,8 +1,6 @@
 Lambda TODO
 -----------
-Change definition syntax from :<NAME> <EXPR> to <NAME>:<EXPR>
 Documentation
 Unit tests
 More graceful parse error handling
-Factor out tree traversing into its own lib
-Core library
+Factor out tree traversing into its own lib

contrib/lambda/lambda.factor

@@ -29,7 +29,8 @@ IN: lambda
 
 : lambda-boot ( -- names )
     #! load the core lambda library
-    H{ } clone ;
+    H{ } clone dup lambda-core 
+    [ lambda-parse lambda-eval lambda-print drop ] each-with ;
 
 : (lambda) ( names -- names )
     readln dup "." = [ drop ] [

contrib/lambda/load.factor

@@ -1,6 +1,7 @@
 PROVIDE: lambda {
     "nodes.factor"
     "parser.factor"
+    "core.factor"
     "lambda.factor"
 } {
     "test/lambda.factor"

contrib/lambda/nodes.factor

@@ -1,7 +1,7 @@
 #! A lambda expression manipulator, by Matthew Willis
 REQUIRES: lazy-lists ;
 USING: lazy-lists strings arrays hashtables 
-sequences namespaces words kernel ;
+sequences namespaces words parser kernel ;
 
 IN: kernel
 : dip swap slip ; inline
@@ -11,6 +11,7 @@ IN: lambda
 TUPLE: lambda-node expr original canonical ;
 TUPLE: apply-node func arg ;
 TUPLE: variable-node var ;
+TUPLE: alien-node word ;
 
 DEFER: substitute
 C: lambda-node ( var expr implicit-empty-lambda-node -- lambda-node )
@@ -42,6 +43,8 @@ M: apply-node (traverse) ( data-array word apply-node -- node )
 M: variable-node (traverse) ( data-array word variable-node -- node )
     (pre) (post) ;
 
+M: alien-node (traverse) ( data-array word alien-node -- node ) nip nip ;
+
 : traverse ( node data-array {pre,post} -- node )
     rot (traverse) ;
 
@@ -103,6 +106,12 @@ M: variable-node (substitute) ( data-array variable-node -- node )
 : eta-reduce ( lambda-node -- expr ) 
     lambda-node-expr apply-node-func ;
 
+DEFER: evaluate
+: alien-reduce ( apply-node -- expr )
+    #! execute the factor word in the alien-node
+    dup apply-node-arg evaluate 
+    swap apply-node-func alien-node-word "lambda" lookup execute ;
+
 GENERIC: evaluate
 M: lambda-node evaluate ( lambda-node -- node ) 
     #! eta-reduction
@@ -119,15 +128,21 @@ M: lambda-node evaluate ( lambda-node -- node )
 M: apply-node evaluate ( apply-node -- node )
     #! beta-reduction
     #! TODO: fix the weird recursion here
-    dup apply-node-func lambda-node?
-    [ beta-reduce evaluate ] 
+    dup apply-node-func alien-node?
+    [ alien-reduce evaluate ]
     [
-        dup apply-node-func evaluate swap [ set-apply-node-func ] keep
-        dup apply-node-func lambda-node? [ evaluate ] when
+        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 ) ;
 
+M: alien-node evaluate ( alien-node -- node ) ;
+
 GENERIC: (replace-names)
 DEFER: replace-names 
 M: lambda-node (replace-names) ( names-hash l-node -- node ) nip ;
@@ -156,4 +171,7 @@ M: apply-node expr>string ( available-vars apply-node -- string )
     [ "(" , , " " , , ")" , ] { } make concat ;
 
 M: variable-node expr>string ( available-vars variable-node -- string ) 
-    nip variable-node-var dup string? [ lambda-node-canonical ] unless ;
+    nip variable-node-var dup string? [ lambda-node-canonical ] unless ;
+
+M: alien-node expr>string ( available-vars alien-node -- string )
+    nip [ "[" , alien-node-word , "]" , ] { } make concat ;

contrib/lambda/parser.factor

@@ -55,9 +55,14 @@ DEFER: <expr>
     "(" token <expr> sp &> <expr> sp <&> ")" token sp <& 
     [ [ first ] keep second <apply-node> ] <@ ;
 
+: <alien>
+    #! parses [<FACTOR-WORD>], the alien invocation
+    #! an alien factor word must be all capital letters and numerals
+    "[" token <name> sp &> "]" token sp <& [ <alien-node> ] <@ ;
+
 : <expr>
     [ <id> call ] [ <lambda> call ] [ <apply> call ] <|> <|>
-    <name> [ <variable-node> ] <@ <|> ;
+    <name> [ <variable-node> ] <@ <|> <alien> <|> ;
 
 : <line>
     ":" token <name> &> <expr> sp <&> f succeed <expr> <&>