UI work

TODO.FACTOR.txt

@@ -6,14 +6,11 @@
 
 + ui:
 
-- inspector: complain if UI not running
+- mouse enter onto overlapping with interior, but not child, gadget
-- opening listeners fails
 - menu dragging
-- hide menu after item selected
 - scrollable inspector
 - inspector needs prettier nesting
 - <titled> needs to look better
-- enforce inspector uniqueness
 - auto-updating inspector
 - fix up the min thumb size hack
 - fix up initial layout of slider
@@ -23,6 +20,7 @@
 - resizing and moving gadgets
 - faster layout
 - faster repaint
+- closing inspectors
 
 + compiler/ffi:
 

examples/gadget-test.factor

@@ -1,80 +0,0 @@
-! TrueType font rendering demo.
-!
-! To run this code, bootstrap Factor like so:
-!
-! ./f boot.image.le32
-!     -libraries:sdl:name=libSDL.so
-!     -libraries:sdl-gfx:name=libSDL_gfx.so
-!     -libraries:sdl-ttf:name=libSDL_ttf.so
-!
-! (But all on one line)
-!
-! Then, start Factor as usual (./f factor.image) and enter this
-! at the listener:
-!
-! "examples/text-demo.factor" run-file
-
-IN: text-demo
-USING: listener parser threads unparser ;
-USE: streams
-USE: sdl
-USE: sdl-event
-USE: sdl-gfx
-USE: sdl-video
-USE: sdl-ttf
-USE: namespaces
-USE: math
-USE: kernel
-USE: test
-USE: compiler
-USE: strings
-USE: alien
-USE: prettyprint
-USE: lists
-USE: gadgets
-USE: generic
-USE: stdio
-USE: prettyprint
-USE: words
-
-: filled? "filled" get checkbox-selected? ;
-
-: <funny-rect>
-    filled? [ <plain-rect> ] [ <hollow-rect> ] ifte <gadget> dup moving-actions ;
-
-: <funny-ellipse>
-    filled? [ <plain-ellipse> ] [ <hollow-ellipse> ] ifte <gadget> dup moving-actions ;
-
-: <funny-line>
-    <line> <gadget> dup moving-actions ;
-
-
-: make-shapes ( -- )
-    f world get set-gadget-children
-    
-    0 default-gap 0 <pile> "pile" set
-    <default-shelf> "shelf" set
-!    "Close" [ "dialog" get world get remove-gadget ] <button> "shelf" get add-gadget
-!    "New Rectangle" [ drop 100 100 100 100 <funny-rect> dup [ 255 255 0 ] background set-paint-property world get add-gadget ] <button> "shelf" get add-gadget
-!    "New Ellipse" [ drop 100 100 200 100 <funny-ellipse> dup [ 0 255 0 ] background set-paint-property world get add-gadget ] <button> "shelf" get add-gadget
-!    "New Line" [ drop 100 100 200 100 <funny-line> dup [ 255 0 0 ] background set-paint-property world get add-gadget ] <button> "shelf" get add-gadget
-!    "Prompt" [ drop "Enter input text:" input-dialog . flush ] <button> "shelf" get add-gadget
-!    "Filled?" <checkbox> dup "filled" set "shelf" get add-gadget
-!    "shelf" get "pile" get add-gadget
-!    "Welcome to Factor " version cat2 <label> "pile" get add-gadget
-!    "A field."  <field> "pile" get add-gadget
-!    "Another field."  <field> "pile" get add-gadget
-    <console-pane> <scroller> "pile" get add-gadget
-
-    "pile" get line-border dup "dialog" set  dup  
- moving-actions
-  world get add-gadget 
-  
-  ;
-
-: gadget-demo ( -- )
-    make-shapes
-    USE: shells
-    ui ;
-
-gadget-demo

library/bootstrap/boot-stage2.factor

@@ -177,6 +177,7 @@ cpu "x86" = "mini" get not and [
         "/library/ui/halo.factor"
         "/library/ui/labels.factor"
         "/library/ui/buttons.factor"
+        "/library/ui/checkboxes.factor"
         "/library/ui/line-editor.factor"
         "/library/ui/editors.factor"
         "/library/ui/dialogs.factor"

library/ui/buttons.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic kernel lists math namespaces sdl ;
+USING: generic kernel lists math namespaces prettyprint sdl
+stdio ;
 
 : button-down? ( n -- ? )
     my-hand hand-buttons contains? ;
@@ -22,6 +23,7 @@ USING: generic kernel lists math namespaces sdl ;
     ] ifte ;
 
 : button-update ( button -- )
