core/ui/gadgets/grids.factor

   1 ! Copyright (C) 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: gadgets
   4 USING: arrays kernel math namespaces sequences words ;
   5
   6 TUPLE: grid children gap ;
   7
   8 : set-grid-children* ( children grid -- )
   9     [ set-grid-children ] 2keep >r concat r> add-gadgets ;
  10
  11 C: grid ( children -- grid )
  12     dup delegate>gadget
  13     [ set-grid-children* ] keep
  14     { 0 0 } over set-grid-gap ;
  15
  16 : grid-child ( grid i j -- gadget ) rot grid-children nth nth ;
  17
  18 : grid-add ( gadget grid i j -- )
  19     >r >r 2dup add-gadget r> r>
  20     3dup grid-child unparent rot grid-children nth set-nth ;
  21
  22 : grid-remove ( grid i j -- )
  23     >r >r >r <gadget> r> r> r> grid-add ;
  24
  25 : pref-dim-grid ( -- dims )
  26     grid get grid-children [ [ pref-dim ] map ] map ;
  27
  28 : compute-grid ( -- horiz vert )
  29     pref-dim-grid
  30     dup flip [ max-dim ] map swap [ max-dim ] map ;
  31
  32 : with-grid ( grid quot -- )
  33     [ >r grid set compute-grid r> call ] with-scope ; inline
  34
  35 : gap grid get grid-gap ;
  36
  37 : (pair-up) ( horiz vert -- dim ) >r first r> second 2array ;
  38
  39 M: grid pref-dim*
  40     [
  41         [ gap [ v+ gap v+ ] reduce ] 2apply (pair-up)
  42     ] with-grid ;
  43
  44 : do-grid ( dims quot -- )
  45     swap grid get grid-children
  46     [ [ pick call ] 2each ] 2each
  47     drop ; inline
  48
  49 : pair-up ( horiz vert -- dims )
  50     [ swap [ swap (pair-up) ] map-with ] map-with ;
  51
  52 : grid-positions ( dims -- locs )
  53     gap [ v+ gap v+ ] accumulate nip ;
  54
  55 : position-grid ( horiz vert -- )
  56     [ grid-positions ] 2apply
  57     pair-up [ set-rect-loc ] do-grid ;
  58
  59 : resize-grid ( horiz vert -- )
  60     pair-up [ set-layout-dim ] do-grid ;
  61
  62 : grid-layout ( horiz vert -- )
  63     2dup position-grid resize-grid ;
  64
  65 M: grid layout*
  66     [ grid-layout ] with-grid ;
  67
  68 : build-grid ( grid specs -- )
  69     swap [ [ grid-add ] build-spec ] with-gadget ; inline
  70
  71 M: grid children-on ( rect gadget -- seq )
  72     dup gadget-children empty? [
  73         2drop f
  74     ] [
  75         { 0 1 } swap grid-children
  76         [ 0 <column> fast-children-on ] keep
  77         <slice> concat
  78     ] if ;