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