steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

bake: Bake quotations and vectors

db4
Eduardo Cavazos 2008-07-02 11:43:14 -05:00
parent a25254c7f4
commit 4e599f5d9c
1 changed files with 50 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

68
extra/bake/bake.factor
View File

@ -1,6 +1,6 @@
USING: kernel parser combinators sequences splitting quotations arrays macros
arrays.lib combinators.cleave combinators.conditional newfx ;
USING: kernel parser namespaces sequences quotations arrays vectors splitting
macros arrays.lib combinators.lib combinators.conditional newfx ;
IN: bake
@ -14,46 +14,78 @@ SYMBOL: @
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
DEFER: [bake-array]
DEFER: [bake]
: broil-element ( obj -- quot )
{
{ [ comma? ] [ drop [ >r ] ] }
{ [ array? ] [ [bake-array] [ >r ] append ] }
{ [ drop t ] [ [ >r ] prefix-on ] }
{ [ comma? ] [ drop [ >r ] ] }
{ [ sequence? ] [ [bake] [ >r ] append ] }
{ [ drop t ] [ [ >r ] prefix-on ] }
}
1cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [broil] ( array -- quot )
: constructor ( seq -- quot )
{
{ [ array? ] [ length [ narray ] prefix-on ] }
{ [ quotation? ] [ length [ ncurry ] prefix-on [ ] prefix ] }
{ [ vector? ] [ length [ narray >vector ] prefix-on ] }
}
1cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [broil] ( seq -- quot )
[ reverse [ broil-element ] map concat ]
[ length [ drop [ r> ] ] map concat ]
[ length [ narray ] prefix-on ]
[ length [ drop [ r> ] ] map concat ]
[ constructor ]
tri append append
>quotation ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [simmer] ( array -- quot )
SYMBOL: saved-sequence
: [connector] ( -- quot )
saved-sequence get quotation? [ [ compose ] ] [ [ append ] ] if ;
: [starter] ( -- quot )
saved-sequence get
{
{ [ quotation? ] [ drop [ [ ] ] ] }
{ [ array? ] [ drop [ { } ] ] }
{ [ vector? ] [ drop [ V{ } ] ] }
}
1cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [simmer] ( seq -- quot )
dup saved-sequence set
{ @ } split reverse
[ [ [bake-array] [ append ] append [ >r ] append ] map concat ]
[ length [ drop [ r> append ] ] map concat ]
[ [ [bake] [connector] append [ >r ] append ] map concat ]
[ length [ drop [ r> ] [connector] append ] map concat ]
bi
>r 2 head* [ >r ] append r> ! remove the last append
>r 1 invert-index pluck r> ! remove the last append/compose
[ { } ] swap append
[starter] prepend
append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [bake-array] ( array -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ;
MACRO: bake-array ( array -- quot ) [bake-array] ;
: [bake] ( seq -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: `{ \ } [ >array ] parse-literal \ bake-array parsed ; parsing
MACRO: bake ( seq -- quot ) [bake] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
: `V{ \ } [ >vector ] parse-literal \ bake parsed ; parsing
: `[ \ ] [ >quotation ] parse-literal \ bake parsed ; parsing