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

bake: New oven: convention, broil, or simmer

db4
Eduardo Cavazos 2008-06-30 10:31:12 -05:00
parent 915b82a19d
commit 6bf04eb1ee
1 changed files with 45 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

86
extra/bake/bake.factor
View File

@ -1,61 +1,65 @@
USING: kernel parser namespaces quotations arrays vectors strings USING: kernel parser combinators sequences splitting quotations arrays macros
sequences assocs classes.tuple math combinators ; arrays.lib combinators.cleave newfx dns.util ;
IN: bake IN: bake
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: insert-quot expr ; MACRO: 1cond ( tbl -- )
[ [ 1st [ dup ] prepend ] [ 2nd ] bi {2} ] map
C: <insert-quot> insert-quot [ cond ] prefix-on ;
: ,[ \ ] [ >quotation <insert-quot> ] parse-literal ; parsing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: splice-quot expr ; SYMBOL: ,
SYMBOL: @
C: <splice-quot> splice-quot : comma? ( obj -- ? ) , = ;
: atsym? ( obj -- ? ) @ = ;
: %[ \ ] [ >quotation <splice-quot> ] parse-literal ; parsing
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: ,u ( seq -- seq ) unclip building get push ; DEFER: [bake-array]
: broil-element ( obj -- quot )
{
{ [ comma? ] [ drop [ >r ] ] }
{ [ array? ] [ [bake-array] [ >r ] append ] }
{ [ drop t ] [ [ >r ] prefix-on ] }
}
1cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: exemplar : [broil] ( array -- quot )
[ reverse [ broil-element ] map concat ]
: reset-building ( -- ) 1024 <vector> building set ; [ length [ drop [ r> ] ] map concat ]
[ length [ narray ] prefix-on ]
: save-exemplar ( seq -- seq ) dup exemplar set ; tri append append
>quotation ;
: finish-baking ( -- seq ) building get exemplar get like ;
DEFER: bake
: bake-item ( item -- )
{ { [ dup \ , = ] [ drop , ] }
{ [ dup \ % = ] [ drop % ] }
{ [ dup \ ,u = ] [ drop ,u ] }
{ [ dup insert-quot? ] [ insert-quot-expr call , ] }
{ [ dup splice-quot? ] [ splice-quot-expr call % ] }
{ [ dup integer? ] [ , ] }
{ [ dup string? ] [ , ] }
{ [ dup tuple? ] [ tuple>array bake >tuple , ] }
{ [ dup assoc? ] [ [ >alist bake ] keep assoc-like , ] }
{ [ dup sequence? ] [ bake , ] }
{ [ t ] [ , ] } }
cond ;
: bake-items ( seq -- ) [ bake-item ] each ;
: bake ( seq -- seq )
[ reset-building save-exemplar bake-items finish-baking ] with-scope ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing : [simmer] ( array -- quot )
{ @ } split reverse
[ [ [bake-array] [ append ] append [ >r ] append ] map concat ]
[ length [ drop [ r> append ] ] map concat ]
bi
>r 2 head* [ >r ] append r> ! remove the last append
[ { } ] swap append
append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [bake-array] ( array -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ;
MACRO: bake-array ( array -- quot ) [bake-array] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: `{ \ } [ >array ] parse-literal \ bake-array parsed ; parsing