libs/lambda/nodes.factor

   1 #! A lambda expression manipulator, by Matthew Willis
   2 USING: lazy-lists strings arrays hashtables
   3 sequences namespaces words parser kernel ;
   4
   5 IN: lambda
   6
   7 : dip swap slip ; inline
   8
   9 SYMBOL: lambda-names
  10 TUPLE: lambda-node self expr name ;
  11 TUPLE: apply-node func arg ;
  12 TUPLE: var-node name ; #! var is either a var, name, or pointer to a lambda-node
  13 TUPLE: beta-node expr lambdas ; #! a namespace node
  14 TUPLE: alien-node word ;
  15
  16 M: lambda-node equal? eq? ;
  17
  18 GENERIC: bind-var
  19 M: lambda-node bind-var ( binding lambda -- )
  20     lambda-node-expr bind-var ;
  21
  22 M: apply-node bind-var ( binding apply -- )
  23     [ apply-node-func bind-var ] 2keep apply-node-arg bind-var ;
  24
  25 M: var-node bind-var ( binding var-node -- )
  26     2dup var-node-name swap lambda-node-name =
  27     [ set-var-node-name ] [ 2drop ] if ;
  28
  29 M: alien-node bind-var ( binding alien -- ) 2drop ;
  30
  31 C: lambda-node ( expr var lambda -- lambda )
  32     swapd [ set-lambda-node-name ] keep
  33     [ set-lambda-node-expr ] 2keep
  34     dup [ set-lambda-node-self ] keep
  35     [ swap bind-var ] keep ;
  36
  37 GENERIC: beta-push
  38 #! push the beta further down the syntax tree
  39 #!  this is how lambda achieves lazy beta reduction and efficient cloning.
  40 #!  everything outside of the beta must have been cloned.
  41 M: lambda-node beta-push ( beta lambda -- lambda )
  42     clone dup lambda-node-expr pick set-beta-node-expr
  43     [ set-lambda-node-expr ] keep ;
  44
  45 M: apply-node beta-push ( beta apply -- apply )
  46     #! push the beta into each branch, cloning the beta
  47     swap dup clone
  48     pick apply-node-func swap [ set-beta-node-expr ] keep swap
  49     rot apply-node-arg swap [ set-beta-node-expr ] keep
  50     <apply-node> ;
  51
  52 M: var-node beta-push ( beta var -- expr )
  53     #! substitute the variable with the appropriate entry from the
  54     #! beta namespace
  55     tuck var-node-name swap beta-node-lambdas hash dup
  56     [ nip ] [ drop ] if ;
  57
  58 M: beta-node beta-push ( beta inner-beta -- beta )
  59     #! combines the namespaces of two betas
  60     dup beta-node-lambdas rot beta-node-lambdas hash-union
  61     swap [ set-beta-node-lambdas ] keep ;
  62
  63 M: alien-node beta-push ( beta alien -- alien ) nip ;
  64
  65 : beta-reduce ( apply -- beta )
  66     #! construct a beta-node which carries the namespace of the lambda
  67     dup apply-node-arg swap apply-node-func dup lambda-node-expr -rot
  68     lambda-node-self H{ } clone [ set-hash ] keep <beta-node> ;
  69
  70 DEFER: evaluate
  71 : left-reduce ( apply -- apply/f )
  72     #! we are at an application node -- evaluate the function
  73     dup apply-node-func evaluate dup
  74     [ swap [ set-apply-node-func ] keep ]
  75     [ nip ] if ;
  76
  77 : alien-reduce ( apply -- node/f )
  78     #! we have come to an alien application, which requires us to
  79     #! fully normalize the argument before proceeding
  80     dup apply-node-arg evaluate dup
  81     [ swap [ set-apply-node-arg ] keep ]
  82     [ #! right side is normalized, we are ready to do the alien application
  83         drop dup apply-node-arg swap apply-node-func
  84         alien-node-word "lambda" lookup execute
  85     ] if ;
  86
  87 GENERIC: evaluate
  88 #! There are
  89 #!   beta-reduction, beta-pushing, and name replacing.
  90 : normalize ( expr -- expr )
  91     dup evaluate [ nip normalize ] when* ;
  92
  93 M: lambda-node evaluate ( lambda -- node/f ) drop f ;
  94
  95 M: apply-node evaluate ( apply -- node )
  96     dup apply-node-func lambda-node?
  97     [ beta-reduce ]
  98     [
  99         dup apply-node-func alien-node?
 100         [ alien-reduce ]
 101         [ left-reduce ] if
 102     ] if ;
 103
 104 M: var-node evaluate ( var -- node/f )
 105     var-node-name lambda-names get hash ;
 106
 107 M: beta-node evaluate ( beta -- node/f )
 108     dup beta-node-expr beta-push ;
 109
 110 M: alien-node evaluate ( alien -- node/f ) drop f ;
 111
 112 GENERIC: expr>string
 113 M: lambda-node expr>string ( lambda-node -- string )
 114     [
 115         dup "(" , lambda-node-name , ". " ,
 116         lambda-node-expr expr>string , ")" ,
 117     ] { } make concat ;
 118
 119 M: apply-node expr>string ( apply-node -- string )
 120     [
 121         dup "(" , apply-node-func expr>string , " " ,
 122         apply-node-arg expr>string , ")" ,
 123     ] { } make concat ;
 124
 125 M: var-node expr>string ( variable-node -- string )
 126     var-node-name dup string? [ lambda-node-name ] unless ;
 127
 128 M: alien-node expr>string ( alien-node -- string )
 129     [ "[" , alien-node-word , "]" , ] { } make concat ;
 130
 131 M: beta-node expr>string ( beta -- string )
 132     [ "beta<" , beta-node-expr expr>string , ">" , ] { } make concat ;