Simplifying UI code dealing with worlds

library/bootstrap/boot-stage1.factor

@@ -169,9 +169,8 @@ vectors words ;
         "/library/ui/world.factor"
         "/library/ui/paint.factor"
         "/library/ui/theme.factor"
-        "/library/ui/gestures.factor"
         "/library/ui/labels.factor"
-        "/library/ui/hand.factor"
+        "/library/ui/gestures.factor"
         "/library/ui/frames.factor"
         "/library/ui/borders.factor"
         "/library/ui/buttons.factor"

library/cocoa/ui.factor

@@ -166,16 +166,13 @@ H{ } clone views set-global
     FactorView over rect-dim <GLView>
     [ over set-world-handle dup add-notify register-view ] keep ;
 
-: <FactorWindow> ( gadget title -- window )
-    >r <FactorView> r> <ViewWindow> dup [contentView] [release] ;
-
 IN: gadgets
 
 : redraw-world ( handle -- )
     world-handle 1 [setNeedsDisplay:] ;
 
-: in-window ( gadget status dim title -- )
+: in-window ( world title -- )
-    >r <world> r> <FactorWindow> drop ;
+    >r <FactorView> r> <ViewWindow> [contentView] [release] ;
 
 : select-gl-context ( handle -- )
     [openGLContext] [makeCurrentContext] ;

library/ui/backend.factor

@@ -5,7 +5,7 @@ DEFER: draw-world ! defined in world.factor
 
 : redraw-world ( world -- ) draw-world ;
 
-DEFER: in-window ( gadget status dim title -- )
+DEFER: in-window ( world title -- )
 
 DEFER: select-gl-context ( handle -- )
 

library/ui/browser.factor

@@ -72,12 +72,12 @@ C: browser ( obj -- browser )
 
 TUPLE: browser-button object ;
 
-: in-browser ( obj -- )
+: browser-window ( obj -- )
     <browser> "Browser" simple-window ;
 
 : browser-button-action ( button -- )
     [ browser-button-object ] keep find-browser
-    [ dup save-current browse ] [ in-browser ] if* ;
+    [ dup save-current browse ] [ browser-window ] if* ;
 
 C: browser-button ( gadget object -- button )
     [ set-browser-button-object ] keep

library/ui/environment.factor

@@ -0,0 +1,39 @@
+! Copyright (C) 2006 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: gadgets gadgets-labels gadgets-layouts gadgets-theme
+hashtables kernel math namespaces queues sequences threads ;
+
+: layout-queued ( -- )
+    invalid dup queue-empty? [
+        drop
+    ] [
+        deque dup layout
+        find-world [ dup world-handle set ] when*
+        layout-queued
+    ] if ;
+
+: init-ui ( -- )
+    H{ } clone \ timers set-global
+    <queue> \ invalid set-global ;
+    
+: ui-step ( -- )
+    do-timers
+    [ layout-queued ] make-hash hash-values
+    [ dup world-handle [ draw-world ] [ drop ] if ] each
+    10 sleep ;
+
+: close-global ( world global -- )
+    dup get-global find-world rot eq?
+    [ f swap set-global ] [ drop ] if ;
+
+: close-world ( world -- )
+    dup hand-clicked close-global
+    dup hand-gadget close-global
+    f over request-focus* dup remove-notify
+    dup free-fonts f swap set-world-handle ;
+
+: <status-bar> ( -- gadget ) "" <label> dup highlight-theme ;
+
+: simple-window ( gadget title -- )
+    >r <status-bar> <world> dup prefer r> in-window ;

library/ui/gestures.factor

@@ -1,7 +1,8 @@
-! Copyright (C) 2005 Slava Pestov.
+! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets
-USING: alien generic hashtables kernel lists math sequences ;
+USING: gadgets-labels gadgets-layouts hashtables kernel math
+namespaces queues sequences threads ;
 
 : action ( gadget gesture -- quot )
     swap gadget-gestures ?hash ;
@@ -41,3 +42,111 @@ SYMBOL: mouse-leave
 
 SYMBOL: lose-focus
 SYMBOL: gain-focus
