#! A lambda expression manipulator, by Matthew Willis USING: lazy-lists strings arrays hashtables sequences namespaces words parser kernel ; IN: lambda SYMBOL: lambda-names TUPLE: lambda-node self expr name ; TUPLE: apply-node func arg ; 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 ; M: lambda-node equal? 2drop f ; GENERIC: bind-var M: lambda-node bind-var ( binding lambda -- ) lambda-node-expr bind-var ; M: apply-node bind-var ( binding apply -- ) [ apply-node-func bind-var ] 2keep apply-node-arg bind-var ; M: var-node bind-var ( binding var-node -- ) 2dup var-node-name swap lambda-node-name = [ set-var-node-name ] [ 2drop ] if ; M: alien-node bind-var ( binding alien -- ) 2drop ; 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 ; GENERIC: beta-push #! push the beta further down the syntax tree #! this is how lambda achieves lazy beta reduction and efficient cloning. #! everything outside of the beta must have been cloned. M: lambda-node beta-push ( beta lambda -- lambda ) clone dup lambda-node-expr pick set-beta-node-expr [ set-lambda-node-expr ] keep ; 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 ; M: var-node beta-push ( beta var -- expr ) #! substitute the variable with the appropriate entry from the #! beta namespace tuck var-node-name swap beta-node-lambdas hash dup [ nip ] [ drop ] if ; M: beta-node beta-push ( beta inner-beta -- beta ) #! combines the namespaces of two betas dup beta-node-lambdas rot beta-node-lambdas hash-union swap [ set-beta-node-lambdas ] keep ; M: alien-node beta-push ( beta alien -- alien ) nip ; : beta-reduce ( apply -- beta ) #! construct a beta-node which carries the namespace of the lambda dup apply-node-arg swap apply-node-func dup lambda-node-expr -rot lambda-node-self H{ } clone [ set-hash ] keep ; DEFER: evaluate : left-reduce ( apply -- apply/f ) #! we are at an application node -- evaluate the function dup apply-node-func evaluate dup [ swap [ set-apply-node-func ] keep ] [ nip ] if ; : alien-reduce ( apply -- node/f ) #! we have come to an alien application, which requires us to #! fully normalize the argument before proceeding dup apply-node-arg evaluate dup [ swap [ set-apply-node-arg ] keep ] [ #! right side is normalized, we are ready to do the alien application drop dup apply-node-arg swap apply-node-func alien-node-word "lambda" lookup execute ] if ; 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: 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 ; M: var-node evaluate ( var -- node/f ) var-node-name lambda-names get hash ; M: beta-node evaluate ( beta -- node/f ) dup beta-node-expr beta-push ; M: alien-node evaluate ( alien -- node/f ) drop f ; GENERIC: expr>string M: lambda-node expr>string ( lambda-node -- string ) [ dup "(" , lambda-node-name , ". " , lambda-node-expr expr>string , ")" , ] { } make concat ; M: apply-node expr>string ( apply-node -- string ) [ dup "(" , apply-node-func expr>string , " " , apply-node-arg expr>string , ")" , ] { } make concat ; M: var-node expr>string ( variable-node -- string ) var-node-name dup string? [ lambda-node-name ] unless ; M: alien-node expr>string ( alien-node -- string ) [ "[" , alien-node-word , "]" , ] { } make concat ; M: beta-node expr>string ( beta -- string ) [ "beta<" , beta-node-expr expr>string , ">" , ] { } make concat ;