# Paste: Almost XY in factor

Author: doublec factor Sat, 7 Feb 2009 03:57:01
Plain Text |
```! Copyright (C) 2008 Chris Double.
IN: xy
USING:
accessors
arrays
assocs
combinators
io
kernel
locals
make
math
math.parser
namespaces
peg
peg.ebnf
sequences
strings
;

:: linrec
( if-quot:    ( -- ? )
then-quot:  ( -- )
else1-quot: ( -- )
else2-quot: ( -- )
-- )
if-quot call [
then-quot call
] [
else1-quot call
if-quot then-quot else1-quot else2-quot linrec
else2-quot call
] if ; inline recursive

:: unfold
( seed
p:   ( seed -- ? )
f:   ( seed -- o )
g:   ( seed -- seed' )
-- )
[
seed [ dup p call ] [ ] [ dup f call , g call ] [ ] linrec
] { } make nip ; inline

TUPLE: token-number      value ;
TUPLE: token-word        value ;
TUPLE: token-string      value ;

EBNF: tokenize-xy
Digit             = [0-9]
Digits            = Digit+
Number            = Digits &(Space | Punctuation | !(.)) => [[ string>number token-number boa ]]
Letter            = [a-zA-Z]
SingleLineComment = "//" (!("\n") .)* "\n" => [[ ignore ]]
MultiLineComment  = "/*" (!("*/") .)* "*/" => [[ ignore ]]
Space             = " " | "\t" | "\r" | "\n" | SingleLineComment | MultiLineComment
Spaces            = Space* => [[ ignore ]]

Punctuation       = "(" | ")" | "[" | "]" | ";"
String            = '"' (!('"') .) '"' => [[ second >string token-string boa ]]
Word              = !(String) (!(Space | Punctuation) .)+ => [[ >string token-word boa ]]
Tok               = Spaces (Number | Word | String | Punctuation )
Toks              = Tok* Spaces
;EBNF

TUPLE: ast-number      value ;
TUPLE: ast-word        value ;
TUPLE: ast-string      value ;
TUPLE: ast-quot-open         ;
TUPLE: ast-quot-close        ;
TUPLE: ast-list-open         ;
TUPLE: ast-list-close        ;
TUPLE: ast-list        value ;
TUPLE: ast-quot        value ;
TUPLE: ast-define            ;
TUPLE: ast-define-start      ;

GENERIC: (@pprint) ( ast -- )
M: ast-number (@pprint) ( ast -- ) value>> # ;
M: ast-word  (@pprint) ( ast -- ) value>> % ;
M: ast-string (@pprint) ( ast -- ) CHAR: " , value>> % CHAR: " , ;
M: ast-quot-open (@pprint) ( ast -- ) drop CHAR: [ , ;
M: ast-quot-close (@pprint) ( ast -- ) drop CHAR: ] , ;
M: ast-list-open (@pprint) ( ast -- ) drop CHAR: ( , ;
M: ast-list-close (@pprint) ( ast -- ) drop CHAR: ) , ;
M: ast-list (@pprint) ( ast -- ) CHAR: ( , " " % value>> [ (@pprint) " " % ] each CHAR: ) , ;
M: ast-quot (@pprint) ( ast -- ) CHAR: [ , " " % value>> [ (@pprint) " " % ] each CHAR: ] , ;
M: ast-define (@pprint) ( ast -- ) drop CHAR: ; , ;
M: ast-define-start (@pprint) ( ast -- ) drop CHAR: ; , ;

: @pprint ( ast -- string )
[ (@pprint) ] "" make ;

EBNF: parse-xy
tokenizer   = <foreign tokenize-xy Tok>
Word        = . ?[ token-word? ]?        => [[ value>> ast-word boa ]]
Number      = . ?[ token-number? ]?      => [[ value>> ast-number boa ]]
String      = . ?[ token-string? ]?      => [[ value>> ast-string boa ]]
QuotOpen    = "["                        => [[ drop ast-quot-open boa ]]
QuotClose   = "]"                        => [[ drop ast-quot-close boa ]]
ListOpen    = "("                        => [[ drop ast-list-open boa ]]
ListClose   = ")"                        => [[ drop ast-list-close boa ]]
Define      = ";"                        => [[ drop ast-define boa ]]

Sequence    = QuotOpen | QuotClose | ListOpen | ListClose
XY          = (Word | Number | String | Sequence | Define)+
;EBNF

TUPLE: XY env x y ;

:: y-empty? ( xy -- ? )
xy y>> empty? ;

:: y-pop ( xy -- xy y )
xy env>> xy x>> xy y>> unclip [ XY boa ] dip ;

:: y-push ( xy y -- xy )
xy env>> xy x>> xy y>> y prefix XY boa ;

:: y-pop-tail ( xy -- xy y )
xy env>> xy x>> xy y>> 1 cut* first [ XY boa ] dip ;

:: y-compose ( xy seq -- xy )
xy env>> xy x>> seq xy y>> append XY boa ;

:: x-push ( xy x -- xy )
xy env>> xy x>> x suffix xy y>> XY boa ;

:: y-push-tail ( xy y -- xy )
xy env>> xy x>> xy y>>  y suffix XY boa ;

:: x-pop ( xy -- xy x )
xy env>> xy x>> 1 cut* first [ xy y>> XY boa ] dip ;

:: x-pop2 ( xy -- xy x1 x2 )
xy env>> xy x>> 2 cut* first2 [ xy y>> XY boa ] 2dip ;

SYMBOL: foo
SYMBOL: ->
SYMBOL: <-
SYMBOL: =>
SYMBOL: <=
SYMBOL: xy/
SYMBOL: xy\

: (x@eval) ( xy -- xy )
y-pop {
{ [ dup \ xy/ = ] [ drop x-pop y-compose ] }
{ [ dup \ xy\ = ] [ drop y-pop x-push ] }
{ [ dup \ -> = ] [ drop x-pop >>y ] }
{ [ dup \ <- = ] [ drop x-pop >>x ] }
{ [ dup \ => = ] [ drop x-pop y-push-tail ] }
{ [ dup \ <= = ] [ drop y-pop-tail x-push ] }
{ [ dup \ * = ]  [ drop x-pop2 * x-push ] }
{ [ dup \ + = ]  [ drop x-pop2 + x-push ] }
{ [ dup foo = ]  [ drop { 1 + foo } y-compose ] }
[ x-push ]
} cond ;

GENERIC: (@eval) ( xy v -- xy )
M: object (@eval) ( xy ast-number -- xy )
x-push ;

:: quot-active? ( xy -- ? )
xy x>> [ dup ast-quot-open? swap ast-define-start? or ] find-last nip ;

:: @eval-word ( xy ast-word -- xy )
ast-word value>> {
{ [ dup "`" = ]  [ drop xy x-pop dup ast-list? over ast-quot? or [ value>> first ] [ 1array ast-list boa ] if x-push ] }
{ [ dup "=>" = ] [ drop xy x-pop y-push-tail ] }
{ [ dup "<=" = ] [ drop xy y-pop-tail x-push ] }
{ [ dup "->" = ] [ drop xy x-pop value>> >>y ] }
{ [ dup "<-" = ] [ drop xy x-pop >>x ] }
{ [ dup "\\" = ] [ drop xy y-pop x-push ] }
{ [ dup "/"  = ] [ drop xy x-pop value>> y-compose ] }
{ [ dup "+" = ] [ drop xy x-pop2 [ value>> ] bi@ + ast-number boa x-push ] }
{ [ dup "-" = ] [ drop xy x-pop2 [ value>> ] bi@ - ast-number boa x-push ] }
{ [ dup "*" = ] [ drop xy x-pop2 [ value>> ] bi@ * ast-number boa x-push ] }
[ xy env>> at [ xy swap y-compose ] [ xy ast-word x-push ] if* ]
} cond ;