+    dup dup mouse-over? rollover? set-paint-property
     dup dup button-pressed? reverse-video set-paint-property
     redraw ;
 
@@ -44,43 +46,10 @@ USING: generic kernel lists math namespaces sdl ;
 : <button> ( label quot -- button )
     >r <label> line-border dup r> button-actions ;
 
-: <check> ( w h -- cross )
+: roll-border ( child -- border )
-    2dup >r >r 0 0 r> r> <line> <gadget>
+    0 0 0 0 <roll-rect> <gadget> 1 <border> ;
-    >r tuck neg >r >r >r 0 r> r> r> <line> <gadget> r>
-    2list <stack> ;
 
-TUPLE: checkbox bevel selected? delegate ;
+: <roll-button> ( label quot -- gadget )
-
+    #! Thinner border that is only visible when the mouse is
-: init-checkbox-bevel ( bevel checkbox -- )
+    #! over the button.
-    2dup set-checkbox-bevel add-gadget ;
+    >r <label> roll-border dup r> button-actions ;
-
-: update-checkbox ( checkbox -- )
-    #! Really, there should only be one child.
-    dup checkbox-bevel gadget-children [ unparent ] each
-    dup checkbox-selected? [
-        7 7 <check>
-    ] [
-        0 0 7 7 <rectangle> <gadget>
-    ] ifte swap checkbox-bevel add-gadget ;
-
-: toggle-checkbox ( checkbox -- )
-    dup checkbox-selected? not over set-checkbox-selected?
-    update-checkbox ;
-
-: checkbox-update ( checkbox -- )
-    dup button-pressed? >r checkbox-bevel r>
-    reverse-video set-paint-property ;
-
-: checkbox-actions ( checkbox -- )
-    dup [ toggle-checkbox ] [ action ] set-action
-    dup [ dup checkbox-update button-clicked ] [ button-up 1 ] set-action
-    dup [ checkbox-update ] [ button-down 1 ] set-action
-    dup [ checkbox-update ] [ mouse-leave ] set-action
-    [ checkbox-bevel button-update ] [ mouse-enter ] set-action ;
-
-C: checkbox ( label -- checkbox )
-    <default-shelf> over set-checkbox-delegate
-    [ f line-border swap init-checkbox-bevel ] keep
-    [ >r <label> r> add-gadget ] keep
-    dup checkbox-actions
-    dup update-checkbox ;

library/ui/checkboxes.factor

@@ -0,0 +1,45 @@
+! Copyright (C) 2005 Slava Pestov.
+! See http://factor.sf.net/license.txt for BSD license.
+IN: gadgets
+USING: generic kernel lists math namespaces sdl ;
+
+: <check> ( w h -- cross )
+    2dup >r >r 0 0 r> r> <line> <gadget>
+    >r tuck neg >r >r >r 0 r> r> r> <line> <gadget> r>
+    2list <stack> ;
+
+TUPLE: checkbox bevel selected? delegate ;
+
+: init-checkbox-bevel ( bevel checkbox -- )
+    2dup set-checkbox-bevel add-gadget ;
+
+: update-checkbox ( checkbox -- )
+    #! Really, there should only be one child.
+    dup checkbox-bevel gadget-children [ unparent ] each
+    dup checkbox-selected? [
+        7 7 <check>
+    ] [
+        0 0 7 7 <rectangle> <gadget>
+    ] ifte swap checkbox-bevel add-gadget ;
+
+: toggle-checkbox ( checkbox -- )
+    dup checkbox-selected? not over set-checkbox-selected?
+    update-checkbox ;
+
+: checkbox-update ( checkbox -- )
+    dup button-pressed? >r checkbox-bevel r>
+    reverse-video set-paint-property ;
+
+: checkbox-actions ( checkbox -- )
+    dup [ toggle-checkbox ] [ action ] set-action
+    dup [ dup checkbox-update button-clicked ] [ button-up 1 ] set-action
+    dup [ checkbox-update ] [ button-down 1 ] set-action
+    dup [ checkbox-update ] [ mouse-leave ] set-action
+    [ checkbox-bevel button-update ] [ mouse-enter ] set-action ;
+
+C: checkbox ( label -- checkbox )
+    <default-shelf> over set-checkbox-delegate
+    [ f line-border swap init-checkbox-bevel ] keep
+    [ >r <label> r> add-gadget ] keep
+    dup checkbox-actions
+    dup update-checkbox ;

library/ui/inspector.factor

@@ -1,12 +1,18 @@
 ! 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
+USING: errors gadgets generic hashtables kernel kernel-internals
-namespaces unparser vectors words ;
+lists namespaces strings unparser vectors words ;
 
 : label-box ( list -- gadget )
     <line-pile> swap [ <presentation> over add-gadget ] each ;
 
