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 ;
14 ! Assoc mapping aliens to worlds
17 : window ( handle -- world ) worlds get-global at ;
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,
26 swap 2array worlds get-global push
27 worlds get-global dup length 1 >
28 [ [ length 1 - dup 1 - ] keep exchange ] [ drop ] if ;
30 : unregister-window ( handle -- )
31 worlds [ [ first = ] with reject ] change-global ;
33 : raised-window ( world -- )
35 [ [ second eq? ] with find drop ] keep
36 [ nth ] [ remove-nth! drop ] [ nip ] 2tri push ;
38 : focus-gestures ( new old -- )
39 drop-prefix <reversed>
40 lose-focus swap each-gesture
41 gain-focus swap each-gesture ;
43 : ?grab-input ( world -- )
44 dup grab-input?>> [ handle>> (grab-input) ] [ drop ] if ;
46 : ?ungrab-input ( world -- )
47 dup grab-input?>> [ handle>> (ungrab-input) ] [ drop ] if ;
49 : focus-world ( world -- )
53 focus-path f focus-gestures
56 : unfocus-world ( world -- )
59 [ focus-path f swap focus-gestures ] bi ;
61 : set-up-window ( world -- )
64 [ [ title>> ] keep set-title ]
70 : clean-up-broken-window ( world -- )
72 dup { [ focused?>> ] [ grab-input?>> ] } 1&&
73 [ handle>> (ungrab-input) ] [ drop ] if
74 ] [ handle>> (close-window) ] bi ;
79 [ set-up-window ] [ ] [ clean-up-broken-window ] cleanup
82 : dispose-window-resources ( world -- )
83 [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ;
88 [ text-handle>> [ dispose ] when* ]
89 [ images>> [ dispose ] when* ]
90 [ hand-clicked close-global ]
91 [ hand-gadget close-global ]
93 [ dispose-window-resources ]
95 [ [ (close-window) f ] change-handle drop ]
96 [ promise>> t swap fulfill ]
100 <box> drag-timer set-global
101 f hand-gadget set-global
102 f hand-clicked set-global
103 f hand-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 ;
110 : update-hand ( world -- )
111 dup hand-world get-global eq?
112 [ hand-loc get-global swap move-hand ] [ drop ] if ;
114 : slurp-vector ( .. seq quot: ( ... elt -- .. ) -- )
115 over '[ _ empty? not ] -rot '[ _ pop @ ] while ; inline
117 : layout-queued ( -- seq )
120 [ dup layout find-world [ , ] when* ] slurp-vector
123 : redraw-worlds ( seq -- )
124 [ dup update-hand draw-world ] each ;
126 : send-queued-gestures ( -- )
127 gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ;
133 send-queued-gestures ;
137 : with-ui-running ( quot -- )
138 t ui-running set-global
139 [ f ui-running set-global ] [ ] cleanup ; inline
143 : find-windows ( quot: ( world -- ? ) -- seq )
144 [ worlds get-global values ] dip
145 '[ dup children>> [ ] [ nip first ] if-empty @ ]
148 : find-window ( quot: ( world -- ? ) -- world/f )
149 find-windows ?last ; inline
151 : ui-running? ( -- ? )
152 ui-running get-global ;
158 : update-ui-loop ( -- )
159 ! Note the logic: if update-ui fails, we open an error window and
160 ! run one iteration of update-ui. If that also fails, well, the
161 ! whole UI subsystem is broken so we throw the error to terminate
162 ! the update-ui-loop.
163 [ { [ ui-running? ] [ ui-thread get-global self eq? ] } 0&& ]
165 ui-notify-flag get lower-flag
167 [ ui-error update-ui ] [
168 stop-event-loop nip rethrow
173 : start-ui-thread ( -- )
174 [ self ui-thread set-global update-ui-loop ]
175 "UI update" spawn drop ;
177 : start-ui ( quot -- )
178 call( -- ) notify-ui-thread start-ui-thread ;
180 : ?attributes ( gadget title/attributes -- attributes )
181 dup string? [ <world-attributes> swap >>title ] [ clone ] if
182 swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ;
186 : open-world-window ( world -- )
187 dup pref-dim [ ceiling ] map >>dim dup relayout graft ;
189 : open-window* ( gadget title/attributes -- window )
190 ?attributes <world> [ open-world-window ] keep ;
192 : open-window ( gadget title/attributes -- )
195 : set-fullscreen ( gadget ? -- )
196 [ find-world ] dip (set-fullscreen) ;
198 : fullscreen? ( gadget -- ? )
199 find-world (fullscreen?) ;
201 : toggle-fullscreen ( gadget -- )
202 dup fullscreen? not set-fullscreen ;
204 : raise-window ( gadget -- )
205 find-world raise-window* ;
207 : topmost-window ( -- world )
208 worlds get-global last second ;
210 HOOK: close-window ui-backend ( gadget -- )
212 M: object close-window
213 find-world [ ungraft ] when* ;
216 f ui-running set-global
217 <flag> ui-notify-flag set-global
218 ] "ui" add-startup-hook
220 HOOK: resize-window ui-backend ( world dim -- )
221 M: object resize-window 2drop ;
223 : relayout-window ( gadget -- )
225 [ find-world [ dup pref-dim resize-window ] when* ] bi ;
227 : with-ui ( quot: ( -- ) -- )
228 ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ;
230 HOOK: beep ui-backend ( -- )
232 HOOK: system-alert ui-backend ( caption text -- )
234 : parse-window-attributes ( class -- attributes )
235 "{" expect dup all-slots parse-tuple-literal-slots ;
237 : define-window ( word attributes quot -- )
238 '[ [ f _ clone @ open-window ] with-ui ] ( -- ) define-declared ;
242 world-attributes parse-window-attributes
248 world-attributes parse-window-attributes
250 [ define-window ] [ 2drop current-vocab main<< ] 3bi ;