M:: ast-word (@eval) ( xy ast-word -- xy )
ast-word value>> {
{ [ dup "\\" = ] [ drop xy y-pop x-push ] }
{ [ dup "/" = ] [ drop xy x-pop dup ast-word? [ dup value>> xy env>> at [ nip ] when* ] [ value>> ] if y-compose ] }
[  drop xy quot-active? [ xy ast-word x-push ] [ xy ast-word @eval-word ] if ]
} cond ;

M:: ast-quot-close (@eval) ( xy ast-quot-close -- xy )
xy x>> [ ast-quot-open? ] find-last [
xy env>> xy x>> rot cut 1 tail ast-quot boa xy y>> swap prefix XY boa
] [
drop xy ast-quot-close x-push
] if ;

M:: ast-list-close (@eval) ( xy ast-quot-close -- xy )
xy x>> [ ast-list-open? ] find-last [
xy env>> xy x>> rot cut 1 tail ast-list boa xy y>> swap prefix XY boa
] [
"mismatched start/end markers" throw
] if ;

:: @eval-ast-define ( index env x y -- xy )
x index cut 1 tail unclip value>> env clone [ set-at ] keep swap y XY boa ;

M:: ast-define (@eval) ( xy ast-define -- xy )
xy x>> [ ast-define-start? ] find-last [
xy [ env>> ] [ x>> ] [ y>> ] tri @eval-ast-define
] [
drop xy ast-define-start boa x-push
] if ;

