libs/lambda/core.factor

   1 USING: lazy-lists io strings sequences math namespaces kernel ;
   2 IN: lambda
   3
   4 : lambda-core ( -- expr-string-array )
   5     {
   6         ":0 (one.(zero.zero))"
   7         ":SUCC (num.(one.(zero.(one((num one) zero)))))"
   8     }
   9
  10     0 lfrom 100 swap ltake list>array
  11     [
  12         [ ":" , dup 1 + number>string , " (SUCC " , number>string ,
  13         ")" , ] { } make concat
  14     ] map append
  15
  16     0 lfrom 26 swap ltake list>array
  17     [
  18         [ ":" , 65 + dup ch>string , " " , number>string , ] { } make concat
  19     ] map append
  20
  21     {
  22         ":LF 10"
  23         ":FALSE (t.(f.f))"
  24         ":TRUE (t.(f.t))"
  25         ":AND (p.(q.((p q) FALSE)))"
  26         ":OR (p.(q.((p TRUE) q)))"
  27         ":ISZERO (num.((num (pred. FALSE)) TRUE))"
  28         ":ADD (num.(other.((num SUCC) other)))"
  29         ":MULT (num.(other.((num (ADD other)) 0)))"
  30         ":PRED (n.(f.(x.(((n (g.(h.(h(g f))))) (u. x)) (u.u)))))"
  31         ":SUBFROM (num.(other.((num PRED) other)))"
  32         ":EQUAL (num.(other.((AND (ISZERO ((SUBFROM num) other))) (ISZERO ((SUBFROM other) num)))))"
  33         ":FACT (fact.(num.(((ISZERO num) 1) ((MULT num) (fact (PRED num))))))"
  34         ":YCOMBINATOR (func.((y. (func (y y)))(y. (func (y y)))))"
  35         ":FACTORIAL (YCOMBINATOR FACT)"
  36         ":CONS (car.(cdr.(which.((which car) cdr))))"
  37         ":CAR (cons.(cons TRUE))"
  38         ":CDR (cons.(cons FALSE))"
  39         ":PCONS (pcons.(num.(cons.(((ISZERO num) (PRINTSPECIAL LF)) ((PRINTCHAR (CAR cons)) ((pcons (PRED num)) (CDR cons)))))))"
  40         ":PRINTCONS (YCOMBINATOR PCONS)"
  41         ":NUMTOCHAR (num. ((ADD 48) num))"
  42         ":PRINTNUM (num.(PRINTCHAR (NUMTOCHAR num)))"
  43         ":PRINTCHAR (char.([PRINTCHAR] (ALIENNUM char)))"
  44         ":PRINTSPECIAL (special.([PRINTCHAR] (ALIENNUM special)))"
  45         ":ALIEN0 alienbaseonenum"
  46         ":ALIENNUM (num.((num [ALIENSUCC]) ALIEN0))"
  47         ":HELLOCONS ((CONS H) ((CONS E) ((CONS Y) ((CONS 0) nil))))"
  48         ":HELLO ((PRINTCONS 3) HELLOCONS)"
  49         "(([HELLO] nil) ([INFO] nil))"
  50     } append ;
  51
  52 : print-return ( -- node )
  53     write "(nil.nil)" lambda-parse second ;
  54
  55 : HELLO ( node -- node )
  56     drop "\nHello and Welcome to Lambda!\n" print-return ;
  57
  58 : INFO ( node -- node )
  59     drop "Type HELLO and wait 10 seconds to see me flex my io muscles.\n" print-return ;
  60
  61 : ALIENSUCC ( node -- node )
  62     var-node-name "a" append <var-node> ;
  63
  64 : ALIENPRED ( node -- node )
  65     var-node-name dup length 1 - swap remove-nth <var-node> ;
  66
  67 : ALIENISZERO ( node -- node )
  68     ;
  69
  70 : PRINTCHAR ( node -- node )
  71     #! takes a base one num and prints its char equivalent
  72     var-node-name length "alienbaseonenum" length - ch>string print-return ;
  73
  74 : READCHAR ( node -- node )
  75     #! reads one character of input and stores it as a base one num
  76     "alienbaseonenum" read1 [ "a" append ] times <var-node> ;
  77
  78