From: Daniel Ehrenberg <littledan@Macintosh-103.local>
Date: Tue, 19 Aug 2008 19:06:26 +0000 (+0200)
Subject: Merge branch 'master' of git://factorcode.org/git/factor
X-Git-Tag: 0.94~2439^2~181^2~2^2~1
X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=1e1da7330921bd8d5918aa101dbea6c8c4b51026

Merge branch 'master' of git://factorcode.org/git/factor
---

1e1da7330921bd8d5918aa101dbea6c8c4b51026
diff --cc basis/ui/gadgets/gadgets-tests.factor
index 0000000000,1a2555d538..0bce366fcc
mode 000000,100755..100755
--- a/basis/ui/gadgets/gadgets-tests.factor
+++ b/basis/ui/gadgets/gadgets-tests.factor
@@@ -1,0 -1,165 +1,165 @@@
+ IN: ui.gadgets.tests
+ USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds
 -tools.test namespaces models kernel dlists dequeues math sets
++tools.test namespaces models kernel dlists deques math sets
+ math.parser ui sequences hashtables assocs io arrays prettyprint
+ io.streams.string math.geometry.rect ;
+ 
+ [ { 300 300 } ]
+ [
+     ! c contains b contains a
+     <gadget> "a" set
+     <gadget> "b" set
+     "a" get "b" get swap add-gadget drop
+     <gadget> "c" set
+     "b" get "c" get swap add-gadget drop
+ 
+     ! position a and b
+     { 100 200 } "a" get set-rect-loc
+     { 200 100 } "b" get set-rect-loc
+ 
+     ! give c a loc, it doesn't matter
+     { -1000 23 } "c" get set-rect-loc
+ 
+     ! what is the location of a inside c?
+     "a" get "c" get relative-loc
+ ] unit-test
+ 
+ <gadget> "g1" set
+ { 10 10 } "g1" get set-rect-loc
+ { 30 30 } "g1" get set-rect-dim
+ <gadget> "g2" set
+ { 20 20 } "g2" get set-rect-loc
+ { 50 500 } "g2" get set-rect-dim
+ <gadget> "g3" set
+ { 100 200 } "g3" get set-rect-dim
+ 
+ "g1" get "g2" get swap add-gadget drop
+ "g2" get "g3" get swap add-gadget drop
+ 
+ [ { 30 30 } ] [ "g1" get screen-loc ] unit-test
+ [ { 30 30 } ] [ "g1" get screen-rect rect-loc ] unit-test
+ [ { 30 30 } ] [ "g1" get screen-rect rect-dim ] unit-test
+ [ { 20 20 } ] [ "g2" get screen-loc ] unit-test
+ [ { 20 20 } ] [ "g2" get screen-rect rect-loc ] unit-test
+ [ { 50 180 } ] [ "g2" get screen-rect rect-dim ] unit-test
+ [ { 0 0 } ] [ "g3" get screen-loc ] unit-test
+ [ { 0 0 } ] [ "g3" get screen-rect rect-loc ] unit-test
+ [ { 100 200 } ] [ "g3" get screen-rect rect-dim ] unit-test
+ 
+ <gadget> "g1" set
+ { 300 300 } "g1" get set-rect-dim
+ <gadget> "g2" set
+ "g2" get "g1" get swap add-gadget drop
+ { 20 20 } "g2" get set-rect-loc
+ { 20 20 } "g2" get set-rect-dim
+ <gadget> "g3" set
+ "g3" get "g1" get swap add-gadget drop
+ { 100 100 } "g3" get set-rect-loc
+ { 20 20 } "g3" get set-rect-dim
+ 
+ [ t ] [ { 30 30 } "g2" get inside? ] unit-test
+ 
+ [ t ] [ { 30 30 } "g1" get (pick-up) "g2" get eq? ] unit-test
+ 
+ [ t ] [ { 30 30 } "g1" get pick-up "g2" get eq? ] unit-test
+ 
+ [ t ] [ { 110 110 } "g1" get pick-up "g3" get eq? ] unit-test
+ 
+ <gadget> "g4" set
+ "g4" get "g2" get swap add-gadget drop
+ { 5 5 } "g4" get set-rect-loc
+ { 1 1 } "g4" get set-rect-dim
+ 
+ [ t ] [ { 25 25 } "g1" get pick-up "g4" get eq? ] unit-test
+ 
+ TUPLE: mock-gadget < gadget graft-called ungraft-called ;
+ 
+ : <mock-gadget> ( -- gadget )
+     mock-gadget new-gadget 0 >>graft-called 0 >>ungraft-called ;
+ 
+ M: mock-gadget graft*
+     dup mock-gadget-graft-called 1+
+     swap set-mock-gadget-graft-called ;
+ 
+ M: mock-gadget ungraft*
+     dup mock-gadget-ungraft-called 1+
+     swap set-mock-gadget-ungraft-called ;
+ 
+ ! We can't print to output-stream here because that might be a pane
+ ! stream, and our graft-queue rebinding here would be captured
+ ! by code adding children to the pane...
+ [
+     <dlist> \ graft-queue [
+         [ ] [ <mock-gadget> dup queue-graft unqueue-graft ] unit-test
 -        [ t ] [ graft-queue dequeue-empty? ] unit-test
++        [ t ] [ graft-queue deque-empty? ] unit-test
+     ] with-variable
+ 
+     <dlist> \ graft-queue [
 -        [ t ] [ graft-queue dequeue-empty? ] unit-test
++        [ t ] [ graft-queue deque-empty? ] unit-test
+ 
+         <mock-gadget> "g" set
+         [ ] [ "g" get queue-graft ] unit-test
 -        [ f ] [ graft-queue dequeue-empty? ] unit-test
++        [ f ] [ graft-queue deque-empty? ] unit-test
+         [ { f t } ] [ "g" get gadget-graft-state ] unit-test
+         [ ] [ "g" get graft-later ] unit-test
+         [ { f t } ] [ "g" get gadget-graft-state ] unit-test
+         [ ] [ "g" get ungraft-later ] unit-test
+         [ { f f } ] [ "g" get gadget-graft-state ] unit-test
 -        [ t ] [ graft-queue dequeue-empty? ] unit-test
++        [ t ] [ graft-queue deque-empty? ] unit-test
+         [ ] [ "g" get ungraft-later ] unit-test
+         [ ] [ "g" get graft-later ] unit-test
+         [ ] [ notify-queued ] unit-test
+         [ { t t } ] [ "g" get gadget-graft-state ] unit-test
 -        [ t ] [ graft-queue dequeue-empty? ] unit-test
++        [ t ] [ graft-queue deque-empty? ] unit-test
+         [ ] [ "g" get graft-later ] unit-test
+         [ 1 ] [ "g" get mock-gadget-graft-called ] unit-test
+         [ ] [ "g" get ungraft-later ] unit-test
+         [ { t f } ] [ "g" get gadget-graft-state ] unit-test
+         [ ] [ notify-queued ] unit-test
+         [ 1 ] [ "g" get mock-gadget-ungraft-called ] unit-test
+         [ { f f } ] [ "g" get gadget-graft-state ] unit-test
+     ] with-variable
+ 
+     : add-some-children
+         3 [
+             <mock-gadget> over <model> over set-gadget-model
+             dup "g" get swap add-gadget drop
+             swap 1+ number>string set
+         ] each ;
+ 
+     : status-flags
+         { "g" "1" "2" "3" } [ get gadget-graft-state ] map prune ;
+ 
+     : notify-combo ( ? ? -- )
+         nl "===== Combo: " write 2dup 2array . nl
+         <dlist> \ graft-queue [
+             <mock-gadget> "g" set
+             [ ] [ add-some-children ] unit-test
+             [ V{ { f f } } ] [ status-flags ] unit-test
+             [ ] [ "g" get graft ] unit-test
+             [ V{ { f t } } ] [ status-flags ] unit-test
+             dup [ [ ] [ notify-queued ] unit-test ] when
+             [ ] [ "g" get clear-gadget ] unit-test
+             [ [ 1 ] [ graft-queue dlist-length ] unit-test ] unless
+             [ [ ] [ notify-queued ] unit-test ] when
+             [ ] [ add-some-children ] unit-test
+             [ { f t } ] [ "1" get gadget-graft-state ] unit-test
+             [ { f t } ] [ "2" get gadget-graft-state ] unit-test
+             [ { f t } ] [ "3" get gadget-graft-state ] unit-test
 -            [ ] [ graft-queue [ "x" print notify ] slurp-dequeue ] unit-test
++            [ ] [ graft-queue [ "x" print notify ] slurp-deque ] unit-test
+             [ ] [ notify-queued ] unit-test
+             [ V{ { t t } } ] [ status-flags ] unit-test
+         ] with-variable ;
+ 
+     { { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
+ ] with-string-writer print
+ 
+ \ <gadget> must-infer
+ \ unparent must-infer
+ \ add-gadget must-infer
+ \ add-gadgets must-infer
+ \ clear-gadget must-infer
+ 
+ \ relayout must-infer
+ \ relayout-1 must-infer
+ \ pref-dim must-infer
diff --cc basis/ui/gadgets/gadgets.factor
index 0000000000,90eea255e8..15a28801d6
mode 000000,100755..100755
--- a/basis/ui/gadgets/gadgets.factor
+++ b/basis/ui/gadgets/gadgets.factor
@@@ -1,0 -1,368 +1,368 @@@
+ ! Copyright (C) 2005, 2008 Slava Pestov.
+ ! See http://factorcode.org/license.txt for BSD license.
+ USING: accessors arrays hashtables kernel models math namespaces
+        sequences quotations math.vectors combinators sorting
 -       binary-search vectors dlists dequeues models threads
++       binary-search vectors dlists deques models threads
+        concurrency.flags math.order math.geometry.rect ;
+ 
+ IN: ui.gadgets
+ 
+ SYMBOL: ui-notify-flag
+ 
+ : notify-ui-thread ( -- ) ui-notify-flag get-global raise-flag ;
+ 
+ TUPLE: gadget < rect
+        pref-dim parent children orientation focus
+        visible? root? clipped? layout-state graft-state graft-node
+        interior boundary
+        model ;
+ 
+ M: gadget equal? 2drop f ;
+ 
+ M: gadget hashcode* drop gadget hashcode* ;
+ 
+ M: gadget model-changed 2drop ;
+ 
+ : gadget-child ( gadget -- child ) children>> first ;
+ 
+ : nth-gadget ( n gadget -- child ) children>> nth ;
+ 
+ : init-gadget ( gadget -- gadget )
+   init-rect
+   { 0 1 } >>orientation
+   t       >>visible?
+   { f f } >>graft-state ; inline
+ 
+ : new-gadget ( class -- gadget ) new init-gadget ; inline
+ 
+ : <gadget> ( -- gadget )
+     gadget new-gadget ;
+ 
+ : activate-control ( gadget -- )
+     dup model>> dup [
+         2dup add-connection
+         swap model-changed
+     ] [
+         2drop
+     ] if ;
+ 
+ : deactivate-control ( gadget -- )
+     dup model>> dup [ 2dup remove-connection ] when 2drop ;
+ 
+ : control-value ( control -- value )
+     model>> model-value ;
+ 
+ : set-control-value ( value control -- )
+     model>> set-model ;
+ 
+ : relative-loc ( fromgadget togadget -- loc )
+     2dup eq? [
+         2drop { 0 0 }
+     ] [
+         over rect-loc >r
+         >r parent>> r> relative-loc
+         r> v+
+     ] if ;
+ 
+ GENERIC: user-input* ( str gadget -- ? )
+ 
+ M: gadget user-input* 2drop t ;
+ 
+ GENERIC: children-on ( rect/point gadget -- seq )
+ 
+ M: gadget children-on nip children>> ;
+ 
+ : ((fast-children-on)) ( gadget dim axis -- <=> )
+     [ swap loc>> v- ] dip v. 0 <=> ;
+ 
+ : (fast-children-on) ( dim axis children -- i )
+     -rot [ ((fast-children-on)) ] 2curry search drop ;
+ 
+ : fast-children-on ( rect axis children -- from to )
+     [ [ rect-loc ] 2dip (fast-children-on) 0 or ]
+     [ [ rect-bounds v+ ] 2dip (fast-children-on) ?1+ ]
+     3bi ;
+ 
+ : inside? ( bounds gadget -- ? )
+     dup visible?>> [ intersects? ] [ 2drop f ] if ;
+ 
+ : (pick-up) ( point gadget -- gadget )
+     dupd children-on [ inside? ] with find-last nip ;
+ 
+ : pick-up ( point gadget -- child/f )
+     2dup (pick-up) dup
+     [ nip [ rect-loc v- ] keep pick-up ] [ rot 2drop ] if ;
+ 
+ : max-dim ( dims -- dim ) { 0 0 } [ vmax ] reduce ;
+ 
+ : dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
+ 
+ : orient ( gadget seq1 seq2 -- seq )
+     >r >r orientation>> r> r> [ pick set-axis ] 2map nip ;
+ 
+ : each-child ( gadget quot -- )
+     >r children>> r> each ; inline
+ 
+ ! Selection protocol
+ GENERIC: gadget-selection? ( gadget -- ? )
+ 
+ M: gadget gadget-selection? drop f ;
+ 
+ GENERIC: gadget-selection ( gadget -- string/f )
+ 
+ M: gadget gadget-selection drop f ;
+ 
+ ! Text protocol
+ GENERIC: gadget-text* ( gadget -- )
+ 
+ GENERIC: gadget-text-separator ( gadget -- str )
+ 
+ M: gadget gadget-text-separator
+     orientation>> { 0 1 } = "\n" "" ? ;
+ 
+ : gadget-seq-text ( seq gadget -- )
+     gadget-text-separator swap
+     [ dup % ] [ gadget-text* ] interleave drop ;
+ 
+ M: gadget gadget-text*
+     dup children>> swap gadget-seq-text ;
+ 
+ M: array gadget-text*
+     [ gadget-text* ] each ;
+ 
+ : gadget-text ( gadget -- string ) [ gadget-text* ] "" make ;
+ 
+ : invalidate ( gadget -- )
+     \ invalidate swap (>>layout-state) ;
+ 
+ : forget-pref-dim ( gadget -- ) f swap (>>pref-dim) ;
+ 
+ : layout-queue ( -- queue ) \ layout-queue get ;
+ 
+ : layout-later ( gadget -- )
+     #! When unit testing gadgets without the UI running, the
+     #! invalid queue is not initialized and we simply ignore
+     #! invalidation requests.
+     layout-queue [ push-front notify-ui-thread ] [ drop ] if* ;
+ 
+ DEFER: relayout
+ 
+ : invalidate* ( gadget -- )
+     \ invalidate* over (>>layout-state)
+     dup forget-pref-dim
+     dup gadget-root?
+     [ layout-later ] [ parent>> [ relayout ] when* ] if ;
+ 
+ : relayout ( gadget -- )
+     dup layout-state>> \ invalidate* eq?
+     [ drop ] [ invalidate* ] if ;
+ 
+ : relayout-1 ( gadget -- )
+     dup layout-state>>
+     [ drop ] [ dup invalidate layout-later ] if ;
+ 
+ : show-gadget ( gadget -- ) t swap (>>visible?) ;
+ 
+ : hide-gadget ( gadget -- ) f swap (>>visible?) ;
+ 
+ DEFER: in-layout?
+ 
+ : do-invalidate ( gadget -- gadget )
+   in-layout? get [ dup invalidate ] [ dup invalidate* ] if ;
+ 
+ M: gadget (>>dim) ( dim gadget -- )
+    2dup dim>> =
+      [ 2drop ]
+      [ tuck call-next-method do-invalidate drop ]
+    if ;
+ 
+ GENERIC: pref-dim* ( gadget -- dim )
+ 
+ : ?set-gadget-pref-dim ( dim gadget -- )
+     dup layout-state>>
+     [ 2drop ] [ (>>pref-dim) ] if ;
+ 
+ : pref-dim ( gadget -- dim )
+     dup pref-dim>> [ ] [
+         [ pref-dim* dup ] keep ?set-gadget-pref-dim
+     ] ?if ;
+ 
+ : pref-dims ( gadgets -- seq ) [ pref-dim ] map ;
+ 
+ M: gadget pref-dim* rect-dim ;
+ 
+ GENERIC: layout* ( gadget -- )
+ 
+ M: gadget layout* drop ;
+ 
+ : prefer ( gadget -- ) dup pref-dim swap (>>dim) ;
+ 
+ : validate ( gadget -- ) f swap (>>layout-state) ;
+ 
+ : layout ( gadget -- )
+     dup layout-state>> [
+         dup validate
+         dup layout*
+         dup [ layout ] each-child
+     ] when drop ;
+ 
+ : graft-queue ( -- dlist ) \ graft-queue get ;
+ 
+ : unqueue-graft ( gadget -- )
+     [ graft-node>> graft-queue delete-node ]
+     [ [ first { t t } { f f } ? ] change-graft-state drop ] bi ;
+ 
+ : (queue-graft) ( gadget flags -- )
+     >>graft-state
+     dup graft-queue push-front* >>graft-node drop
+     notify-ui-thread ;
+ 
+ : queue-graft ( gadget -- )
+     { f t } (queue-graft) ;
+ 
+ : queue-ungraft ( gadget -- )
+     { t f } (queue-graft) ;
+ 
+ : graft-later ( gadget -- )
+     dup graft-state>> {
+         { { f t } [ drop ] }
+         { { t t } [ drop ] }
+         { { t f } [ unqueue-graft ] }
+         { { f f } [ queue-graft ] }
+     } case ;
+ 
+ : ungraft-later ( gadget -- )
+     dup graft-state>> {
+         { { f f } [ drop ] }
+         { { t f } [ drop ] }
+         { { f t } [ unqueue-graft ] }
+         { { t t } [ queue-ungraft ] }
+     } case ;
+ 
+ GENERIC: graft* ( gadget -- )
+ 
+ M: gadget graft* drop ;
+ 
+ : graft ( gadget -- )
+     dup graft-later [ graft ] each-child ;
+ 
+ GENERIC: ungraft* ( gadget -- )
+ 
+ M: gadget ungraft* drop ;
+ 
+ : ungraft ( gadget -- )
+     dup [ ungraft ] each-child ungraft-later ;
+ 
+ : (unparent) ( gadget -- )
+     dup ungraft
+     dup forget-pref-dim
+     f swap (>>parent) ;
+ 
+ : unfocus-gadget ( child gadget -- )
+     tuck focus>> eq?
+     [ f swap (>>focus) ] [ drop ] if ;
+ 
+ SYMBOL: in-layout?
+ 
+ : not-in-layout ( -- )
+     in-layout? get
+     [ "Cannot add/remove gadgets in layout*" throw ] when ;
+ 
+ : unparent ( gadget -- )
+     not-in-layout
+     [
+         dup parent>> dup [
+             over (unparent)
+             [ unfocus-gadget ] 2keep
+             [ children>> delete ] keep
+             relayout
+         ] [
+             2drop
+         ] if
+     ] when* ;
+ 
+ : (clear-gadget) ( gadget -- )
+     dup [ (unparent) ] each-child
+     f over (>>focus)
+     f swap (>>children) ;
+ 
+ : clear-gadget ( gadget -- )
+     not-in-layout
+     dup (clear-gadget) relayout ;
+ 
+ : ((add-gadget)) ( parent child -- parent )
+     over children>> ?push >>children ;
+ 
+ : (add-gadget) ( parent child -- parent )
+     dup unparent
+     over >>parent
+     tuck ((add-gadget))
+     tuck graft-state>> second
+         [ graft ]
+         [ drop  ]
+     if ;
+ 
+ : add-gadget ( parent child -- parent )
+     not-in-layout
+     (add-gadget)
+     dup relayout ;
+   
+ : add-gadgets ( parent children -- parent )
+     not-in-layout
+     [ (add-gadget) ] each
+     dup relayout ;
+ 
+ : parents ( gadget -- seq )
+     [ parent>> ] follow ;
+ 
+ : each-parent ( gadget quot -- ? )
+     >r parents r> all? ; inline
+ 
+ : find-parent ( gadget quot -- parent )
+     >r parents r> find nip ; inline
+ 
+ : screen-loc ( gadget -- loc )
+     parents { 0 0 } [ rect-loc v+ ] reduce ;
+ 
+ : (screen-rect) ( gadget -- loc ext )
+     dup parent>> [
+         >r rect-extent r> (screen-rect)
+         >r tuck v+ r> vmin >r v+ r>
+     ] [
+         rect-extent
+     ] if* ;
+ 
+ : screen-rect ( gadget -- rect )
+     (screen-rect) <extent-rect> ;
+ 
+ : child? ( parent child -- ? )
+     {
+         { [ 2dup eq? ] [ 2drop t ] }
+         { [ dup not ] [ 2drop f ] }
+         [ parent>> child? ]
+     } cond ;
+ 
+ GENERIC: focusable-child* ( gadget -- child/t )
+ 
+ M: gadget focusable-child* drop t ;
+ 
+ : focusable-child ( gadget -- child )
+     dup focusable-child*
+     dup t eq? [ drop ] [ nip focusable-child ] if ;
+ 
+ GENERIC: request-focus-on ( child gadget -- )
+ 
+ M: gadget request-focus-on parent>> request-focus-on ;
+ 
+ M: f request-focus-on 2drop ;
+ 
+ : request-focus ( gadget -- )
+     [ focusable-child ] keep request-focus-on ;
+ 
+ : focus-path ( world -- seq )
+     [ focus>> ] follow ;
+ 
+ ! Deprecated
+ 
+ : construct-gadget ( class -- tuple )
+     >r <gadget> { set-delegate } r> construct ; inline
diff --cc basis/ui/ui.factor
index 0000000000,29d1d16642..0e00627cb9
mode 000000,100755..100755
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@@@ -1,0 -1,221 +1,221 @@@
+ ! Copyright (C) 2006, 2007 Slava Pestov.
+ ! See http://factorcode.org/license.txt for BSD license.
+ USING: arrays assocs io kernel math models namespaces
 -prettyprint dlists dequeues sequences threads sequences words
++prettyprint dlists deques sequences threads sequences words
+ debugger ui.gadgets ui.gadgets.worlds ui.gadgets.tracks
+ ui.gestures ui.backend ui.render continuations init combinators
+ hashtables concurrency.flags sets accessors ;
+ IN: ui
+ 
+ ! Assoc mapping aliens to gadgets
+ SYMBOL: windows
+ 
+ SYMBOL: stop-after-last-window?
+ 
+ : event-loop? ( -- ? )
+     {
+         { [ stop-after-last-window? get not ] [ t ] }
 -        { [ graft-queue dequeue-empty? not ] [ t ] }
++        { [ graft-queue deque-empty? not ] [ t ] }
+         { [ windows get-global empty? not ] [ t ] }
+         [ f ]
+     } cond ;
+ 
+ : event-loop ( -- ) [ event-loop? ] [ do-events ] [ ] while ;
+ 
+ : window ( handle -- world ) windows get-global at ;
+ 
+ : window-focus ( handle -- gadget ) window world-focus ;
+ 
+ : register-window ( world handle -- )
+     #! Add the new window just below the topmost window. Why?
+     #! So that if the new window doesn't actually receive focus
+     #! (eg, we're using focus follows mouse and the mouse is not
+     #! in the new window when it appears) Factor doesn't get
+     #! confused and send workspace operations to the new window,
+     #! etc.
+     swap 2array windows get-global push
+     windows get-global dup length 1 >
+     [ [ length 1- dup 1- ] keep exchange ] [ drop ] if ;
+ 
+ : unregister-window ( handle -- )
+     windows global [ [ first = not ] with filter ] change-at ;
+ 
+ : raised-window ( world -- )
+     windows get-global
+     [ [ second eq? ] with find drop ] keep
+     [ nth ] [ delete-nth ] [ nip ] 2tri push ;
+ 
+ : focus-gestures ( new old -- )
+     drop-prefix <reversed>
+     T{ lose-focus } swap each-gesture
+     T{ gain-focus } swap each-gesture ;
+ 
+ : focus-world ( world -- )
+     t over set-world-focused?
+     dup raised-window
+     focus-path f focus-gestures ;
+ 
+ : unfocus-world ( world -- )
+     f over set-world-focused?
+     focus-path f swap focus-gestures ;
+ 
+ M: world graft*
+     dup (open-window)
+     dup world-title over set-title
+     request-focus ;
+ 
+ : reset-world ( world -- )
+     #! This is used when a window is being closed, but also
+     #! when restoring saved worlds on image startup.
+     dup world-fonts clear-assoc
+     dup unfocus-world
+     f swap set-world-handle ;
+ 
+ M: world ungraft*
+     dup free-fonts
+     dup hand-clicked close-global
+     dup hand-gadget close-global
+     dup world-handle (close-window)
+     reset-world ;
+ 
+ : find-window ( quot -- world )
+     windows get values
+     [ gadget-child swap call ] with find-last nip ; inline
+ 
+ SYMBOL: ui-hook
+ 
+ : init-ui ( -- )
+     <dlist> \ graft-queue set-global
+     <dlist> \ layout-queue set-global
+     V{ } clone windows set-global ;
+ 
+ : restore-gadget-later ( gadget -- )
+     dup gadget-graft-state {
+         { { f f } [ ] }
+         { { f t } [ ] }
+         { { t t } [
+             { f f } over set-gadget-graft-state
+         ] }
+         { { t f } [
+             dup unqueue-graft
+             { f f } over set-gadget-graft-state
+         ] }
+     } case graft-later ;
+ 
+ : restore-gadget ( gadget -- )
+     dup restore-gadget-later
+     gadget-children [ restore-gadget ] each ;
+ 
+ : restore-world ( world -- )
+     dup reset-world restore-gadget ;
+ 
+ : restore-windows ( -- )
+     windows get [ values ] keep delete-all
+     [ restore-world ] each
+     forget-rollover ;
+ 
+ : restore-windows? ( -- ? )
+     windows get empty? not ;
+ 
+ : update-hand ( world -- )
+     dup hand-world get-global eq?
+     [ hand-loc get-global swap move-hand ] [ drop ] if ;
+ 
+ : layout-queued ( -- seq )
+     [
+         in-layout? on
+         layout-queue [
+             dup layout find-world [ , ] when*
 -        ] slurp-dequeue
++        ] slurp-deque
+     ] { } make prune ;
+ 
+ : redraw-worlds ( seq -- )
+     [ dup update-hand draw-world ] each ;
+ 
+ : notify ( gadget -- )
+     dup gadget-graft-state
+     dup first { f f } { t t } ?
+     pick set-gadget-graft-state {
+         { { f t } [ dup activate-control graft* ] }
+         { { t f } [ dup deactivate-control ungraft* ] }
+     } case ;
+ 
+ : notify-queued ( -- )
 -    graft-queue [ notify ] slurp-dequeue ;
++    graft-queue [ notify ] slurp-deque ;
+ 
+ : update-ui ( -- )
+     [ notify-queued layout-queued redraw-worlds ] assert-depth ;
+ 
+ : ui-wait ( -- )
+     10 sleep ;
+ 
+ : ui-try ( quot -- ) [ ui-error ] recover ;
+ 
+ SYMBOL: ui-thread
+ 
+ : ui-running ( quot -- )
+     t \ ui-running set-global
+     [ f \ ui-running set-global ] [ ] cleanup ; inline
+ 
+ : ui-running? ( -- ? )
+     \ ui-running get-global ;
+ 
+ : update-ui-loop ( -- )
+     ui-running? ui-thread get-global self eq? and [
+         ui-notify-flag get lower-flag
+         [ update-ui ] ui-try
+         update-ui-loop
+     ] when ;
+ 
+ : start-ui-thread ( -- )
+     [ self ui-thread set-global update-ui-loop ]
+     "UI update" spawn drop ;
+ 
+ : open-world-window ( world -- )
+     dup pref-dim over (>>dim) dup relayout graft ;
+ 
+ : open-window ( gadget title -- )
+     f <world> open-world-window ;
+ 
+ : set-fullscreen? ( ? gadget -- )
+     find-world set-fullscreen* ;
+ 
+ : fullscreen? ( gadget -- ? )
+     find-world fullscreen* ;
+ 
+ : raise-window ( gadget -- )
+     find-world raise-window* ;
+ 
+ HOOK: close-window ui-backend ( gadget -- )
+ 
+ M: object close-window
+     find-world [ ungraft ] when* ;
+ 
+ : start-ui ( -- )
+     restore-windows? [
+         restore-windows
+     ] [
+         init-ui ui-hook get call
+     ] if
+     notify-ui-thread start-ui-thread ;
+ 
+ [
+     f \ ui-running set-global
+     <flag> ui-notify-flag set-global
+ ] "ui" add-init-hook
+ 
+ HOOK: ui ui-backend ( -- )
+ 
+ MAIN: ui
+ 
+ : with-ui ( quot -- )
+     ui-running? [
+         call
+     ] [
+         f windows set-global
+         [
+             ui-hook set
+             stop-after-last-window? on
+             ui
+         ] with-scope
+     ] if ;