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

frp.layout works with books

db4
Sam Anklesaria 2009-06-07 17:03:32 -05:00
parent 5b4466161c
commit e8cbb5b228
2 changed files with 24 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
extra/persistency/persistency.factor
View File

@ -6,11 +6,12 @@ IN: persistency
TUPLE: persistent id ; TUPLE: persistent id ;
UNION: bool word POSTPONE: f ; UNION: bool word POSTPONE: f ;
PREDICATE: short-string < string length 100 <= ; UNION: short-string string ;
: db-ize ( class -- db-class ) { : db-ize ( class -- db-class ) {
{ bool [ BOOLEAN ] } { bool [ BOOLEAN ] }
{ string [ TEXT ] }
{ short-string [ { VARCHAR 100 } ] } { short-string [ { VARCHAR 100 } ] }
{ string [ TEXT ] }
{ float [ DOUBLE ] } { float [ DOUBLE ] }
{ timestamp [ TIMESTAMP ] } { timestamp [ TIMESTAMP ] }
{ fixnum [ INTEGER ] } { fixnum [ INTEGER ] }

33
extra/ui/frp/layout/layout.factor
View File

@ -16,30 +16,39 @@ M: model -> dup , ;
: <spacer> ( -- ) <gadget> 1 <layout> , ; : <spacer> ( -- ) <gadget> 1 <layout> , ;
SYMBOL: wordnames SYMBOL: wordnames
: layouts ( gadgets -- layouts ) [ [ gadget? ] [ layout? ] bi or ] filter : insert-layout ( track layout -- track ) [ gadget>> ] [ size>> ] bi track-add ; inline
[ dup layout? [ f <layout> ] unless ] map ; : layouts ( sized? gadgets -- layouts ) [ [ gadget? ] [ layout? ] bi or ] filter swap
[ [ dup layout? [ f <layout> ] unless ] map ] when ;
: make-layout ( building sized? -- models words layouts ) [ swap layouts ] curry
[ { } make [ [ model? ] filter ] [ [ word? ] filter ] ] dip tri ; inline
: handle-words ( words gadget -- gadget ) tuck
[ [ swap 2array ] curry wordnames get swap change-at ] curry each ;
: <box> ( gadgets type -- track ) : <box> ( gadgets type -- track )
[ { } make [ [ model? ] filter ] [ [ word? ] filter ] [ layouts ] tri ] dip <track> [ t make-layout ] dip <track>
swap [ [ gadget>> ] [ size>> ] bi track-add ] each swap [ insert-layout ] each
tuck [ [ swap 2array ] curry wordnames get swap change-at ] curry each handle-words
swap [ <product> >>model ] unless-empty ; inline swap [ <product> >>model ] unless-empty ; inline
: <hbox> ( gadgets -- track ) horizontal <box> ; inline : <hbox> ( gadgets -- track ) horizontal <box> ; inline
: <vbox> ( gadgets -- track ) vertical <box> ; inline : <vbox> ( gadgets -- track ) vertical <box> ; inline
: <frp-book> ( gadgets -- book ) { } make [ gadget>> ] map f <book> ; inline : <frp-book> ( gadgets -- book ) f make-layout f <book> handle-words ; inline
SYNTAX: $ CREATE-WORD dup [ , ] curry (( -- )) define-declared "$" expect SYNTAX: $ CREATE-WORD dup [ , ] curry (( -- )) define-declared "$" expect
word [ [ building get length swap wordnames get set-at ] [ , ] bi ] curry over push-all ; word [ [ building get length swap wordnames get set-at ] [ , ] bi ] curry over push-all ;
: insert-gadget ( number parent gadget -- ) -rot [ but-last insert-nth ] change-children drop ;
GENERIC# insert-item 1 ( item location -- ) GENERIC# insert-item 1 ( item location -- )
M: gadget insert-item [ f <layout> ] dip insert-item ; M: gadget insert-item dup first book? [ first2 spin [ add-gadget ] keep insert-gadget ]
M: layout insert-item first2 spin [ [ gadget>> ] [ size>> ] bi track-add ] keep gadget>> [ [ f <layout> ] dip insert-item ] if ;
-rot [ but-last insert-nth ] change-children drop ; M: layout insert-item first2 spin [ insert-layout ] keep gadget>> insert-gadget ;
M: model insert-item first model>> swap add-connection ; M: model insert-item dup first book? [ "Books can't contain models" throw ]
[ first model>> swap add-connection ] if ;
: insert-items ( makelist -- ) f swap [ dup word? : insert-items ( makelist -- ) f swap [ dup word?
[ nip ] [ over [ wordnames get at insert-item ] [ wordnames get [ first2 1 + 2array ] change-at ] bi ] if [ nip ] [
] each drop ; over [ wordnames get at insert-item ] [ wordnames get [ first2 1 + 2array ] change-at ] bi
] if ] each drop ;
: with-interface ( quot: ( -- gadget ) -- gadget ) H{ } clone wordnames : with-interface ( quot: ( -- gadget ) -- gadget ) H{ } clone wordnames
[ { } make insert-items ] with-variable ; inline [ { } make insert-items ] with-variable ; inline