basis/ui/ui.factor

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