basis/ui/gadgets/gadgets.factor

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