basis/ui/gadgets/gadgets.factor

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