Refactored Lambda, implemented reverse name lookups
matthew.willis
parent
835ed00a14
commit
3bf43d3c61
|
|
@ -1,159 +1,47 @@
|
|||
#! An interpreter for lambda expressions, by Matthew Willis
|
||||
#! The grammar in BNF is:
|
||||
#! <expr> ::= <id>
|
||||
#! <expr> ::= <name>
|
||||
#! <expr> ::= (<id> . <expr>)
|
||||
#! <expr> ::= (<expr> <expr>)
|
||||
#! <line> ::= <expr>
|
||||
#! <line> ::= <name> : <expr>
|
||||
|
||||
REQUIRES: parser-combinators ;
|
||||
USING: parser-combinators lazy-lists io strings
|
||||
hashtables sequences prettyprint namespaces kernel ;
|
||||
|
||||
REQUIRES: lazy-lists ;
|
||||
USING: lazy-lists io strings hashtables sequences kernel ;
|
||||
IN: lambda
|
||||
|
||||
: <letter>
|
||||
#! parses an uppercase or lowercase letter
|
||||
[ letter? ] satisfy [ ch>string ] <@ ;
|
||||
|
||||
: <LETTER>
|
||||
#! parses an uppercase or lowercase letter
|
||||
[ LETTER? ] satisfy [ ch>string ] <@ ;
|
||||
|
||||
: <number>
|
||||
#! parses a number
|
||||
[ digit? ] satisfy [ ch>string ] <@ ;
|
||||
|
||||
: <alphanumeric>
|
||||
#! parses an alphanumeral
|
||||
<letter> <number> <|> ;
|
||||
|
||||
: <ALPHANUMERIC>
|
||||
#! parses an alphanumeral
|
||||
<LETTER> <number> <|> ;
|
||||
|
||||
TUPLE: lambda-node expr temp-label ;
|
||||
TUPLE: apply-node func arg ;
|
||||
TUPLE: variable-node var ;
|
||||
|
||||
GENERIC: variable-eq?
|
||||
M: string variable-eq? ( var string -- bool ) = ;
|
||||
|
||||
M: lambda-node variable-eq? ( var lambda-node-pointer -- bool ) eq? ;
|
||||
|
||||
GENERIC: substitute
|
||||
M: lambda-node substitute ( expr var lambda-node -- )
|
||||
[ lambda-node-expr substitute ] keep [ set-lambda-node-expr ] keep ;
|
||||
|
||||
M: apply-node substitute ( expr var apply-node -- )
|
||||
[ [ apply-node-func substitute ] keep set-apply-node-func ] 3keep
|
||||
[ apply-node-arg substitute ] keep [ set-apply-node-arg ] keep ;
|
||||
|
||||
M: variable-node substitute ( expr var variable-node -- )
|
||||
#! ( variable-node == var ) ? expr | variable-node
|
||||
#! this could use multiple dispatch!
|
||||
[ variable-node-var variable-eq? ] keep swap ( expr variable-node cond )
|
||||
[ swap ] unless drop ;
|
||||
|
||||
: beta-reduce ( expr lambda-node -- reduced-expr )
|
||||
#! "pass" expr to the lambda-node, returning a reduced expression
|
||||
dup lambda-node-expr substitute ;
|
||||
|
||||
GENERIC: reduce
|
||||
#! TODO: eta reduction
|
||||
M: lambda-node reduce ( lambda-node -- reduced-lambda-node )
|
||||
[ [ lambda-node-expr reduce ] keep set-lambda-node-expr ] keep ;
|
||||
|
||||
M: apply-node reduce ( apply-node -- reduced-apply-node )
|
||||
#! beta-reduction
|
||||
[ [ apply-node-func reduce ] keep set-apply-node-func ] keep
|
||||
[ [ apply-node-arg reduce ] keep set-apply-node-arg ] keep
|
||||
[ apply-node-func dup lambda-node? ] keep swap
|
||||
[ apply-node-arg swap beta-reduce reduce ] [ nip ] if ;
|
||||
|
||||
M: variable-node reduce ( -- ) ;
|
||||
|
||||
GENERIC: expr>string
|
||||
M: lambda-node expr>string ( available-vars lambda-node -- string )
|
||||
[ uncons swap ] swap slip [ set-lambda-node-temp-label ] 2keep
|
||||
[ swap ] swap slip lambda-node-expr expr>string swap
|
||||
[ "(" , , ". " , , ")" , ] { } make concat ;
|
||||
|
||||
M: apply-node expr>string ( available-vars apply-node -- string )
|
||||
[ apply-node-arg expr>string ] 2keep apply-node-func expr>string
|
||||
[ "(" , , " " , , ")" , ] { } make concat ;
|
||||
|
||||
M: variable-node expr>string ( available-vars variable-node -- string )
|
||||
nip variable-node-var dup string? [ lambda-node-temp-label ] unless ;
|
||||
|
||||
GENERIC: replace-names
|
||||
M: lambda-node replace-names ( names-hash l-node -- node )
|
||||
[ lambda-node-expr replace-names ] keep [ set-lambda-node-expr ] keep ;
|
||||
|
||||
M: apply-node replace-names ( names-hash l-node -- node )
|
||||
[
|
||||
[ apply-node-func replace-names ] keep set-apply-node-func
|
||||
] 2keep [ apply-node-arg replace-names ] keep [ set-apply-node-arg ] keep ;
|
||||
|
||||
M: variable-node replace-names ( names-hash variable-node -- node )
|
||||
[ variable-node-var swap hash ] keep over not [ nip ] [ drop ] if ;
|
||||
|
||||
C: lambda-node ( var expr implicit-empty-lambda-node -- lambda-node )
|
||||
#! store the expr, replacing every occurence of var with
|
||||
#! a pointer to this lambda-node
|
||||
[ <variable-node> -rot substitute ] keep [ set-lambda-node-expr ] keep ;
|
||||
|
||||
: <id>
|
||||
#! parses an identifier (string for now)
|
||||
#! TODO: do we need to enter it into a symbol table?
|
||||
<letter> <alphanumeric> <*> <:&> [ concat <variable-node> ] <@ ;
|
||||
|
||||
: <name>
|
||||
#! parses a name, which is used in replacement
|
||||
<ALPHANUMERIC> <+> [ concat ] <@ ;
|
||||
|
||||
DEFER: <expr>
|
||||
: <lambda>
|
||||
#! parses (<id>.<expr>), the "lambda" expression
|
||||
#! all occurences of <id> are replaced with a pointer to this
|
||||
#! lambda expression.
|
||||
"(" token <id> sp &> "." token sp <&
|
||||
<expr> sp <&> ")" token sp <&
|
||||
[ [ first variable-node-var ] keep second <lambda-node> ] <@ ;
|
||||
|
||||
: <apply>
|
||||
#! parses (<expr> <expr>), the function application
|
||||
"(" token <expr> sp &> <expr> sp <&> ")" token sp <&
|
||||
[ [ first ] keep second <apply-node> ] <@ ;
|
||||
|
||||
: <expr>
|
||||
[ <id> call ] [ <lambda> call ] [ <apply> call ] <|> <|>
|
||||
<name> [ <variable-node> ] <@ <|> ;
|
||||
|
||||
: <line>
|
||||
":" token <name> &> <expr> sp <&> "OK" succeed <expr> <&>
|
||||
<|> ;
|
||||
|
||||
: lambda-parse
|
||||
#! debug word to parse this <expr> and print the result
|
||||
<line> some call ;
|
||||
|
||||
#! every expression has a canonical representation of this form
|
||||
: bound-variables-list ( -- lazy-list ) 65 lfrom [ ch>string ] lmap ;
|
||||
|
||||
: lambda-print ( name expr -- )
|
||||
bound-variables-list swap expr>string ":" swap append append print flush ;
|
||||
TUPLE: linterp names reps ;
|
||||
: (lint>string) ( linterp expr -- linterp )
|
||||
bound-variables-list swap expr>string over dupd linterp-reps hash
|
||||
", " join ":" append swap append "=> " swap append ;
|
||||
|
||||
: update-names ( names-hash name expr -- names-hash )
|
||||
swap rot [ set-hash ] keep ;
|
||||
|
||||
#! Interpreter: listen-reduce-print loop
|
||||
: lint ( names-hash -- new-names-hash )
|
||||
readln [ "." = ] keep swap [ drop ] [
|
||||
lambda-parse [ first ] keep second pick swap replace-names reduce
|
||||
[ lambda-print ] 2keep update-names lint
|
||||
] if ;
|
||||
C: linterp ( names-hash )
|
||||
#! take a names hash, and generate the reverse lookup hash from it.
|
||||
#! TODO: make this really ugly code cleaner
|
||||
2dup set-linterp-names swap H{ } clone [ swap hash>alist
|
||||
[ [ first ] keep second bound-variables-list swap expr>string rot
|
||||
[ hash ] 2keep rot dup not [ drop rot { } swap add -rot ]
|
||||
[ >r rot r> swap add -rot ] if set-hash ] each-with ] keep
|
||||
swap [ set-linterp-reps ] keep ;
|
||||
|
||||
: lint-read ( -- input )
|
||||
readln [ "." = ] keep swap ;
|
||||
|
||||
: lint-eval ( linterp input -- linterp name expr )
|
||||
lambda-parse [ first ] keep second pick linterp-names swap replace-names
|
||||
evaluate ;
|
||||
|
||||
: lint>string ( linterp name expr -- linterp )
|
||||
rot linterp-names -rot [ update-names ] keep [ <linterp> ] dip
|
||||
(lint>string) ;
|
||||
|
||||
: lint-print ( linterp name expr -- linterp )
|
||||
lint>string print flush ;
|
||||
|
||||
: lint-boot ( -- initial-names )
|
||||
H{ } clone ;
|
||||
H{ } clone <linterp> ;
|
||||
|
||||
: (lint) ( linterp -- linterp )
|
||||
lint-read [ drop ] [ lint-eval lint-print lint ] if ;
|
||||
|
||||
: lint ( -- linterp )
|
||||
lint-boot (lint) ;
|
||||
|
|
@ -1,4 +1,6 @@
|
|||
PROVIDE: lambda {
|
||||
"nodes.factor"
|
||||
"parser.factor"
|
||||
"lambda.factor"
|
||||
} {
|
||||
"test/lambda.factor"
|
||||
|
|
|
|||
|
|
@ -0,0 +1,120 @@
|
|||
#! A lambda expression manipulator, by Matthew Willis
|
||||
REQUIRES: lazy-lists ;
|
||||
USING: lazy-lists strings arrays hashtables
|
||||
sequences namespaces words kernel ;
|
||||
|
||||
IN: kernel
|
||||
: dip swap slip ; inline
|
||||
|
||||
IN: lambda
|
||||
|
||||
TUPLE: lambda-node expr temp-label ;
|
||||
TUPLE: apply-node func arg ;
|
||||
TUPLE: variable-node var ;
|
||||
|
||||
DEFER: substitute
|
||||
C: lambda-node ( var expr implicit-empty-lambda-node -- lambda-node )
|
||||
#! store the expr, replacing every occurence of var with
|
||||
#! a pointer to this lambda-node
|
||||
[ <variable-node> -rot substitute ] keep
|
||||
[ set-lambda-node-expr ] keep ;
|
||||
|
||||
GENERIC: (post-order)
|
||||
#! Traverses the tree while executing a word in post-order
|
||||
M: lambda-node (post-order) ( data-array word lambda-node -- node )
|
||||
[ [ lambda-node-expr (post-order) ] keep set-lambda-node-expr ] 3keep
|
||||
swap execute ;
|
||||
|
||||
M: apply-node (post-order) ( data-array word apply-node -- node )
|
||||
[ [ apply-node-func (post-order) ] keep set-apply-node-func ] 3keep
|
||||
[ [ apply-node-arg (post-order) ] keep set-apply-node-arg ] 3keep
|
||||
swap execute ;
|
||||
|
||||
M: variable-node (post-order) ( data-array word variable-node -- node )
|
||||
swap execute ;
|
||||
|
||||
: post-order ( node data-array word -- node )
|
||||
#! the public face of post-order.
|
||||
rot (post-order) ;
|
||||
|
||||
GENERIC: (clone-node)
|
||||
#! (clone-node) uses both pre and post orders.
|
||||
#! We could factor out (pre-post-order) and have both clone
|
||||
#! and the existing post-order invoke that
|
||||
M: lambda-node (clone-node) ( lambda-node -- node )
|
||||
dup clone
|
||||
[ lambda-node-expr (clone-node) ] keep [ set-lambda-node-expr ] keep
|
||||
[ dup <variable-node> -rot lambda-node-expr substitute ] keep
|
||||
[ set-lambda-node-expr ] keep ;
|
||||
|
||||
M: apply-node (clone-node) ( apply-node -- node )
|
||||
clone
|
||||
[ apply-node-func (clone-node) ] keep [ set-apply-node-func ] keep
|
||||
[ apply-node-arg (clone-node) ] keep [ set-apply-node-arg ] keep ;
|
||||
|
||||
M: variable-node (clone-node) ( variable-node -- node )
|
||||
clone ;
|
||||
|
||||
GENERIC: variable-eq?
|
||||
M: string variable-eq? ( var string -- bool ) = ;
|
||||
|
||||
M: lambda-node variable-eq? ( var lambda-node-pointer -- bool ) eq? ;
|
||||
|
||||
GENERIC: (substitute)
|
||||
M: lambda-node (substitute) ( data-array lambda-node -- ) nip ;
|
||||
|
||||
M: apply-node (substitute) ( data-array apply-node -- ) nip ;
|
||||
|
||||
M: variable-node (substitute) ( data-array variable-node -- )
|
||||
#! ( variable-node == var ) ? expr | variable-node
|
||||
#! this could use multiple dispatch!
|
||||
[ [ first ] keep second ] dip ( expr var variable-node -- )
|
||||
[ variable-node-var variable-eq? ] keep swap ( expr variable-node cond )
|
||||
[ swap ] unless drop ;
|
||||
|
||||
: substitute ( expr var node -- node )
|
||||
-rot 2array \ (substitute) post-order ;
|
||||
|
||||
: beta-reduce ( expr lambda-node -- expr )
|
||||
#! "pass" expr to the lambda-node, returning a reduced expression
|
||||
(clone-node) dup lambda-node-expr substitute ;
|
||||
|
||||
GENERIC: (evaluate)
|
||||
DEFER: evaluate
|
||||
#! TODO: eta reduction
|
||||
M: lambda-node (evaluate) ( data-array lambda-node -- node ) nip ;
|
||||
|
||||
M: apply-node (evaluate) ( data-array apply-node -- node )
|
||||
#! beta-reduction
|
||||
nip [ apply-node-func dup lambda-node? ] keep swap
|
||||
[ apply-node-arg swap beta-reduce evaluate ] [ nip ] if ;
|
||||
|
||||
M: variable-node (evaluate) ( data-array variable-node -- node ) nip ;
|
||||
|
||||
: evaluate ( node -- node )
|
||||
{ } \ (evaluate) post-order ;
|
||||
|
||||
GENERIC: (replace-names)
|
||||
M: lambda-node (replace-names) ( names-hash l-node -- node ) nip ;
|
||||
|
||||
M: apply-node (replace-names) ( names-hash l-node -- node ) nip ;
|
||||
|
||||
M: variable-node (replace-names) ( names-hash variable-node -- node )
|
||||
[ variable-node-var swap hash ] keep over not
|
||||
[ nip ] [ drop (clone-node) ] if ;
|
||||
|
||||
: replace-names ( names-hash node -- node )
|
||||
swap \ (replace-names) post-order ;
|
||||
|
||||
GENERIC: expr>string
|
||||
M: lambda-node expr>string ( available-vars lambda-node -- string )
|
||||
[ uncons swap ] dip [ set-lambda-node-temp-label ] 2keep
|
||||
[ swap ] dip lambda-node-expr expr>string swap
|
||||
[ "(" , , ". " , , ")" , ] { } make concat ;
|
||||
|
||||
M: apply-node expr>string ( available-vars apply-node -- string )
|
||||
[ apply-node-arg expr>string ] 2keep apply-node-func expr>string
|
||||
[ "(" , , " " , , ")" , ] { } make concat ;
|
||||
|
||||
M: variable-node expr>string ( available-vars variable-node -- string )
|
||||
nip variable-node-var dup string? [ lambda-node-temp-label ] unless ;
|
||||
|
|
@ -0,0 +1,68 @@
|
|||
#! A parser for lambda expressions, by Matthew Willis
|
||||
#! The grammar in BNF is:
|
||||
#! <expr> ::= <id>
|
||||
#! <expr> ::= <name>
|
||||
#! <expr> ::= (<id> . <expr>)
|
||||
#! <expr> ::= (<expr> <expr>)
|
||||
#! <line> ::= <expr>
|
||||
#! <line> ::= <name> : <expr>
|
||||
|
||||
REQUIRES: parser-combinators ;
|
||||
USING: parser-combinators strings sequences kernel ;
|
||||
|
||||
IN: lambda
|
||||
|
||||
: <letter>
|
||||
#! parses an uppercase or lowercase letter
|
||||
[ letter? ] satisfy [ ch>string ] <@ ;
|
||||
|
||||
: <LETTER>
|
||||
#! parses an uppercase or lowercase letter
|
||||
[ LETTER? ] satisfy [ ch>string ] <@ ;
|
||||
|
||||
: <number>
|
||||
#! parses a number
|
||||
[ digit? ] satisfy [ ch>string ] <@ ;
|
||||
|
||||
: <alphanumeric>
|
||||
#! parses an alphanumeral
|
||||
<letter> <number> <|> ;
|
||||
|
||||
: <ALPHANUMERIC>
|
||||
#! parses an alphanumeral
|
||||
<LETTER> <number> <|> ;
|
||||
|
||||
: <id>
|
||||
#! parses an identifier (string for now)
|
||||
#! TODO: do we need to enter it into a symbol table?
|
||||
<letter> <alphanumeric> <*> <&:> [ concat <variable-node> ] <@ ;
|
||||
|
||||
: <name>
|
||||
#! parses a name, which is used in replacement
|
||||
<ALPHANUMERIC> <+> [ concat ] <@ ;
|
||||
|
||||
DEFER: <expr>
|
||||
: <lambda>
|
||||
#! parses (<id>.<expr>), the "lambda" expression
|
||||
#! all occurences of <id> are replaced with a pointer to this
|
||||
#! lambda expression.
|
||||
"(" token <id> sp &> "." token sp <&
|
||||
<expr> sp <&> ")" token sp <&
|
||||
[ [ first variable-node-var ] keep second <lambda-node> ] <@ ;
|
||||
|
||||
: <apply>
|
||||
#! parses (<expr> <expr>), the function application
|
||||
"(" token <expr> sp &> <expr> sp <&> ")" token sp <&
|
||||
[ [ first ] keep second <apply-node> ] <@ ;
|
||||
|
||||
: <expr>
|
||||
[ <id> call ] [ <lambda> call ] [ <apply> call ] <|> <|>
|
||||
<name> [ <variable-node> ] <@ <|> ;
|
||||
|
||||
: <line>
|
||||
":" token <name> &> <expr> sp <&> "OK" succeed <expr> <&>
|
||||
<|> ;
|
||||
|
||||
: lambda-parse
|
||||
#! debug word to parse this <expr> and print the result
|
||||
<line> some call ;
|
||||
Loading…
Reference in New Issue