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