+: unparse* ( obj -- str ) dup string? [ unparse ] unless ;
+
+: sort-sheet ( assoc -- assoc )
+    #! Sort an association list whose keys are arbitrary objects
+    [ 2car swap unparse* swap unparse* str-lexi> ] sort ;
+
 : alist>sheet ( assoc -- sheet )
     unzip swap
     <default-shelf>
@@ -28,7 +34,7 @@ namespaces unparser vectors words ;
     ] map-with ;
 
 : slot-sheet ( obj -- sheet )
-    object>alist alist>sheet "Slots:" <titled> ;
+    object>alist sort-sheet alist>sheet "Slots:" <titled> ;
 
 GENERIC: custom-sheet ( obj -- gadget )
 
@@ -36,7 +42,8 @@ GENERIC: custom-sheet ( obj -- gadget )
     0 default-gap 0 <pile>
     over top-sheet over add-gadget
     over slot-sheet over add-gadget
-    swap custom-sheet over add-gadget ;
+    swap custom-sheet over add-gadget
+    line-border dup moving-actions ;
 
 M: object custom-sheet drop <empty-gadget> ;
 
@@ -50,7 +57,7 @@ M: vector custom-sheet ( array -- gadget )
     "Elements:" <titled> ;
 
 M: hashtable custom-sheet ( array -- gadget )
-    hash>alist alist>sheet "Entries:" <titled> ;
+    hash>alist sort-sheet alist>sheet "Entries:" <titled> ;
 
 M: word custom-sheet ( word -- gadget )
     word-props <inspector> empty-border "Properties:" <titled> ;
@@ -62,7 +69,25 @@ M: tuple custom-sheet ( tuple -- gadget )
         <empty-gadget>
     ] ifte* ;
 
-: inspect ( obj -- )
+! We ensure that only one inspector is open for each object.
-    <inspector> ( <scroller> )
+SYMBOL: inspectors
-    line-border dup moving-actions world get add-gadget ;
 
+: ensure-ui
+    world get dup [ world-running? ] when [
+        "Inspector cannot be used if UI not running." throw
+    ] unless ;
+
+: inspector ( obj -- gadget )
+    #! Return an existing inspector gadget for this object, or
+    #! create a new one.
+    dup inspectors get assq [
+        dup <inspector>
+        [ swap inspectors [ acons ] change ] keep
+    ] ?unless ;
+
+: inspect ( obj -- )
+    #! Show an inspector for the object. The inspector lists
+    #! slots and entries in collections.
+    ensure-ui global [ inspector world get add-gadget ] bind ;
+
+global [ inspectors off ] bind

library/ui/labels.factor

@@ -10,16 +10,6 @@ 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 ;
 

library/ui/menus.factor

@@ -3,11 +3,13 @@
 IN: gadgets
 USING: kernel lists math namespaces ;
 
-: hide-menu ( world -- )
+: hide-menu ( -- )
+    world get
     dup world-menu [ unparent ] when* f swap set-world-menu ;
 
 : show-menu ( menu -- )
-    world get dup hide-menu
+    hide-menu
+    world get
     2dup set-world-menu
     2dup world-hand screen-pos >rect rot move-gadget
     add-gadget ;
@@ -21,14 +23,20 @@ USING: kernel lists math namespaces ;
 TUPLE: menu delegate ;
 
 : menu-actions ( menu -- )
-    [ drop world get hide-menu ] [ button-up 1 ] set-action ;
+    [ drop world get hide-menu ] [ button-down 1 ] set-action ;
+
+: assoc>menu ( assoc menu -- )
+    #! Given an association list mapping labels to quotations.
+    #! Prepend a call to hide-menu to each quotation.
+    [
+        uncons \ hide-menu swons <menu-item> swap add-gadget
+    ] each-with ;
 
 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
+    rot assoc>menu dup menu-actions ;
-    dup menu-actions ;
 
 ! While a menu is open, clicking anywhere sends the click to
 ! the menu.

library/ui/paint.factor

@@ -35,8 +35,12 @@ TUPLE: hollow-rect delegate ;
 C: hollow-rect ( x y w h -- rect )
     [ >r <rectangle> r> set-hollow-rect-delegate ] keep ;
 
+: hollow-rect ( shape -- )
+    #! Draw a hollow rect with the bounds of an arbitrary shape.
+    rect>screen >r 1 - r> 1 - fg rgb rectangleColor ;
+
 M: hollow-rect draw-shape ( rect -- )
