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 ;
14 ! Assoc mapping aliens to gadgets
17 : window ( handle -- world ) windows get-global at ;
19 : window-focus ( handle -- gadget ) window world-focus ;
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,
28 swap 2array windows get-global push
29 windows get-global dup length 1 >
30 [ [ length 1 - dup 1 - ] keep exchange ] [ drop ] if ;
32 : unregister-window ( handle -- )
33 windows [ [ first = not ] with filter ] change-global ;
35 : raised-window ( world -- )
37 [ [ second eq? ] with find drop ] keep
38 [ nth ] [ remove-nth! drop ] [ nip ] 2tri push ;
40 : focus-gestures ( new old -- )
41 drop-prefix <reversed>
42 lose-focus swap each-gesture
43 gain-focus swap each-gesture ;
45 : ?grab-input ( world -- )
46 dup grab-input?>> [ handle>> (grab-input) ] [ drop ] if ;
48 : ?ungrab-input ( world -- )
49 dup grab-input?>> [ handle>> (ungrab-input) ] [ drop ] if ;
51 : focus-world ( world -- )
55 focus-path f focus-gestures
58 : unfocus-world ( world -- )
61 [ focus-path f swap focus-gestures ] bi ;
63 : set-up-window ( world -- )
66 [ [ title>> ] keep set-title ]
73 : clean-up-broken-window ( world -- )
75 dup { [ focused?>> ] [ grab-input?>> ] } 1&&
76 [ handle>> (ungrab-input) ] [ drop ] if
77 ] [ handle>> (close-window) ] bi ;
83 [ [ clean-up-broken-window ] [ ui-error ] bi* ] recover
89 [ text-handle>> [ dispose ] when* ]
90 [ images>> [ dispose ] when* ]
91 [ hand-clicked close-global ]
92 [ hand-gadget close-global ]
94 [ [ <reversed> [ [ dispose ] when* ] each V{ } clone ] change-window-resources drop ]
95 [ [ (close-window) f ] change-handle drop ]
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 <dlist> \ layout-queue set-global
107 <dlist> \ gesture-queue set-global
108 V{ } clone windows set-global ;
110 : update-hand ( world -- )
111 dup hand-world get-global eq?
112 [ hand-loc get-global swap move-hand ] [ drop ] if ;
114 : layout-queued ( -- seq )
118 dup layout find-world [ , ] when*
122 : redraw-worlds ( seq -- )
123 [ dup update-hand draw-world ] each ;
125 : send-queued-gestures ( -- )
126 gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ;
132 send-queued-gestures ;
136 : ui-running ( quot -- )
137 t \ ui-running set-global
138 [ f \ ui-running set-global ] [ ] cleanup ; inline
142 : find-window ( quot -- world )
143 [ windows get values ] dip
144 '[ dup children>> [ ] [ nip first ] if-empty @ ]
145 find-last nip ; inline
147 : ui-running? ( -- ? )
148 \ ui-running get-global ;
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
157 [ { [ ui-running? ] [ ui-thread get-global self eq? ] } 0&& ]
159 ui-notify-flag get lower-flag
160 [ update-ui ] [ ui-error update-ui ] recover
163 : start-ui-thread ( -- )
164 [ self ui-thread set-global update-ui-loop ]
165 "UI update" spawn drop ;
167 : start-ui ( quot -- )
168 call( -- ) notify-ui-thread start-ui-thread ;
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 ;
176 : open-world-window ( world -- )
177 dup pref-dim >>dim dup relayout graft ;
179 : open-window* ( gadget title/attributes -- window )
180 ?attributes <world> [ open-world-window ] keep ;
182 : open-window ( gadget title/attributes -- )
185 : set-fullscreen ( gadget ? -- )
186 [ find-world ] dip (set-fullscreen) ;
188 : fullscreen? ( gadget -- ? )
189 find-world (fullscreen?) ;
191 : toggle-fullscreen ( gadget -- )
192 dup fullscreen? not set-fullscreen ;
194 : raise-window ( gadget -- )
195 find-world raise-window* ;
197 : topmost-window ( -- world )
198 windows get last second ;
200 HOOK: close-window ui-backend ( gadget -- )
202 M: object close-window
203 find-world [ ungraft ] when* ;
206 f \ ui-running set-global
207 <flag> ui-notify-flag set-global
208 ] "ui" add-startup-hook
210 : with-ui ( quot -- )
211 ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ;
213 HOOK: beep ui-backend ( -- )
215 HOOK: system-alert ui-backend ( caption text -- )
217 : parse-main-window-attributes ( class -- attributes )
218 "{" expect dup all-slots parse-tuple-literal-slots ;
220 : define-main-window ( word attributes quot -- )
222 '[ [ f _ clone @ open-window ] with-ui ] (( -- )) define-declared
223 ] [ 2drop current-vocab main<< ] 3bi ;
227 world-attributes parse-main-window-attributes