basis/ui/ui.factor

   1 ! Copyright (C) 2006, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays assocs io kernel math models namespaces make dlists
   4 deques sequences threads words continuations init
   5 combinators combinators.short-circuit hashtables concurrency.flags
   6 sets accessors calendar fry destructors ui.gadgets ui.gadgets.private
   7 ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render
   8 strings ;
   9 IN: ui
  10
  11 <PRIVATE
  12
  13 ! Assoc mapping aliens to gadgets
  14 SYMBOL: windows
  15
  16 : window ( handle -- world ) windows get-global at ;
  17
  18 : window-focus ( handle -- gadget ) window world-focus ;
  19
  20 : register-window ( world handle -- )
  21     #! Add the new window just below the topmost window. Why?
  22     #! So that if the new window doesn't actually receive focus
  23     #! (eg, we're using focus follows mouse and the mouse is not
  24     #! in the new window when it appears) Factor doesn't get
  25     #! confused and send workspace operations to the new window,
  26     #! etc.
  27     swap 2array windows get-global push
  28     windows get-global dup length 1 >
  29     [ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;
  30
  31 : unregister-window ( handle -- )
  32     windows [ [ first = not ] with filter ] change-global ;
  33
  34 : raised-window ( world -- )
  35     windows get-global
  36     [ [ second eq? ] with find drop ] keep
  37     [ nth ] [ delete-nth ] [ nip ] 2tri push ;
  38
  39 : focus-gestures ( new old -- )
  40     drop-prefix <reversed>
  41     lose-focus swap each-gesture
  42     gain-focus swap each-gesture ;
  43
  44 : ?grab-input ( world -- )
  45     dup grab-input?>> [ handle>> (grab-input) ] [ drop ] if ;
  46
  47 : ?ungrab-input ( world -- )
  48     dup grab-input?>> [ handle>> (ungrab-input) ] [ drop ] if ;
  49
  50 : focus-world ( world -- )
  51     t >>focused?
  52     [ ?grab-input ] [
  53         dup raised-window
  54         focus-path f focus-gestures
  55     ] bi ;
  56
  57 : unfocus-world ( world -- )
  58     f >>focused?
  59     [ ?ungrab-input ]
  60     [ focus-path f swap focus-gestures ] bi ;
  61
  62 : set-up-window ( world -- )
  63     {
  64         [ handle>> select-gl-context ]
  65         [ [ title>> ] keep set-title ]
  66         [ begin-world ]
  67         [ resize-world ]
  68         [ t >>active? drop ]
  69         [ request-focus ]
  70     } cleave ;
  71
  72 : clean-up-broken-window ( world -- )
  73     [
  74         dup { [ focused?>> ] [ grab-input?>> ] } 1&&
  75         [ handle>> (ungrab-input) ] [ drop ] if
  76     ] [ handle>> (close-window) ] bi ;
  77
  78 M: world graft*
  79     [ (open-window) ]
  80     [
  81         [ set-up-window ]
  82         [ [ clean-up-broken-window ] [ ui-error ] bi* ] recover
  83     ] bi ;
  84
  85 : reset-world ( world -- )
  86     #! This is used when a window is being closed, but also
  87     #! when restoring saved worlds on image startup.
  88     f >>handle unfocus-world ;
  89
  90 : (ungraft-world) ( world -- )
  91     {
  92         [ handle>> select-gl-context ]
  93         [ text-handle>> [ dispose ] when* ]
  94         [ images>> [ dispose ] when* ]
  95         [ hand-clicked close-global ]
  96         [ hand-gadget close-global ]
  97         [ end-world ]
  98     } cleave ;
  99
 100 M: world ungraft*
 101     [ (ungraft-world) ]
 102     [ handle>> (close-window) ]
 103     [ reset-world ] tri ;
 104
 105 : init-ui ( -- )
 106     <dlist> \ graft-queue set-global
 107     <dlist> \ layout-queue set-global
 108     <dlist> \ gesture-queue set-global
 109     V{ } clone windows set-global ;
 110
 111 : restore-gadget-later ( gadget -- )
 112     dup graft-state>> {
 113         { { f f } [ ] }
 114         { { f t } [ ] }
 115         { { t t } [ { f f } >>graft-state ] }
 116         { { t f } [ dup unqueue-graft { f f } >>graft-state ] }
 117     } case graft-later ;
 118
 119 : restore-gadget ( gadget -- )
 120     dup restore-gadget-later
 121     children>> [ restore-gadget ] each ;
 122
 123 : restore-world ( world -- )
 124     {
 125         [ reset-world ]
 126         [ f >>text-handle f >>images drop ]
 127         [ restore-gadget ]
 128     } cleave ;
 129
 130 : update-hand ( world -- )
 131     dup hand-world get-global eq?
 132     [ hand-loc get-global swap move-hand ] [ drop ] if ;
 133
 134 : layout-queued ( -- seq )
 135     [
 136         in-layout? on
 137         layout-queue [
 138             dup layout find-world [ , ] when*
 139         ] slurp-deque
 140     ] { } make prune ;
 141
 142 : redraw-worlds ( seq -- )
 143     [ dup update-hand draw-world ] each ;
 144
 145 : send-queued-gestures ( -- )
 146     gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ;
 147
 148 : update-ui ( -- )
 149     notify-queued
 150     layout-queued
 151     redraw-worlds
 152     send-queued-gestures ;
 153
 154 SYMBOL: ui-thread
 155
 156 : ui-running ( quot -- )
 157     t \ ui-running set-global
 158     [ f \ ui-running set-global ] [ ] cleanup ; inline
 159
 160 PRIVATE>
 161
 162 : find-window ( quot -- world )
 163     [ windows get values ] dip
 164     '[ dup children>> [ ] [ nip first ] if-empty @ ]
 165     find-last nip ; inline
 166
 167 : ui-running? ( -- ? )
 168     \ ui-running get-global ;
 169
 170 <PRIVATE
 171
 172 : update-ui-loop ( -- )
 173     #! Note the logic: if update-ui fails, we open an error window
 174     #! and run one iteration of update-ui. If that also fails, well,
 175     #! the whole UI subsystem is broken so we exit out of the
 176     #! update-ui-loop.
 177     [ { [ ui-running? ] [ ui-thread get-global self eq? ] } 0&& ]
 178     [
 179         ui-notify-flag get lower-flag
 180         [ update-ui ] [ ui-error update-ui ] recover
 181     ] while ;
 182
 183 : start-ui-thread ( -- )
 184     [ self ui-thread set-global update-ui-loop ]
 185     "UI update" spawn drop ;
 186
 187 : start-ui ( quot -- )
 188     call( -- ) notify-ui-thread start-ui-thread ;
 189
 190 : restore-windows ( -- )
 191     [
 192         windows get [ values ] [ delete-all ] bi
 193         [ restore-world ] each
 194         forget-rollover
 195     ] (with-ui) ;
 196
 197 : restore-windows? ( -- ? )
 198     windows get empty? not ;
 199
 200 : ?attributes ( gadget title/attributes -- attributes )
 201     dup string? [ world-attributes new swap >>title ] when
 202     swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ;
 203
 204 PRIVATE>
 205
 206 : open-world-window ( world -- )
 207     dup pref-dim >>dim dup relayout graft ;
 208
 209 : open-window ( gadget title/attributes -- )
 210     ?attributes <world> open-world-window ;
 211
 212 : set-fullscreen ( gadget ? -- )
 213     [ find-world ] dip (set-fullscreen) ;
 214
 215 : fullscreen? ( gadget -- ? )
 216     find-world (fullscreen?) ;
 217
 218 : toggle-fullscreen ( gadget -- )
 219     dup fullscreen? not set-fullscreen ;
 220
 221 : raise-window ( gadget -- )
 222     find-world raise-window* ;
 223
 224 HOOK: close-window ui-backend ( gadget -- )
 225
 226 M: object close-window
 227     find-world [ ungraft ] when* ;
 228
 229 [
 230     f \ ui-running set-global
 231     <flag> ui-notify-flag set-global
 232 ] "ui" add-init-hook
 233
 234 : with-ui ( quot -- )
 235     ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ;
 236
 237 HOOK: beep ui-backend ( -- )