basis/ui/gadgets/gadgets.factor

   1 ! Copyright (C) 2005, 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays hashtables kernel models math namespaces
   4        sequences quotations math.vectors combinators sorting
   5        binary-search vectors dlists deques models threads
   6        concurrency.flags math.order math.geometry.rect ;
   7
   8 IN: ui.gadgets
   9
  10 SYMBOL: ui-notify-flag
  11
  12 : notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
  13
  14 TUPLE: gadget < rect
  15        pref-dim parent children orientation focus
  16        visible? root? clipped? layout-state graft-state graft-node
  17        interior boundary
  18        model ;
  19
  20 M: gadget equal? 2drop f ;
  21
  22 M: gadget hashcode* drop gadget hashcode* ;
  23
  24 M: gadget model-changed 2drop ;
  25
  26 : gadget-child ( gadget -- child ) children>> first ;
  27
  28 : nth-gadget ( n gadget -- child ) children>> nth ;
  29
  30 : init-gadget ( gadget -- gadget )
  31   init-rect
  32   { 0 1 } >>orientation
  33   t       >>visible?
  34   { f f } >>graft-state ; inline
  35
  36 : new-gadget ( class -- gadget ) new init-gadget ; inline
  37
  38 : <gadget> ( -- gadget )
  39     gadget new-gadget ;
  40
  41 : activate-control ( gadget -- )
  42     dup model>> dup [
  43         2dup add-connection
  44         swap model-changed
  45     ] [
  46         2drop
  47     ] if ;
  48
  49 : deactivate-control ( gadget -- )
  50     dup model>> dup [ 2dup remove-connection ] when 2drop ;
  51
  52 : control-value ( control -- value )
  53     model>> value>> ;
  54
  55 : set-control-value ( value control -- )
  56     model>> set-model ;
  57
  58 : relative-loc ( fromgadget togadget -- loc )
  59     2dup eq? [
  60         2drop { 0 0 }
  61     ] [
  62         over rect-loc >r
  63         >r parent>> r> relative-loc
  64         r> v+
  65     ] if ;
  66
  67 GENERIC: user-input* ( str gadget -- ? )
  68
  69 M: gadget user-input* 2drop t ;
  70
  71 GENERIC: children-on ( rect/point gadget -- seq )
  72
  73 M: gadget children-on nip children>> ;
  74
  75 : ((fast-children-on)) ( gadget dim axis -- <=> )
  76     [ swap loc>> v- ] dip v. 0 <=> ;
  77
  78 : (fast-children-on) ( dim axis children -- i )
  79     -rot [ ((fast-children-on)) ] 2curry search drop ;
  80
  81 : fast-children-on ( rect axis children -- from to )
  82     [ [ rect-loc ] 2dip (fast-children-on) 0 or ]
  83     [ [ rect-bounds v+ ] 2dip (fast-children-on) ?1+ ]
  84     3bi ;
  85
  86 : inside? ( bounds gadget -- ? )
  87     dup visible?>> [ intersects? ] [ 2drop f ] if ;
  88
  89 : (pick-up) ( point gadget -- gadget )
  90     dupd children-on [ inside? ] with find-last nip ;
  91
  92 : pick-up ( point gadget -- child/f )
  93     2dup (pick-up) dup
  94     [ nip [ rect-loc v- ] keep pick-up ] [ rot 2drop ] if ;
  95
  96 : max-dim ( dims -- dim ) { 0 0 } [ vmax ] reduce ;
  97
  98 : dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
  99
 100 : orient ( gadget seq1 seq2 -- seq )
 101     >r >r orientation>> r> r> [ pick set-axis ] 2map nip ;
 102
 103 : each-child ( gadget quot -- )
 104     >r children>> r> each ; inline
 105
 106 ! Selection protocol
 107 GENERIC: gadget-selection? ( gadget -- ? )
 108
 109 M: gadget gadget-selection? drop f ;
 110
 111 GENERIC: gadget-selection ( gadget -- string/f )
 112
 113 M: gadget gadget-selection drop f ;
 114
 115 ! Text protocol
 116 GENERIC: gadget-text* ( gadget -- )
 117
 118 GENERIC: gadget-text-separator ( gadget -- str )
 119
 120 M: gadget gadget-text-separator
 121     orientation>> { 0 1 } = "\n" "" ? ;
 122
 123 : gadget-seq-text ( seq gadget -- )
 124     gadget-text-separator swap
 125     [ dup % ] [ gadget-text* ] interleave drop ;
 126
 127 M: gadget gadget-text*
 128     dup children>> swap gadget-seq-text ;
 129
 130 M: array gadget-text*
 131     [ gadget-text* ] each ;
 132
 133 : gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
 134
 135 : invalidate ( gadget -- )
 136     \ invalidate swap (>>layout-state) ;
 137
 138 : forget-pref-dim ( gadget -- ) f swap (>>pref-dim) ;
 139
 140 : layout-queue ( -- queue ) \ layout-queue get ;
 141
 142 : layout-later ( gadget -- )
 143     #! When unit testing gadgets without the UI running, the
 144     #! invalid queue is not initialized and we simply ignore
 145     #! invalidation requests.
 146     layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;
 147
 148 DEFER: relayout
 149
 150 : invalidate* ( gadget -- )
 151     \ invalidate* over (>>layout-state)
 152     dup forget-pref-dim
 153     dup root?>>
 154     [ layout-later ] [ parent>> [ relayout ] when* ] if ;
 155
 156 : relayout ( gadget -- )
 157     dup layout-state>> \ invalidate* eq?
 158     [ drop ] [ invalidate* ] if ;
 159
 160 : relayout-1 ( gadget -- )
 161     dup layout-state>>
 162     [ drop ] [ dup invalidate layout-later ] if ;
 163
 164 : show-gadget ( gadget -- ) t swap (>>visible?) ;
 165
 166 : hide-gadget ( gadget -- ) f swap (>>visible?) ;
 167
 168 DEFER: in-layout?
 169
 170 : do-invalidate ( gadget -- gadget )
 171   in-layout? get [ dup invalidate ] [ dup invalidate* ] if ;
 172
 173 M: gadget (>>dim) ( dim gadget -- )
 174    2dup dim>> =
 175      [ 2drop ]
 176      [ tuck call-next-method do-invalidate drop ]
 177    if ;
 178
 179 GENERIC: pref-dim* ( gadget -- dim )
 180
 181 : ?set-gadget-pref-dim ( dim gadget -- )
 182     dup layout-state>>
 183     [ 2drop ] [ (>>pref-dim) ] if ;
 184
 185 : pref-dim ( gadget -- dim )
 186     dup pref-dim>> [ ] [
 187         [ pref-dim* dup ] keep ?set-gadget-pref-dim
 188     ] ?if ;
 189
 190 : pref-dims ( gadgets -- seq ) [ pref-dim ] map ;
 191
 192 M: gadget pref-dim* rect-dim ;
 193
 194 GENERIC: layout* ( gadget -- )
 195
 196 M: gadget layout* drop ;
 197
 198 : prefer ( gadget -- ) dup pref-dim swap (>>dim) ;
 199
 200 : validate ( gadget -- ) f swap (>>layout-state) ;
 201
 202 : layout ( gadget -- )
 203     dup layout-state>> [
 204         dup validate
 205         dup layout*
 206         dup [ layout ] each-child
 207     ] when drop ;
 208
 209 : graft-queue ( -- dlist ) \ graft-queue get ;
 210
 211 : unqueue-graft ( gadget -- )
 212     [ graft-node>> graft-queue delete-node ]
 213     [ [ first { t t } { f f } ? ] change-graft-state drop ] bi ;
 214
 215 : (queue-graft) ( gadget flags -- )
 216     >>graft-state
 217     dup graft-queue push-front* >>graft-node drop
 218     notify-ui-thread ;
 219
 220 : queue-graft ( gadget -- )
 221     { f t } (queue-graft) ;
 222
 223 : queue-ungraft ( gadget -- )
 224     { t f } (queue-graft) ;
 225
 226 : graft-later ( gadget -- )
 227     dup graft-state>> {
 228         { { f t } [ drop ] }
 229         { { t t } [ drop ] }
 230         { { t f } [ unqueue-graft ] }
 231         { { f f } [ queue-graft ] }
 232     } case ;
 233
 234 : ungraft-later ( gadget -- )
 235     dup graft-state>> {
 236         { { f f } [ drop ] }
 237         { { t f } [ drop ] }
 238         { { f t } [ unqueue-graft ] }
 239         { { t t } [ queue-ungraft ] }
 240     } case ;
 241
 242 GENERIC: graft* ( gadget -- )
 243
 244 M: gadget graft* drop ;
 245
 246 : graft ( gadget -- )
 247     dup graft-later [ graft ] each-child ;
 248
 249 GENERIC: ungraft* ( gadget -- )
 250
 251 M: gadget ungraft* drop ;
 252
 253 : ungraft ( gadget -- )
 254     dup [ ungraft ] each-child ungraft-later ;
 255
 256 : (unparent) ( gadget -- )
 257     dup ungraft
 258     dup forget-pref-dim
 259     f swap (>>parent) ;
 260
 261 : unfocus-gadget ( child gadget -- )
 262     tuck focus>> eq?
 263     [ f swap (>>focus) ] [ drop ] if ;
 264
 265 SYMBOL: in-layout?
 266
 267 : not-in-layout ( -- )
 268     in-layout? get
 269     [ "Cannot add/remove gadgets in layout*" throw ] when ;
 270
 271 : unparent ( gadget -- )
 272     not-in-layout
 273     [
 274         dup parent>> dup [
 275             over (unparent)
 276             [ unfocus-gadget ] 2keep
 277             [ children>> delete ] keep
 278             relayout
 279         ] [
 280             2drop
 281         ] if
 282     ] when* ;
 283
 284 : (clear-gadget) ( gadget -- )
 285     dup [ (unparent) ] each-child
 286     f over (>>focus)
 287     f swap (>>children) ;
 288
 289 : clear-gadget ( gadget -- )
 290     not-in-layout
 291     dup (clear-gadget) relayout ;
 292
 293 : ((add-gadget)) ( parent child -- parent )
 294     over children>> ?push >>children ;
 295
 296 : (add-gadget) ( parent child -- parent )
 297     dup unparent
 298     over >>parent
 299     tuck ((add-gadget))
 300     tuck graft-state>> second
 301         [ graft ]
 302         [ drop  ]
 303     if ;
 304
 305 : add-gadget ( parent child -- parent )
 306     not-in-layout
 307     (add-gadget)
 308     dup relayout ;
 309
 310 : add-gadgets ( parent children -- parent )
 311     not-in-layout
 312     [ (add-gadget) ] each
 313     dup relayout ;
 314
 315 : parents ( gadget -- seq )
 316     [ parent>> ] follow ;
 317
 318 : each-parent ( gadget quot -- ? )
 319     >r parents r> all? ; inline
 320
 321 : find-parent ( gadget quot -- parent )
 322     >r parents r> find nip ; inline
 323
 324 : screen-loc ( gadget -- loc )
 325     parents { 0 0 } [ rect-loc v+ ] reduce ;
 326
 327 : (screen-rect) ( gadget -- loc ext )
 328     dup parent>> [
 329         >r rect-extent r> (screen-rect)
 330         >r tuck v+ r> vmin >r v+ r>
 331     ] [
 332         rect-extent
 333     ] if* ;
 334
 335 : screen-rect ( gadget -- rect )
 336     (screen-rect) <extent-rect> ;
 337
 338 : child? ( parent child -- ? )
 339     {
 340         { [ 2dup eq? ] [ 2drop t ] }
 341         { [ dup not ] [ 2drop f ] }
 342         [ parent>> child? ]
 343     } cond ;
 344
 345 GENERIC: focusable-child* ( gadget -- child/t )
 346
 347 M: gadget focusable-child* drop t ;
 348
 349 : focusable-child ( gadget -- child )
 350     dup focusable-child*
 351     dup t eq? [ drop ] [ nip focusable-child ] if ;
 352
 353 GENERIC: request-focus-on ( child gadget -- )
 354
 355 M: gadget request-focus-on parent>> request-focus-on ;
 356
 357 M: f request-focus-on 2drop ;
 358
 359 : request-focus ( gadget -- )
 360     [ focusable-child ] keep request-focus-on ;
 361
 362 : focus-path ( world -- seq )
 363     [ focus>> ] follow ;