--- /dev/null
-tools.test namespaces models kernel dlists dequeues math sets
+ IN: ui.gadgets.tests
+ USING: accessors ui.gadgets ui.gadgets.packs ui.gadgets.worlds
- [ t ] [ graft-queue dequeue-empty? ] unit-test
++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 [
- [ f ] [ graft-queue dequeue-empty? ] unit-test
++ [ t ] [ graft-queue deque-empty? ] unit-test
+
+ <mock-gadget> "g" set
+ [ ] [ "g" get queue-graft ] unit-test
- [ t ] [ 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
- [ ] [ graft-queue [ "x" print notify ] slurp-dequeue ] 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-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
--- /dev/null
- binary-search vectors dlists dequeues models threads
+ ! 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 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
--- /dev/null
-prettyprint dlists dequeues sequences threads sequences words
+ ! Copyright (C) 2006, 2007 Slava Pestov.
+ ! See http://factorcode.org/license.txt for BSD license.
+ USING: arrays assocs io kernel math models namespaces
- { [ graft-queue dequeue-empty? not ] [ t ] }
++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 ] }
- ] slurp-dequeue
++ { [ 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*
- graft-queue [ notify ] 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-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 ;
projects / factor.git / commitdiff