extra/ui/frp/layout/layout.factor

   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 ;
   5 QUALIFIED: make
   6 IN: ui.frp.layout
   7
   8 TUPLE: layout gadget size ; C: <layout> layout
   9 TUPLE: placeholder < gadget members ;
  10 : <placeholder> ( -- placeholder ) placeholder new V{ } clone >>members ;
  11
  12 : (remove-members) ( placeholder members -- ) [ [ model? ] filter swap parent>> model>> [ remove-connection ] curry each ]
  13     [ nip [ gadget? ] filter [ unparent ] each ] 2bi ;
  14
  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 ;
  17
  18 : , ( item -- ) make:, ;
  19 : make* ( quot -- list ) { } make ; inline
  20
  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
  23 DEFER: with-interface
  24 : insertion-quot ( quot -- quot' ) make:building get [ placeholder? ] find-last nip [ <placeholder> dup , ] unless*
  25     swap '[ [ _ , @ ] with-interface ] ;
  26
  27 SYNTAX: ,% scan string>number [ <layout> , ] curry over push-all ;
  28 SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] over push-all ;
  29
  30 GENERIC: -> ( uiitem -- model )
  31 M: gadget -> dup , output-model ;
  32 M: model -> dup , ;
  33
  34 : <spacer> ( -- ) <gadget> 1 <layout> , ;
  35
  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 [ <|> >>model ] unless-empty ; inline
  46 : <hbox> ( gadgets -- track ) horizontal <box> ; inline
  47 : <vbox> ( gadgets -- track ) vertical <box> ; inline
  48
  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
  52
  53 SYNTAX: $ CREATE-WORD <placeholder>
  54     [ [ , ] curry (( -- )) define-declared "$" expect ]
  55     [ [ , ] curry ] bi over push-all ;
  56
  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 ;
  60
  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 |? [ nip swap add-connection ] [ drop [ 1array <|> ] dip (>>model) ] if ] if ;
  67 : insert-item ( item location -- ) [ dup get [ drop ] [ remove-members ] if ] [ on ] [ ] tri
  68     [ add-member ] 2keep (insert-item) ;
  69
  70 : insert-items ( makelist -- ) t swap [ dup placeholder? [ nip ] [ over insert-item ] if ] each drop ;
  71
  72 : with-interface ( quot -- ) make* [ insert-items ] with-scope ; inline
  73
  74 M: model >>= [ swap insertion-quot <action> ] curry ;
  75 ! Temporary places should be cleared at insertion, not on mention