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
4 dlists deques sequences threads sequences words continuations
5 init combinators hashtables concurrency.flags sets accessors
6 calendar fry ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
7 ui.gestures ui.backend ui.render ;
10 ! Assoc mapping aliens to gadgets
13 : window ( handle -- world ) windows get-global at ;
15 : window-focus ( handle -- gadget ) window world-focus ;
17 : register-window ( world handle -- )
18 #! Add the new window just below the topmost window. Why?
19 #! So that if the new window doesn't actually receive focus
20 #! (eg, we're using focus follows mouse and the mouse is not
21 #! in the new window when it appears) Factor doesn't get
22 #! confused and send workspace operations to the new window,
24 swap 2array windows get-global push
25 windows get-global dup length 1 >
26 [ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;
28 : unregister-window ( handle -- )
29 windows global [ [ first = not ] with filter ] change-at ;
31 : raised-window ( world -- )
33 [ [ second eq? ] with find drop ] keep
34 [ nth ] [ delete-nth ] [ nip ] 2tri push ;
36 : focus-gestures ( new old -- )
37 drop-prefix <reversed>
38 T{ lose-focus } swap each-gesture
39 T{ gain-focus } swap each-gesture ;
41 : focus-world ( world -- )
44 focus-path f focus-gestures ;
46 : unfocus-world ( world -- )
48 focus-path f swap focus-gestures ;
52 [ [ title>> ] keep set-title ]
53 [ request-focus ] tri ;
55 : reset-world ( world -- )
56 #! This is used when a window is being closed, but also
57 #! when restoring saved worlds on image startup.
58 [ fonts>> clear-assoc ]
60 [ f >>handle drop ] tri ;
62 : (ungraft-world) ( world -- )
64 [ hand-clicked close-global ]
65 [ hand-gadget close-global ] tri ;
69 [ handle>> (close-window) ]
72 : find-window ( quot -- world )
74 [ gadget-child swap call ] with find-last nip ; inline
77 <dlist> \ graft-queue set-global
78 <dlist> \ layout-queue set-global
79 <dlist> \ gesture-queue set-global
80 V{ } clone windows set-global ;
82 : restore-gadget-later ( gadget -- )
86 { { t t } [ { f f } >>graft-state ] }
87 { { t f } [ dup unqueue-graft { f f } >>graft-state ] }
90 : restore-gadget ( gadget -- )
91 dup restore-gadget-later
92 children>> [ restore-gadget ] each ;
94 : restore-world ( world -- )
95 dup reset-world restore-gadget ;
97 : update-hand ( world -- )
98 dup hand-world get-global eq?
99 [ hand-loc get-global swap move-hand ] [ drop ] if ;
101 : layout-queued ( -- seq )
105 dup layout find-world [ , ] when*
109 : redraw-worlds ( seq -- )
110 [ dup update-hand draw-world ] each ;
112 : notify ( gadget -- )
114 [ first { f f } { t t } ? >>graft-state ] keep
116 { { f t } [ dup activate-control graft* ] }
117 { { t f } [ dup deactivate-control ungraft* ] }
120 : notify-queued ( -- )
121 graft-queue [ notify ] slurp-deque ;
123 : send-queued-gestures ( -- )
124 gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ;
134 ] [ ui-error ] recover ;
138 : ui-running ( quot -- )
139 t \ ui-running set-global
140 [ f \ ui-running set-global ] [ ] cleanup ; inline
142 : ui-running? ( -- ? )
143 \ ui-running get-global ;
145 : update-ui-loop ( -- )
146 [ ui-running? ui-thread get-global self eq? and ]
147 [ ui-notify-flag get lower-flag update-ui ]
150 : start-ui-thread ( -- )
151 [ self ui-thread set-global update-ui-loop ]
152 "UI update" spawn drop ;
154 : open-world-window ( world -- )
155 dup pref-dim >>dim dup relayout graft ;
157 : open-window ( gadget title -- )
158 f <world> open-world-window ;
160 : set-fullscreen? ( ? gadget -- )
161 find-world set-fullscreen* ;
163 : fullscreen? ( gadget -- ? )
164 find-world fullscreen* ;
166 : raise-window ( gadget -- )
167 find-world raise-window* ;
169 HOOK: close-window ui-backend ( gadget -- )
171 M: object close-window
172 find-world [ ungraft ] when* ;
174 : start-ui ( quot -- )
175 call notify-ui-thread start-ui-thread ;
178 f \ ui-running set-global
179 <flag> ui-notify-flag set-global
182 HOOK: (with-ui) ui-backend ( quot -- )
184 : restore-windows ( -- )
186 windows get [ values ] [ delete-all ] bi
187 [ restore-world ] each
191 : restore-windows? ( -- ? )
192 windows get empty? not ;
194 : with-ui ( quot -- )
195 ui-running? [ call ] [ '[ init-ui @ ] (with-ui) ] if ;
197 HOOK: beep ui-backend ( -- )