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