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