unmaintained/ui/gadgets/layout/layout.factor

   1 USING: accessors assocs arrays fry kernel lexer make math.parser
   2 models monads namespaces parser sequences
   3 sequences.extras models.combinators ui.gadgets
   4 ui.gadgets.tracks words ui.gadgets.controls ;
   5 QUALIFIED: make
   6 QUALIFIED-WITH: ui.gadgets.books book
   7 IN: ui.gadgets.layout
   8
   9 SYMBOL: templates
  10 TUPLE: layout gadget size ; C: <layout> layout
  11 TUPLE: placeholder < gadget members ;
  12 : <placeholder> ( -- placeholder ) placeholder new V{ } clone >>members ;
  13
  14 : (remove-members) ( placeholder members -- ) [ [ model? ] filter swap parent>> model>> [ remove-connection ] curry each ]
  15     [ nip [ gadget? ] filter [ unparent ] each ] 2bi ;
  16
  17 : remove-members ( placeholder -- ) dup members>> [ drop ] [ [ (remove-members) ] keep delete-all ] if-empty ;
  18 : add-member ( obj placeholder -- ) over layout? [ [ gadget>> ] dip ] when members>> push ;
  19
  20 : , ( item -- ) make:, ;
  21 : make* ( quot -- list ) { } make ; inline
  22
  23 ! Just take the previous mentioned placeholder and use it
  24 ! If there is no previously mentioned placeholder, we're probably making a box, and will create the placeholder ourselves
  25 DEFER: with-interface
  26 : insertion-quot ( quot -- quot' )
  27     make:building get [ [ placeholder? ] find-last nip [ <placeholder> dup , ] unless*
  28     [ templates get ] 2dip swap '[ [ _ templates set _ , @ ] with-interface ] ] when* ;
  29
  30 SYNTAX: ,% scan string>number [ <layout> , ] curry append! ;
  31 SYNTAX: ->% scan string>number '[ [ _ <layout> , ] [ output-model ] bi ] append! ;
  32
  33 GENERIC: -> ( uiitem -- model )
  34 M: gadget -> dup , output-model ;
  35 M: model -> dup , ;
  36
  37 : <spacer> ( -- ) <gadget> 1 <layout> , ;
  38
  39 : add-layout ( track layout -- track ) [ gadget>> ] [ size>> ] bi track-add ;
  40 : layouts ( sized? gadgets -- layouts ) [ [ gadget? ] [ layout? ] bi or ] filter swap
  41    [ [ dup layout? [ f <layout> ] unless ] map ]
  42    [ [ dup gadget? [ gadget>> ] unless ] map ] if ;
  43 : make-layout ( building sized? -- models layouts ) [ swap layouts ] curry
  44    [ make* [ [ model? ] filter ] ] dip bi ; inline
  45 : <box> ( gadgets type -- track )
  46    [ t make-layout ] dip <track>
  47    swap [ add-layout ] each
  48    swap [ <collection> >>model ] unless-empty ; inline
  49 : <hbox> ( gadgets -- track ) horizontal <box> ; inline
  50 : <vbox> ( gadgets -- track ) vertical <box> ; inline
  51
  52 : make-book ( models gadgets model -- book ) book:<book> swap [ "No models in books" throw ] unless-empty ;
  53 : <book> ( quot: ( -- model ) -- book ) f make-layout rot 0 >>value make-book ; inline
  54 : <book*> ( quot -- book ) f make-layout f make-book ; inline
  55
  56 ERROR: not-in-template word ;
  57 SYNTAX: $ scan-new-word dup
  58     [ [ dup templates get at [ nip , ] [ not-in-template ] if* ] curry ( -- ) define-declared "$" expect ]
  59     [ [ <placeholder> [ swap templates get set-at ] keep , ] curry ] bi append! ;
  60
  61 : insert-gadget ( number parent gadget -- ) -rot [ but-last insert-nth ] change-children drop ;
  62 : insert-size ( number parent size -- ) -rot [ but-last insert-nth ] change-sizes drop ;
  63 : insertion-point ( placeholder -- number parent ) dup parent>> [ children>> index ] keep ;
  64
  65 GENERIC: >layout ( gadget -- layout )
  66 M: gadget >layout f <layout> ;
  67 M: layout >layout ;
  68
  69 GENERIC#: (add-gadget-at) 2 ( parent item n -- )
  70 M: gadget (add-gadget-at) -rot [ add-gadget ] keep insert-gadget ;
  71 M: track (add-gadget-at) -rot >layout [ add-layout ] keep [ gadget>> insert-gadget ] [ size>> insert-size ] 3bi ;
  72
  73 GENERIC#: add-gadget-at 1 ( item location -- )
  74 M: object add-gadget-at insertion-point -rot (add-gadget-at) ;
  75 M: model add-gadget-at parent>> dup book:book? [ "No models in books" throw ]
  76    [ dup model>> dup collection? [ nip swap add-connection ] [ drop [ 1array <collection> ] dip model<< ] if ] if ;
  77 : track-add-at ( item location size -- ) swap [ <layout> ] dip add-gadget-at ;
  78 : (track-add-at) ( parent item n size -- ) swap [ <layout> ] dip (add-gadget-at) ;
  79
  80 : insert-item ( item location -- ) [ dup get [ drop ] [ remove-members ] if ] [ on ] [ ] tri
  81     [ add-member ] 2keep add-gadget-at ;
  82
  83 : insert-items ( makelist -- ) t swap [ dup placeholder? [ nip ] [ over insert-item ] if ] each drop ;
  84
  85 : with-interface ( quot -- ) [ make* ] curry H{ } clone templates rot with-variable [ insert-items ] with-scope ; inline
  86
  87 M: model >>= [ swap insertion-quot <action> ] curry ;
  88 M: model fmap insertion-quot <mapped> ;
  89 M: model $> insertion-quot side-effect-model new-mapped-model ;
  90 M: model <$ insertion-quot quot-model new-mapped-model ;