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
13 ! Assoc mapping aliens to gadgets
16 : window ( handle -- world ) windows get-global at ;
18 : window-focus ( handle -- gadget ) window world-focus ;
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,
27 swap 2array windows get-global push
28 windows get-global dup length 1 >
29 [ [ length 1 - dup 1 - ] keep exchange ] [ drop ] if ;
31 : unregister-window ( handle -- )
32 windows [ [ first = not ] with filter ] change-global ;
34 : raised-window ( world -- )
36 [ [ second eq? ] with find drop ] keep
37 [ nth ] [ delete-nth ] [ nip ] 2tri push ;
39 : focus-gestures ( new old -- )
40 drop-prefix <reversed>
41 lose-focus swap each-gesture
42 gain-focus swap each-gesture ;
44 : ?grab-input ( world -- )
45 dup grab-input?>> [ handle>> (grab-input) ] [ drop ] if ;
47 : ?ungrab-input ( world -- )
48 dup grab-input?>> [ handle>> (ungrab-input) ] [ drop ] if ;
50 : focus-world ( world -- )
54 focus-path f focus-gestures
57 : unfocus-world ( world -- )
60 [ focus-path f swap focus-gestures ] bi ;
62 : set-up-window ( world -- )
65 [ [ title>> ] keep set-title ]
72 : clean-up-broken-window ( world -- )
74 dup { [ focused?>> ] [ grab-input?>> ] } 1&&
75 [ handle>> (ungrab-input) ] [ drop ] if
76 ] [ handle>> (close-window) ] bi ;
82 [ [ clean-up-broken-window ] [ ui-error ] bi* ] recover
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 ;
90 : (ungraft-world) ( world -- )
93 [ text-handle>> [ dispose ] when* ]
94 [ images>> [ dispose ] when* ]
95 [ hand-clicked close-global ]
96 [ hand-gadget close-global ]
98 [ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
103 [ handle>> (close-window) ]
104 [ reset-world ] tri ;
107 <dlist> \ graft-queue set-global
108 <dlist> \ layout-queue set-global
109 <dlist> \ gesture-queue set-global
110 V{ } clone windows set-global ;
112 : restore-gadget-later ( gadget -- )
116 { { t t } [ { f f } >>graft-state ] }
117 { { t f } [ dup unqueue-graft { f f } >>graft-state ] }
120 : restore-gadget ( gadget -- )
121 dup restore-gadget-later
122 children>> [ restore-gadget ] each ;
124 : restore-world ( world -- )
127 [ f >>text-handle f >>images drop ]
131 : update-hand ( world -- )
132 dup hand-world get-global eq?
133 [ hand-loc get-global swap move-hand ] [ drop ] if ;
135 : layout-queued ( -- seq )
139 dup layout find-world [ , ] when*
143 : redraw-worlds ( seq -- )
144 [ dup update-hand draw-world ] each ;
146 : send-queued-gestures ( -- )
147 gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ;
153 send-queued-gestures ;
157 : ui-running ( quot -- )
158 t \ ui-running set-global
159 [ f \ ui-running set-global ] [ ] cleanup ; inline
163 : find-window ( quot -- world )
164 [ windows get values ] dip
165 '[ dup children>> [ ] [ nip first ] if-empty @ ]
166 find-last nip ; inline
168 : ui-running? ( -- ? )
169 \ ui-running get-global ;
173 : update-ui-loop ( -- )
174 #! Note the logic: if update-ui fails, we open an error window
175 #! and run one iteration of update-ui. If that also fails, well,
176 #! the whole UI subsystem is broken so we exit out of the
178 [ { [ ui-running? ] [ ui-thread get-global self eq? ] } 0&& ]
180 ui-notify-flag get lower-flag
181 [ update-ui ] [ ui-error update-ui ] recover
184 : start-ui-thread ( -- )
185 [ self ui-thread set-global update-ui-loop ]
186 "UI update" spawn drop ;
188 : start-ui ( quot -- )
189 call( -- ) notify-ui-thread start-ui-thread ;
191 : restore-windows ( -- )
193 windows get [ values ] [ delete-all ] bi
194 [ restore-world ] each
198 : restore-windows? ( -- ? )
199 windows get empty? not ;
201 : ?attributes ( gadget title/attributes -- attributes )
202 dup string? [ world-attributes new swap >>title ] [ clone ] if
203 swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ;
207 : open-world-window ( world -- )
208 dup pref-dim >>dim dup relayout graft ;
210 : open-window* ( gadget title/attributes -- window )
211 ?attributes <world> [ open-world-window ] keep ;
213 : open-window ( gadget title/attributes -- )
216 : set-fullscreen ( gadget ? -- )
217 [ find-world ] dip (set-fullscreen) ;
219 : fullscreen? ( gadget -- ? )
220 find-world (fullscreen?) ;
222 : toggle-fullscreen ( gadget -- )
223 dup fullscreen? not set-fullscreen ;
225 : raise-window ( gadget -- )
226 find-world raise-window* ;
228 : topmost-window ( -- world )
229 windows get last second ;
231 HOOK: close-window ui-backend ( gadget -- )
233 M: object close-window
234 find-world [ ungraft ] when* ;
237 f \ ui-running set-global
238 <flag> ui-notify-flag set-global
241 : with-ui ( quot -- )
242 ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ;
244 HOOK: beep ui-backend ( -- )