+
+! Hand state
+
+! Note that these are only really useful inside an event
+! handler, and that the locations hand-loc and hand-click-loc
+! are in the co-ordinate system of the world which contains
+! the gadget in question.
+SYMBOL: hand-gadget
+SYMBOL: hand-loc
+{ 0 0 0 } hand-loc set-global
+
+SYMBOL: hand-clicked
+SYMBOL: hand-click-loc
+
+SYMBOL: hand-buttons
+V{ } clone hand-buttons set-global
+
+: button-gesture ( buttons gesture -- )
+    #! Send a gesture like [ button-down 2 ]; if nobody
+    #! handles it, send [ button-down ].
+    swap hand-clicked get-global 3dup >r add r> handle-gesture
+    [ nip handle-gesture drop ] [ 3drop ] if ;
+
+: drag-gesture ( -- )
+    #! Send a gesture like [ drag 2 ]; if nobody handles it,
+    #! send [ drag ].
+    hand-buttons get-global first [ drag ] button-gesture ;
+
+: fire-motion ( -- )
+    #! Fire a motion gesture to the gadget underneath the hand,
+    #! and if a mouse button is down, fire a drag gesture to the
+    #! gadget that was clicked.
+    [ motion ] hand-gadget get-global handle-gesture drop
+    hand-buttons get-global empty? [ drag-gesture ] unless ;
+
+: each-gesture ( gesture seq -- )
+    [ handle-gesture* drop ] each-with ;
+
+: hand-gestures ( new old -- )
+    drop-prefix reverse-slice
+    [ mouse-leave ] swap each-gesture
+    fire-motion
+    [ mouse-enter ] swap each-gesture ;
+
+: focus-gestures ( new old -- )
+    drop-prefix reverse-slice
+    [ lose-focus ] swap each-gesture
+    [ gain-focus ] swap each-gesture ;
+
+: request-focus* ( gadget world -- )
+    dup focused-ancestors >r
+    [ set-world-focus ] keep
+    focused-ancestors r> focus-gestures ;
+
+: request-focus ( gadget -- )
+    dup focusable-child swap find-world request-focus* ;
+
+: modifier ( mod modifiers -- seq )
+    [ second swap bitand 0 > ] subset-with
+    [ first ] map ;
+
+: drag-loc ( -- loc )
+    hand-loc get-global hand-click-loc get-global v- ;
+
+: hand-click-rel ( gadget -- loc )
+    hand-click-loc get-global relative-loc ;
+
+: relevant-help ( seq -- help )
+    [ gadget-help ] map [ ] find nip ;
+
+: show-message ( string/f -- )
+    #! Show a message in the status bar.
+    world-status [ set-label-text* ] [ drop ] if* ;
+
+: update-help ( -- )
+    #! Update mouse-over help message.
+    hand-gadget get-global parents [ relevant-help ] keep
+    dup empty? [ 2drop ] [ peek show-message ] if ;
+
+: under-hand ( -- seq )
+    #! A sequence whose first element is the world and last is
+    #! the current gadget, with all parents in between.
+    hand-gadget get-global parents reverse-slice ;
+
+: move-hand ( loc world -- )
+    under-hand >r over hand-loc set-global
+    pick-up hand-gadget set-global
+    under-hand r> hand-gestures update-help ;
+
+: update-clicked ( loc world -- )
+    move-hand
+    hand-gadget get-global hand-clicked set-global
+    hand-loc get-global hand-click-loc set-global ;
+
+: send-button-down ( button# loc world -- )
+    update-clicked
+    dup hand-buttons get-global push
+    [ button-down ] button-gesture ;
+
+: send-button-up ( event loc world -- )
+    move-hand
+    dup hand-buttons get-global delete
+    [ button-up ] button-gesture ;
+
+: send-wheel ( up/down loc world -- )
+    move-hand
+    [ wheel-up ] [ wheel-down ] ?
+    hand-gadget get-global handle-gesture drop ;

library/ui/hand.factor

@@ -1,142 +0,0 @@
-! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-IN: gadgets
-USING: gadgets-labels gadgets-layouts hashtables kernel math
-namespaces queues sequences threads ;
-
-! Hand state
-
-! Note that these are only really useful inside an event
-! handler, and that the locations hand-loc and hand-click-loc
-! are in the co-ordinate system of the world which contains
-! the gadget in question.
-SYMBOL: hand-gadget
-SYMBOL: hand-loc
-{ 0 0 0 } hand-loc set-global
-
-SYMBOL: hand-clicked
-SYMBOL: hand-click-loc
-
-SYMBOL: hand-buttons
-V{ } clone hand-buttons set-global
-
-: button-gesture ( buttons gesture -- )
-    #! Send a gesture like [ button-down 2 ]; if nobody
-    #! handles it, send [ button-down ].
-    swap hand-clicked get-global 3dup >r add r> handle-gesture
-    [ nip handle-gesture drop ] [ 3drop ] if ;
-
-: drag-gesture ( -- )
-    #! Send a gesture like [ drag 2 ]; if nobody handles it,
-    #! send [ drag ].
-    hand-buttons get-global first [ drag ] button-gesture ;
-
-: fire-motion ( -- )
-    #! Fire a motion gesture to the gadget underneath the hand,
-    #! and if a mouse button is down, fire a drag gesture to the
-    #! gadget that was clicked.
-    [ motion ] hand-gadget get-global handle-gesture drop
-    hand-buttons get-global empty? [ drag-gesture ] unless ;
-
-: each-gesture ( gesture seq -- )
-    [ handle-gesture* drop ] each-with ;
-
-: hand-gestures ( new old -- )
-    drop-prefix reverse-slice
-    [ mouse-leave ] swap each-gesture
-    fire-motion
-    [ mouse-enter ] swap each-gesture ;
-
-: focus-gestures ( new old -- )
-    drop-prefix reverse-slice
-    [ lose-focus ] swap each-gesture
-    [ gain-focus ] swap each-gesture ;
-
-: request-focus* ( gadget world -- )
-    dup focused-ancestors >r
-    [ set-world-focus ] keep
-    focused-ancestors r> focus-gestures ;
-
-: request-focus ( gadget -- )
-    dup focusable-child swap find-world request-focus* ;
-
-: modifier ( mod modifiers -- seq )
-    [ second swap bitand 0 > ] subset-with
-    [ first ] map ;
-
-: drag-loc ( -- loc )
-    hand-loc get-global hand-click-loc get-global v- ;
-
-: hand-click-rel ( gadget -- loc )
-    hand-click-loc get-global relative-loc ;
-
-: relevant-help ( seq -- help )
-    [ gadget-help ] map [ ] find nip ;
-
-: show-message ( string/f -- )
-    #! Show a message in the status bar.
-    world-status [ set-label-text* ] [ drop ] if* ;
-
-: update-help ( -- )
-    #! Update mouse-over help message.
-    hand-gadget get-global parents [ relevant-help ] keep
-    dup empty? [ 2drop ] [ peek show-message ] if ;
-
-: under-hand ( -- seq )
-    #! A sequence whose first element is the world and last is
-    #! the current gadget, with all parents in between.
-    hand-gadget get-global parents reverse-slice ;
-
-: move-hand ( loc world -- )
-    under-hand >r over hand-loc set-global
-    pick-up hand-gadget set-global
-    under-hand r> hand-gestures update-help ;
-
-: update-clicked ( loc world -- )
-    move-hand
-    hand-gadget get-global hand-clicked set-global
-    hand-loc get-global hand-click-loc set-global ;
-
-: send-button-down ( button# loc world -- )
-    update-clicked
-    dup hand-buttons get-global push
-    [ button-down ] button-gesture ;
-
-: send-button-up ( event loc world -- )
-    move-hand
-    dup hand-buttons get-global delete
-    [ button-up ] button-gesture ;
-
-: send-wheel ( up/down loc world -- )
-    move-hand
-    [ wheel-up ] [ wheel-down ] ?
-    hand-gadget get-global handle-gesture drop ;
-
-: layout-queued ( -- )
-    invalid dup queue-empty? [
-        drop
-    ] [
-        deque dup layout
-        find-world [ dup world-handle set ] when*
-        layout-queued
-    ] if ;
-
-: init-ui ( -- )
-    H{ } clone \ timers set-global
-    <queue> \ invalid set-global ;
-    
-: ui-step ( -- )
-    do-timers
-    [ layout-queued ] make-hash hash-values
-    [ dup world-handle [ draw-world ] [ drop ] if ] each
-    10 sleep ;
-
-: close-global ( world global -- )
-    dup get-global find-world rot eq?
-    [ f swap set-global ] [ drop ] if ;
-
-: close-world ( world -- )
-    dup hand-clicked close-global
-    dup hand-gadget close-global
-    f over request-focus* dup remove-notify
-    dup free-fonts f swap set-world-handle ;

library/ui/hierarchy.factor

@@ -98,5 +98,3 @@ IN: gadgets-layouts
 : make-pile ( children -- pack ) <pile> [ add-gadgets ] keep ;
 
 : make-shelf ( children -- pack ) <shelf> [ add-gadgets ] keep ;
-
-: make-stack ( children -- pack ) <stack> [ add-gadgets ] keep ;

library/ui/labels.factor

@@ -17,15 +17,13 @@ C: label ( text -- label )
     2dup label-text =
     [ 2dup [ set-label-text ] keep relayout ] unless 2drop ;
 
-: label-font* ( label -- font )
+: label-font* ( label -- font ) label-font lookup-font ;
-    label-font lookup-font ;
 
 : label-size ( gadget text -- dim )
     dup label-font* dup font-height >r
     swap label-text string-width r> 0 3array ;
 
-M: label pref-dim* ( label -- dim )
+M: label pref-dim* ( label -- dim ) label-size ;
-    label-size ;
 
 : draw-label ( label -- )
     dup label-color gl-color

library/ui/launchpad.factor

@@ -13,10 +13,10 @@ namespaces sequences ;
     make-pane <scroller> "Scratch" simple-window ;
 
 : handbook-window ( -- )
-    T{ link f "handbook" } in-browser ;
+    T{ link f "handbook" } browser-window ;
 
 : tutorial-window ( -- )
-    T{ link f "tutorial" } in-browser ;
+    T{ link f "tutorial" } browser-window ;
 
 : default-launchpad
     {
@@ -24,7 +24,7 @@ namespaces sequences ;
         { "Documentation" [ handbook-window ] }
         { "Tutorial" [ tutorial-window ] }
         { "Vocabularies" [ [ vocabs. ] scratch-window ] }
-        { "Globals" [ global in-browser ] }
+        { "Globals" [ global browser-window ] }
         { "Memory" [ [ heap-stats. terpri room. ] scratch-window ] }
         { "Save image" [ save ] }
         { "Exit" [ 0 exit ] }

library/ui/layouts.factor

@@ -142,12 +142,3 @@ M: pack children-on ( rect pack -- list )
         >r >r rect-loc r> r> fast-children-on 0 max
         r>
     ] keep <slice> ;
-
-TUPLE: stack ;
-
-C: stack ( -- gadget )
-    #! A stack lays out all its children on top of each other.
-    { 0 0 1 } over delegate>pack 1 over set-pack-fill ;
-
-M: stack children-on ( point stack -- gadget )
-    nip gadget-children ;

library/ui/listener.factor

@@ -1,5 +1,5 @@
 ! Copyright (C) 2005, 2006 Slava Pestov.
-! See http://factor.sf.net/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
 IN: gadgets-listener
 USING: arrays gadgets gadgets-editors gadgets-labels
 gadgets-layouts gadgets-panes gadgets-scrolling
@@ -7,7 +7,7 @@ gadgets-splitters gadgets-theme generic hashtables
 io jedit kernel listener lists math
 namespaces parser prettyprint sequences threads words ;
 
-TUPLE: listener-gadget pane stack status ;
+TUPLE: listener-gadget pane stack ;
 
 : usable-words ( -- words )
     use get hash-concat hash-values ;
@@ -38,21 +38,20 @@ TUPLE: listener-gadget pane stack status ;
         print-banner listener
     ] with-stream* ;
 
-: <status-bar> ( -- gadget ) "" <label> dup highlight-theme ;
-
 : <stack-bar> ( -- gadget ) <shelf> dup highlight-theme ;
 
+: start-listener ( listener -- )
+    [ >r clear r> listener-thread ] in-thread ;
+
 C: listener-gadget ( -- gadget )
     dup delegate>frame
     <input-pane> dup pick set-listener-gadget-pane
     <scroller> over @center frame-add
-    <status-bar> dup pick set-listener-gadget-status
-    over @bottom frame-add
     <stack-bar> dup pick set-listener-gadget-stack
-    over @top frame-add ;
+    over @top frame-add
+    dup start-listener ;
+
+M: listener-gadget pref-dim* drop { 600 600 0 } ;
 
 : listener-window ( -- )
-    <listener-gadget> dup dup listener-gadget-status
+    <listener-gadget> "Listener" simple-window ;
-    { 600 700 0 } "Listener" in-window
-    [ >r clear r> listener-thread ] in-thread
-    listener-gadget-pane request-focus ;

library/ui/world.factor

@@ -19,13 +19,15 @@ TUPLE: world status focus fonts handle ;
 : font-sprites ( font world -- sprites )
     world-fonts [ drop V{ } clone ] cache ;
 
-C: world ( gadget status dim -- world )
+: add-status ( status world -- )
-    <stack> over set-delegate
+    [ set-world-status ] 2keep @bottom frame-add ;
+
+C: world ( gadget status -- world )
+    dup delegate>frame
     t over set-gadget-root?
     H{ } clone over set-world-fonts
-    [ set-gadget-dim ] keep
+    [ add-status ] keep
-    [ set-world-status ] keep
+    [ @center frame-add ] keep ;
-    [ add-gadget ] keep ;
 
 GENERIC: find-world ( gadget -- world )
 
@@ -35,8 +37,8 @@ M: gadget find-world gadget-parent find-world ;
 
 M: world find-world ;
 
+M: world pref-dim* ( world -- dim )
+    delegate pref-dim* { 1024 768 0 } vmin ;
+
 : focused-ancestors ( world -- seq )
     world-focus parents reverse-slice ;
-
-: simple-window ( gadget title -- )
-    >r f over pref-dim { 800 800 0 } vmin r> in-window ;

library/x11/ui.factor

@@ -110,8 +110,7 @@ M: world client-event ( event world -- )
 
 IN: gadgets
 
-: in-window ( gadget status dim title -- )
+: in-window ( world title -- ) swap gadget-window set-title ;
-    >r <world> gadget-window r> swap set-title ;
 
 : select-gl-context ( handle -- )
     dpy get swap first2 glXMakeCurrent