core/ui/layouts.factor

   1 ! Copyright (C) 2005, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: errors generic hashtables kernel math
   4 namespaces queues sequences ;
   5 IN: gadgets
   6
   7 DEFER: relayout-1
   8
   9 : invalidate ( gadget -- )
  10     \ relayout-1 swap set-gadget-state ;
  11
  12 : forget-pref-dim ( gadget -- ) f swap set-gadget-pref-dim ;
  13
  14 : invalid ( -- queue ) \ invalid get-global ;
  15
  16 : add-invalid ( gadget -- )
  17     #! When unit testing gadgets without the UI running, the
  18     #! invalid queue is not initialized and we simply ignore
  19     #! invalidation requests.
  20     invalid [ enque ] [ drop ] if* ;
  21
  22 DEFER: relayout
  23
  24 : invalidate* ( gadget -- )
  25     \ relayout over set-gadget-state
  26     dup forget-pref-dim
  27     dup gadget-root?
  28     [ add-invalid ] [ gadget-parent [ relayout ] when* ] if ;
  29
  30 : relayout ( gadget -- )
  31     dup gadget-state \ relayout eq?
  32     [ drop ] [ invalidate* ] if ;
  33
  34 : relayout-1 ( gadget -- )
  35     dup gadget-state
  36     [ drop ] [ dup invalidate add-invalid ] if ;
  37
  38 : show-gadget t swap set-gadget-visible? ;
  39
  40 : hide-gadget f swap set-gadget-visible? ;
  41
  42 : (set-rect-dim) ( dim gadget quot -- )
  43     >r 2dup rect-dim =
  44     [ [ 2drop ] [ set-rect-dim ] if ] 2keep
  45     [ drop ] r> if ; inline
  46
  47 : set-layout-dim ( dim gadget -- )
  48     [ invalidate ] (set-rect-dim) ;
  49
  50 : set-gadget-dim ( dim gadget -- )
  51     [ invalidate* ] (set-rect-dim) ;
  52
  53 GENERIC: pref-dim* ( gadget -- dim )
  54
  55 : ?set-gadget-pref-dim ( dim gadget -- )
  56     dup gadget-state [ 2drop ] [ set-gadget-pref-dim ] if ;
  57
  58 : pref-dim ( gadget -- dim )
  59     dup gadget-pref-dim [ ] [
  60         [ pref-dim* dup ] keep ?set-gadget-pref-dim
  61     ] ?if ;
  62
  63 M: gadget pref-dim* rect-dim ;
  64
  65 GENERIC: layout* ( gadget -- )
  66
  67 M: gadget layout* drop ;
  68
  69 : prefer ( gadget -- ) dup pref-dim swap set-layout-dim ;
  70
  71 DEFER: layout
  72
  73 : layout-children ( gadget -- ) [ layout ] each-child ;
  74
  75 : layout ( gadget -- )
  76     dup gadget-state [
  77         f over set-gadget-state
  78         dup layout* dup layout-children
  79     ] when drop ;
  80
  81 TUPLE: pack align fill gap ;
  82
  83 : pref-dims ( gadget -- list ) [ pref-dim ] map ;
  84
  85 : orient ( gadget seq1 seq2 -- seq )
  86     >r >r gadget-orientation r> r> [ pick set-axis ] 2map nip ;
  87
  88 : packed-dim-2 ( gadget sizes -- list )
  89     [ over rect-dim over v- rot pack-fill v*n v+ ] map-with ;
  90
  91 : packed-dims ( gadget sizes -- seq )
  92     2dup packed-dim-2 swap orient ;
  93
  94 : gap-locs ( gap sizes -- seq )
  95     { 0 0 } [ v+ over v+ ] accumulate 2nip ;
  96
  97 : aligned-locs ( gadget sizes -- seq )
  98     [ >r dup pack-align swap rect-dim r> v- n*v ] map-with ;
  99
 100 : packed-locs ( gadget sizes -- seq )
 101     over pack-gap over gap-locs >r dupd aligned-locs r> orient ;
 102
 103 : round-dims ( seq -- newseq )
 104     { 0 0 } swap
 105     [ swap v- dup [ ceiling >fixnum ] map [ swap v- ] keep ] map
 106     nip ;
 107
 108 : pack-layout ( pack sizes -- )
 109     round-dims over gadget-children
 110     >r dupd packed-dims r> 2dup [ set-layout-dim ] 2each
 111     >r packed-locs r> [ set-rect-loc ] 2each ;
 112
 113 C: pack ( orientation -- pack )
 114     dup delegate>gadget
 115     [ set-gadget-orientation ] keep
 116     0 over set-pack-align
 117     0 over set-pack-fill
 118     { 0 0 } over set-pack-gap ;
 119
 120 : delegate>pack ( orientation tuple -- )
 121     >r <pack> r> set-delegate ;
 122
 123 : <pile> ( -- pack ) { 0 1 } <pack> ;
 124
 125 : <shelf> ( -- pack ) { 1 0 } <pack> ;
 126
 127 : dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
 128
 129 : gap-dims ( gap sizes -- seeq )
 130     [ dim-sum ] keep length 1 [-] rot n*v v+ ;
 131
 132 : pack-pref-dim ( gadget sizes -- dim )
 133     over pack-gap over gap-dims >r max-dim r>
 134     rot gadget-orientation set-axis ;
 135
 136 M: pack pref-dim*
 137     dup gadget-children pref-dims pack-pref-dim ;
 138
 139 M: pack layout*
 140     dup gadget-children pref-dims pack-layout ;
 141
 142 : (fast-children-on) ( dim axis gadgets -- i )
 143     swapd [ rect-loc v- over v. ] binsearch nip ;
 144
 145 : fast-children-on ( rect axis children -- from to )
 146     3dup
 147     >r >r dup rect-loc swap rect-dim v+ origin get v-
 148     r> r> (fast-children-on) 1+
 149     >r
 150     >r >r rect-loc origin get v-
 151     r> r> (fast-children-on)
 152     0 max
 153     r> ;
 154
 155 M: pack children-on ( rect gadget -- seq )
 156     dup gadget-orientation swap gadget-children
 157     [ fast-children-on ] keep <slice> ;