1 USING: accessors arrays fry kernel lexer make math.parser
2 models monads namespaces parser sequences
3 sequences.extras ui.frp.gadgets ui.frp.signals ui.gadgets
4 ui.gadgets.books ui.gadgets.tracks words ;
8 TUPLE: layout gadget size ; C: <layout> layout
9 TUPLE: placeholder < gadget members ;
10 : <placeholder> ( -- placeholder ) placeholder new V{ } clone >>members ;
12 : (remove-members) ( placeholder members -- ) [ [ model? ] filter swap parent>> model>> [ remove-connection ] curry each ]
13 [ nip [ gadget? ] filter [ unparent ] each ] 2bi ;
15 : remove-members ( placeholder -- ) dup members>> [ drop ] [ [ (remove-members) ] keep empty ] if-empty ;
16 : add-member ( obj placeholder -- ) over layout? [ [ gadget>> ] dip ] when members>> push ;
18 : , ( item -- ) make:, ;
19 : make* ( quot -- list ) { } make ; inline
21 ! Just take the previous mentioned placeholder and use it
22 ! If there is no previously mentioned placeholder, we're probably making a box, and will create the placeholder ourselves
24 : insertion-quot ( quot -- quot' ) make:building get [ placeholder? ] find-last nip [ <placeholder> dup , ] unless*
25 swap '[ [ _ , @ ] with-interface ] ;
27 SYNTAX: ,% scan string>number [ <layout> , ] curry over push-all ;
28 SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] over push-all ;
30 GENERIC: -> ( uiitem -- model )
31 M: gadget -> dup , output-model ;
34 : <spacer> ( -- ) <gadget> 1 <layout> , ;
36 : add-layout ( track layout -- track ) [ gadget>> ] [ size>> ] bi track-add ; inline
37 : layouts ( sized? gadgets -- layouts ) [ [ gadget? ] [ layout? ] bi or ] filter swap
38 [ [ dup layout? [ f <layout> ] unless ] map ]
39 [ [ dup gadget? [ gadget>> ] unless ] map ] if ;
40 : make-layout ( building sized? -- models layouts ) [ swap layouts ] curry
41 [ make* [ [ model? ] filter ] ] dip bi ; inline
42 : <box> ( gadgets type -- track )
43 [ t make-layout ] dip <track>
44 swap [ add-layout ] each
45 swap [ <collection> >>model ] unless-empty ; inline
46 : <hbox> ( gadgets -- track ) horizontal <box> ; inline
47 : <vbox> ( gadgets -- track ) vertical <box> ; inline
49 : make-book ( models gadgets model -- book ) <book> swap [ "No models in books" throw ] unless-empty ;
50 : <frp-book> ( quot: ( -- model ) -- book ) f make-layout rot 0 >>value make-book ; inline
51 : <frp-book*> ( quot -- book ) f make-layout f make-book ; inline
53 SYNTAX: $ CREATE-WORD <placeholder>
54 [ [ , ] curry (( -- )) define-declared "$" expect ]
55 [ [ , ] curry ] bi over push-all ;
57 : insert-gadget ( number parent gadget -- ) -rot [ but-last insert-nth ] change-children drop ;
58 : insert-size ( number parent size -- ) -rot [ but-last insert-nth ] change-sizes drop ;
59 : insertion-point ( gadget placeholder -- number parent gadget ) dup parent>> [ children>> index ] keep rot ;
61 GENERIC# (insert-item) 1 ( item location -- )
62 M: gadget (insert-item) dup parent>> track? [ [ f <layout> ] dip (insert-item) ]
63 [ insertion-point [ add-gadget ] keep insert-gadget ] if ;
64 M: layout (insert-item) insertion-point [ add-layout ] keep [ gadget>> insert-gadget ] [ size>> insert-size ] 3bi ;
65 M: model (insert-item) parent>> dup book? [ "No models in books" throw ]
66 [ dup model>> dup collection? [ nip swap add-connection ] [ drop [ 1array <collection> ] dip (>>model) ] if ] if ;
67 : insert-item ( item location -- ) [ dup get [ drop ] [ remove-members ] if ] [ on ] [ ] tri
68 [ add-member ] 2keep (insert-item) ;
70 : insert-items ( makelist -- ) t swap [ dup placeholder? [ nip ] [ over insert-item ] if ] each drop ;
72 : with-interface ( quot -- ) make* [ insert-items ] with-scope ; inline
74 M: model >>= [ swap insertion-quot <action> ] curry ;