-    >r surface get r> rect>screen fg rgb rectangleColor ;
+    >r surface get r> hollow-rect ;
 
 ! A rectangle that is filled.
 TUPLE: plain-rect delegate ;
@@ -44,8 +48,12 @@ TUPLE: plain-rect delegate ;
 C: plain-rect ( x y w h -- rect )
     [ >r <rectangle> r> set-plain-rect-delegate ] keep ;
 
+: plain-rect ( shape -- )
+    #! Draw a filled rect with the bounds of an arbitrary shape.
+    rect>screen bg rgb boxColor ;
+
 M: plain-rect draw-shape ( rect -- )
-    >r surface get r> rect>screen bg rgb boxColor ;
+    >r surface get r> plain-rect ;
 
 ! A rectangle that is filled, and has a visible outline.
 TUPLE: etched-rect delegate ;
@@ -54,9 +62,7 @@ C: etched-rect ( x y w h -- rect )
     [ >r <rectangle> r> set-etched-rect-delegate ] keep ;
 
 M: etched-rect draw-shape ( rect -- )
-    >r surface get r> 2dup
+    >r surface get r> 2dup plain-rect hollow-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.
@@ -68,11 +74,8 @@ 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> 2dup
-        >r surface get r> rect>screen fg rgb rectangleColor
+    plain-rect rollover? get [ hollow-rect ] [ 2drop ] ifte ;
-    ] [
-        drop
-    ] ifte ;
 
 M: line draw-shape ( line -- )
     >r surface get r>
@@ -136,8 +139,8 @@ SYMBOL: clip
 : screen-bounds ( shape -- rect )
     [ shape-x x get + ] keep
     [ shape-y y get + ] keep
-    [ shape-w 1 + ] keep
+    [ shape-w ] keep
-    shape-h 1 +
+    shape-h
     <rectangle> ;
 
 : clip-rect ( x1 x2 y1 y2 -- rect )

library/ui/panes.factor

@@ -78,5 +78,7 @@ M: pane stream-close ( stream -- ) drop ;
 
 : <console-pane> ( -- pane )
     <pane> dup [
-        [ print-banner listener ] in-thread
+        [
+            clear  print-banner listener
+        ] in-thread
     ] with-stream ;

library/ui/presentations.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: kernel lists unparser ;
+USING: kernel lists namespaces prettyprint stdio unparser ;
 
 DEFER: inspect
 
@@ -15,15 +15,14 @@ DEFER: inspect
         [[ "Inspect" [ inspect ] ]]
     ] actionize ;
 
-TUPLE: presentation object delegate ;
+: press-presentation ( presentation obj -- )
+    #! Called when mouse is pressed over a presentation.
+    swap button-update  object-menu <menu> show-menu ;
 
-: presentation-actions ( presentation -- )
+: presentation-actions ( presentation obj -- )
-    dup
+    [ literal, \ press-presentation , ] make-list
-    [ drop ] [ button-up 1 ] set-action
-    [ presentation-object object-menu <menu> show-menu ]
     [ button-down 1 ] set-action ;
 
-C: presentation ( obj -- gadget )
+: <presentation> ( obj -- gadget )
-    over unparse <roll-label> over set-presentation-delegate
+    dup unparse [ drop ] <roll-button>
-    [ set-presentation-object ] keep
+    [ swap  presentation-actions ] keep ;
-    dup presentation-actions ;

library/ui/root-menu.factor

@@ -1,15 +1,18 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: kernel memory namespaces ;
+USING: kernel memory namespaces stdio ;
 
 SYMBOL: root-menu
 
 : show-root-menu ( -- )
     root-menu get <menu> show-menu ;
 
+: <console> ( -- console )
+    <console-pane> <scroller> line-border  dup moving-actions ;
+
 [
-    [[ "Listener" [ <console-pane> <scroller> world get add-gadget ] ]]
+    [[ "Listener" [ <console> world get add-gadget ] ]]
     [[ "Globals" [ global inspect ] ]]
     [[ "Save image" [ "image" get save-image ] ]]
     [[ "Exit" [ f world get set-world-running? ] ]]

library/ui/world.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: alien generic kernel lists math memory namespaces sdl
+USING: alien errors generic kernel lists math memory namespaces
-sdl-event sdl-video stdio strings threads ;
+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
@@ -56,6 +56,12 @@ DEFER: handle-event
         drop world get world-step [ yield run-world ] when
     ] ifte ;
 
+: ensure-ui ( -- )
+    #! Raise an error if the UI is not running.
+    world get dup [ world-running? ] when [
+        "Inspector cannot be used if UI not running." throw
+    ] unless ;
+
 global [
     
     <world> world set