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