basis/ui/ui.factor

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