presentations and menus

TODO.FACTOR.txt

@@ -6,6 +6,8 @@
 
 + ui:
 
+- menu dragging
+- hide menu after item selected
 - scrollable inspector
 - inspector needs prettier nesting
 - <titled> needs to look better
@@ -16,9 +18,7 @@
 - console: scroll to bottom
 - split preferred size and layouting
 - remove shelf/pile duplication
-- menus
-- layered gadget
-- resizing and moving gadgets interactively with halo on top of gadget
+- resizing and moving gadgets
 - faster layout
 - faster repaint
 

examples/gadget-test.factor

@@ -74,6 +74,7 @@ USE: words
 
 : gadget-demo ( -- )
     make-shapes
-    start-world ;
+    USE: shells
+    ui ;
 
 gadget-demo

library/bootstrap/boot-stage2.factor

@@ -173,15 +173,16 @@ cpu "x86" = "mini" get not and [
         "/library/ui/gestures.factor"
         "/library/ui/hand.factor"
         "/library/ui/layouts.factor"
+        "/library/ui/halo.factor"
         "/library/ui/world.factor"
         "/library/ui/labels.factor"
         "/library/ui/buttons.factor"
         "/library/ui/line-editor.factor"
         "/library/ui/editors.factor"
-        "/library/ui/halo.factor"
         "/library/ui/dialogs.factor"
         "/library/ui/events.factor"
         "/library/ui/scrolling.factor"
+        "/library/ui/presentations.factor"
         "/library/ui/panes.factor"
         "/library/ui/inspector.factor"
     ] [

library/ui/editors.factor

@@ -55,7 +55,7 @@ TUPLE: editor line caret delegate ;
     request-focus ;
 
 : editor-actions ( editor -- )
-    {{
+    [
         [[ [ gain-focus ] [ focus-editor ] ]]
         [[ [ lose-focus ] [ unfocus-editor ] ]]
         [[ [ button-down 1 ] [ click-editor ] ]]
@@ -63,7 +63,7 @@ TUPLE: editor line caret delegate ;
         [[ [ "LEFT" ] [ [ left ] with-editor ] ]]
         [[ [ "RIGHT" ] [ [ right ] with-editor ] ]]
         [[ [ "CTRL" "k" ] [ [ line-clear ] with-editor ] ]]
-    }} clone swap set-gadget-gestures ;
+    ] swap add-actions ;
 
 : <caret> ( -- caret )
     0 0 0 0 <plain-rect> <gadget>

library/ui/gestures.factor

@@ -9,6 +9,9 @@ USING: alien generic hashtables kernel lists math sdl-event ;
 : set-action ( gadget quot gesture -- )
     rot gadget-gestures set-hash ;
 
+: add-actions ( alist gadget -- )
+    swap [ unswons set-action ] each-with ;
+
 : handle-gesture* ( gesture gadget -- ? )
     tuck gadget-gestures hash* dup [
         cdr call f

library/ui/halo.factor

@@ -1,7 +1,9 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: kernel math namespaces ;
+USING: kernel math namespaces sdl ;
+
+! The halo is used to move and resize gadgets.
 
 : grab ( gadget hand -- )
     [ swap screen-pos swap screen-pos - >rect ] 2keep

library/ui/inspector.factor

@@ -1,16 +1,9 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
 USING: gadgets generic hashtables kernel kernel-internals lists
 namespaces unparser vectors words ;
 
-DEFER: inspect
-
-: <presentation> ( obj -- gadget )
-    dup unparse <label> [
-        swap
-        [ \ drop , literal, \ inspect , ] make-list
-        [ button-up 1 ] set-action
-    ] keep
-    dup [ drop ] [ button-down 1 ] set-action ;
-
 : label-box ( list -- gadget )
     <line-pile> swap [ <presentation> over add-gadget ] each ;
 

library/ui/labels.factor

@@ -1,18 +1,28 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic kernel lists math namespaces sdl sdl-ttf ;
+USING: generic kernel lists math namespaces sdl sdl-ttf stdio ;
 
-! A label draws a text label, centered on the gadget's bounding
-! box.
+! A label gadget draws a string.
 TUPLE: label text delegate ;
 
 C: label ( text -- )
     <empty-gadget> over set-label-delegate
     [ set-label-text ] keep ;
 
+: update-rollover ( gadget -- )
+    dup dup my-hand hand-gadget child?
+    rollover? set-paint-property redraw ;
+
+: <roll-label> ( text -- )
+    #! A label that shows an outline when the mouse is over it.
+    <label> 0 0 0 0 <roll-rect> <gadget> over set-label-delegate
+    dup [ update-rollover ] [ mouse-enter ] set-action
+    dup [ update-rollover ] [ mouse-leave ] set-action ;
+
 M: label layout* ( label -- )
     [ label-text dup shape-w swap shape-h ] keep resize-gadget ;
 
 M: label draw-shape ( label -- )
+    dup label-delegate draw-shape
     dup shape-pos [ label-text draw-shape ] with-trans ;

library/ui/layouts.factor

@@ -84,17 +84,16 @@ M: shelf layout* ( pile -- )
 ! a 5-pixel padding.
 TUPLE: border size delegate ;
 
-C: border ( delegate size -- border )
-    [ set-border-size ] keep [ set-border-delegate ] keep ;
-
-: standard-border ( child delegate -- border )
-    5 <border> [ over [ add-gadget ] [ 2drop ] ifte ] keep ;
+C: border ( child delegate size -- border )
+    [ set-border-size ] keep
+    [ set-border-delegate ] keep
+    [ over [ add-gadget ] [ 2drop ] ifte ] keep ;
 
 : empty-border ( child -- border )
-    <empty-gadget> standard-border ;
+    <empty-gadget> 5 <border> ;
 
 : line-border ( child -- border )
-    0 0 0 0 <etched-rect> <gadget> standard-border ;
+    0 0 0 0 <etched-rect> <gadget> 5 <border> ;
 
 : size-border ( border -- )
     dup gadget-children

library/ui/menus.factor

@@ -0,0 +1,35 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: kernel lists math namespaces ;
+
+: hide-menu ( world -- )
+    dup world-menu [ unparent ] when* f swap set-world-menu ;
+
+: show-menu ( menu -- )
+    world get dup hide-menu
+    2dup set-world-menu
+    2dup world-hand screen-pos >rect rot move-gadget
+    add-gadget ;
+
+: menu-item-border ( child -- border )
+    0 0 0 0 <plain-rect> <gadget> 1 <border> ;
+
+: <menu-item> ( label quot -- gadget )
+    >r <label> menu-item-border dup r> button-actions ;
+
+TUPLE: menu delegate ;
+
+: menu-actions ( menu -- )
+    [ drop world get hide-menu ] [ button-up 1 ] set-action ;
+
+C: menu ( assoc -- gadget )
+    #! Given an association list mapping labels to quotations.
+    [ f line-border swap set-menu-delegate ] keep
+    <line-pile> [ swap add-gadget ] 2keep
+    rot [ uncons <menu-item> swap add-gadget ] each-with
+    dup menu-actions ;
+
+! While a menu is open, clicking anywhere sends the click to
+! the menu.
+M: menu inside? ( point menu -- ? ) 2drop t ;

library/ui/paint.factor

@@ -2,7 +2,7 @@
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
 USING: generic hashtables kernel lists math namespaces sdl
-sdl-gfx sdl-ttf sdl-video strings ;
+sdl-gfx sdl-ttf sdl-video stdio strings ;
 
 ! The painting protocol. Painting is controlled by various
 ! dynamically-scoped variables.
@@ -27,10 +27,9 @@ SYMBOL: font  ! a list of two elements, a font name and size.
 
 GENERIC: draw-shape ( obj -- )
 
-! Actual rectangles don't draw; use a hollow-rect, plain-rect
-! or bevel-rect instead.
 M: rectangle draw-shape drop ;
 
+! A rectangle only whose outline is visible.
 TUPLE: hollow-rect delegate ;
 
 C: hollow-rect ( x y w h -- rect )
@@ -39,6 +38,7 @@ C: hollow-rect ( x y w h -- rect )
 M: hollow-rect draw-shape ( rect -- )
     >r surface get r> rect>screen fg rgb rectangleColor ;
 
+! A rectangle that is filled.
 TUPLE: plain-rect delegate ;
 
 C: plain-rect ( x y w h -- rect )
@@ -47,6 +47,7 @@ C: plain-rect ( x y w h -- rect )
 M: plain-rect draw-shape ( rect -- )
     >r surface get r> rect>screen bg rgb boxColor ;
 
+! A rectangle that is filled, and has a visible outline.
 TUPLE: etched-rect delegate ;
 
 C: etched-rect ( x y w h -- rect )
@@ -57,6 +58,22 @@ M: etched-rect draw-shape ( rect -- )
     rect>screen bg rgb boxColor
     rect>screen fg rgb rectangleColor ;
 
+! A rectangle that has a visible outline only if the rollover
+! paint property is set.
+SYMBOL: rollover?
+
+TUPLE: roll-rect delegate ;
+
+C: roll-rect ( x y w h -- rect )
+    [ >r <rectangle> r> set-roll-rect-delegate ] keep ;
+
+M: roll-rect draw-shape ( rect -- )
+    rollover? get [
+        >r surface get r> rect>screen fg rgb rectangleColor
+    ] [
+        drop
+    ] ifte ;
+
 M: line draw-shape ( line -- )
     >r surface get r>
     line>screen

library/ui/panes.factor

@@ -30,12 +30,12 @@ TUPLE: pane output current input continuation delegate ;
     pane-continuation call ;
  
 : pane-actions ( line -- )
-    {{
+    [
         [[ [ button-down 1 ] [ pane-input click-editor ] ]]
         [[ [ "RETURN" ] [ pane-return ] ]]
         [[ [ "UP" ] [ pane-input [ history-prev ] with-editor ] ]]
         [[ [ "DOWN" ] [ pane-input [ history-next ] with-editor ] ]]
-    }} clone swap set-gadget-gestures ;
+    ] swap add-actions ;
 
 C: pane ( -- pane )
     <line-pile> over set-pane-delegate

library/ui/presentations.factor

@@ -0,0 +1,29 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: kernel lists unparser ;
+
+DEFER: inspect
+
+: actionize ( obj assoc -- assoc )
+    [
+        unswons >r >r unit [ car ] cons r> append r> swons
+    ] map-with ;
+
+: object-menu ( obj -- assoc )
+    [
+        [[ "Inspect" [ inspect ] ]]
+    ] actionize ;
+
+TUPLE: presentation object delegate ;
+
+: presentation-actions ( presentation -- )
+    dup
+    [ drop ] [ button-up 1 ] set-action
+    [ presentation-object object-menu <menu> show-menu ]
+    [ button-down 1 ] set-action ;
+
+C: presentation ( obj -- gadget )
+    over unparse <roll-label> over set-presentation-delegate
+    [ set-presentation-object ] keep
+    dup presentation-actions ;

library/ui/scrolling.factor

@@ -24,9 +24,9 @@ TUPLE: viewport x y delegate ;
     1 swap scroll-viewport ;
 
 : viewport-actions ( viewport -- )
-    {{
+    [
         [[ [ scroll>bottom ] [ scroll>bottom ] ]]
-    }} clone swap set-gadget-gestures ;
+    ] swap add-actions ;
 
 C: viewport ( content -- viewport )
     [ <empty-gadget> swap set-viewport-delegate ] keep

library/ui/world.factor

@@ -1,13 +1,14 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: alien generic kernel lists math namespaces sdl sdl-event
-sdl-video stdio strings threads ;
+USING: alien generic kernel lists math memory namespaces sdl
+sdl-event sdl-video stdio strings threads ;
 
 ! The world gadget is the top level gadget that all (visible)
 ! gadgets are contained in. The current world is stored in the
-! world variable.
-TUPLE: world running? hand delegate ;
+! world variable. The menu slot ensures that only one menu is
+! open at any one time.
+TUPLE: world running? hand menu delegate ;
 
 : <world-box> ( -- box )
     0 0 0 0 <plain-rect> <gadget> ;
@@ -55,12 +56,23 @@ DEFER: handle-event
         drop world get world-step [ yield run-world ] when
     ] ifte ;
 
-: title ( -- str )
-    "Factor " version cat2 ;
+SYMBOL: root-menu
+
+: show-root-menu ( -- )
+    root-menu get <menu> show-menu ;
 
 global [
+    [
+        [[ "Listener" [ <console-pane> <scroller> world get add-gadget ] ]]
+        [[ "Globals" [ global inspect ] ]]
+        [[ "Save image" [ "image" get save-image ] ]]
+        [[ "Exit" [ f world get set-world-running? ] ]]
+    ] root-menu set
+    
     <world> world set
+    
     1280 1024 world get resize-gadget
+    
     {{
 
         [[ background [ 255 255 255 ] ]]
@@ -70,8 +82,13 @@ global [
         [[ reverse-video f ]]
         [[ font       [[ "Sans Serif" 12 ]] ]]
     }} world get set-gadget-paint
+
+    world get [ drop show-root-menu ] [ button-down 1 ] set-action
 ] bind
 
+: title ( -- str )
+    "Factor " version cat2 ;
+
 IN: shells
 
 : ui ( -- )
@@ -82,6 +99,6 @@ IN: shells
     [
         0 x set 0 y set [
             title dup SDL_WM_SetCaption
-            <event> run-world
+            run-world
         ] with-screen
     ] with-scope ;