unmaintained/lambda/core.factor

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