: @eval1 ( xy -- xy )
y-pop (@eval) ;

: @eval ( xy -- xy )
[ dup y-empty? ] [ ] [ @eval1 ] [ ] linrec ;

: default-env ( -- env )
[

] H{ } make-assoc ;

: xy ( string -- xy )
parse-xy [ default-env { } ] dip XY boa ;

: @step ( xy -- xy )
@eval1 dup [ x>> ast-list boa @pprint write " -> " write ] [ y>> ast-quot boa @pprint print ] bi ; ```

Author: tylerg factor Thu, 12 Feb 2009 04:58:37
Plain Text |
```! cool! Also I'm stealing these unfold and linrec words for my utility file.
! But couldn't you have written the matching much simpler using "case" instead of "cond" ?

SYMBOLS: foo
->
<-
=>
<=
xy/
xy\ ;

: (x@eval) ( xy -- xy )
y-pop {
{ xy/  [ x-pop y-compose ] }
{ xy\  [ y-pop x-push ] }
{ ->  [ x-pop >>y ] }
{ <-  [ x-pop >>x ] }
{ =>  [ x-pop y-push-tail ] }
{ <=  [ y-pop-tail x-push ] }
{ *  [ x-pop2 * x-push ] }
{ +  [ x-pop2 + x-push ] }
{ foo   [ { 1 + foo } y-compose ] }
[ x-push ]
} case ;

:: @eval-word ( xy ast-word -- xy )
ast-word value>> {
{ [ dup "`" = ]  [ drop xy x-pop dup ast-list? over ast-quot? or [ value>> first ] [ 1array ast-list boa ] if x-push ] }
{ "=>" [ xy x-pop y-push-tail ] }
{ "<=" [ xy y-pop-tail x-push ] }
{ "->" [ xy x-pop value>> >>y ] }
{ "<-" [ xy x-pop >>x ] }
{ "\\" [ xy y-pop x-push ] }
{ "/" [ xy x-pop value>> y-compose ] }
{ "+" [ xy x-pop2 [ value>> ] bi@ + ast-number boa x-push ] }
{ "-"[ xy x-pop2 [ value>> ] bi@ - ast-number boa x-push ] }
{ "*" [ xy x-pop2 [ value>> ] bi@ * ast-number boa x-push ] }
[ xy env>> at [ xy swap y-compose ] [ xy ast-word x-push ] if* ]
} case ;
```