USING: accessors arrays assocs boxes classes.tuple
classes.tuple.parser combinators combinators.short-circuit
concurrency.flags concurrency.promises continuations deques
-destructors dlists fry init kernel lexer make math
-math.functions namespaces parser sequences sets strings threads
-ui.backend ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.gestures ui.render vectors vocabs.parser words ;
+destructors dlists kernel lexer make math math.functions
+namespaces parser sequences sets strings threads ui.backend
+ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
+ui.render vectors vocabs.parser words ;
IN: ui
<PRIVATE
-! Assoc mapping aliens to gadgets
-SYMBOL: ui-windows
+! Assoc mapping aliens to worlds
+SYMBOL: worlds
-: window ( handle -- world ) ui-windows get-global at ;
+: window ( handle -- world ) worlds get-global at ;
: register-window ( world handle -- )
! Add the new window just below the topmost window. Why?
! in the new window when it appears) Factor doesn't get
! confused and send workspace operations to the new window,
! etc.
- swap 2array ui-windows get-global push
- ui-windows get-global dup length 1 >
+ swap 2array worlds get-global push
+ worlds get-global dup length 1 >
[ [ length 1 - dup 1 - ] keep exchange ] [ drop ] if ;
: unregister-window ( handle -- )
- ui-windows [ [ first = ] with reject ] change-global ;
+ worlds [ [ first = ] with reject ] change-global ;
: raised-window ( world -- )
- ui-windows get-global
+ worlds get-global
[ [ second eq? ] with find drop ] keep
[ nth ] [ remove-nth! drop ] [ nip ] 2tri push ;
<dlist> \ graft-queue set-global
100 <vector> \ layout-queue set-global
<dlist> \ gesture-queue set-global
- V{ } clone ui-windows set-global ;
+ V{ } clone worlds set-global ;
: update-hand ( world -- )
dup hand-world get-global eq?
[ hand-loc get-global swap move-hand ] [ drop ] if ;
-: slurp-vector ( .. seq quot: ( ... elt -- .. ) -- )
+: slurp-vector ( ... seq quot: ( ... elt -- ... ) -- ... )
over '[ _ empty? not ] -rot '[ _ pop @ ] while ; inline
: layout-queued ( -- seq )
redraw-worlds
send-queued-gestures ;
-SYMBOL: ui-thread
-
-: ui-running ( quot -- )
- t \ ui-running set-global
- [ f \ ui-running set-global ] [ ] cleanup ; inline
+SYMBOL: ui-running
PRIVATE>
-: find-window ( quot: ( world -- ? ) -- world/f )
- [ ui-windows get-global values ] dip
+: find-windows ( quot: ( world -- ? ) -- seq )
+ [ worlds get-global values ] dip
'[ dup children>> [ ] [ nip first ] if-empty @ ]
- find-last nip ; inline
+ filter ; inline
+
+: find-window ( quot: ( world -- ? ) -- world/f )
+ find-windows ?last ; inline
: ui-running? ( -- ? )
- \ ui-running get-global ;
+ ui-running get-global ;
<PRIVATE
+SYMBOL: ui-thread
+
: update-ui-loop ( -- )
! Note the logic: if update-ui fails, we open an error window and
! run one iteration of update-ui. If that also fails, well, the
find-world raise-window* ;
: topmost-window ( -- world )
- ui-windows get-global last second ;
+ worlds get-global last second ;
HOOK: close-window ui-backend ( gadget -- )
M: object close-window
find-world [ ungraft ] when* ;
-[
- f \ ui-running set-global
+STARTUP-HOOK: [
+ f ui-running set-global
<flag> ui-notify-flag set-global
-] "ui" add-startup-hook
+]
HOOK: resize-window ui-backend ( world dim -- )
M: object resize-window 2drop ;
[ find-world [ dup pref-dim resize-window ] when* ] bi ;
: with-ui ( quot: ( -- ) -- )
- ui-running? [ call( -- ) ] [ '[ init-ui @ ] (with-ui) ] if ;
+ ui-running? [ call( -- ) ] [
+ t ui-running set-global '[
+ [ init-ui @ ] (with-ui)
+ ] [
+ f ui-running set-global
+ ! Give running ui threads a chance to finish.
+ notify-ui-thread yield
+ ] finally
+ ] if ;
HOOK: beep ui-backend ( -- )