nicer-looking menus in UI

TODO.FACTOR.txt

@@ -8,15 +8,12 @@
 - off-by-one error in pick-up?
 - closing ui does not stop timers
 - adding/removing timers automatically for animated gadgets
-- fix listener prompt display after presentation commands invoked
 - theme abstraction in ui
 - menu dragging
 - fix up the min thumb size hack
 - gaps in pack layout
 - find out why so many small bignums get consed
 - faster mouse tracking
-- an interior paint that is only painted on rollover and mouse press;
-  use it for menu items. give menus a gradient background
 - scroll bar: more intuitive behavior when clicking inside the elevator
 - nicer scrollbars with up/down buttons
 - icons

library/help/tutorial.factor

@@ -17,6 +17,7 @@ M: string tutorial-line <label> ;
 M: general-list tutorial-line
     car dup <label> dup rot [ pane get pane-input set-editor-text drop ] cons
     button-gestures
+    dup roll-button-theme
     dup "Monospaced" font set-paint-prop ;
 
 : <page> ( list -- gadget )
@@ -343,3 +344,7 @@ M: general-list tutorial-line
 
 : tutorial ( -- )
     <tutorial> gadget. ;
+
+: <tutorial-button>
+    "Tutorial" [ drop [ tutorial ] pane get pane-call ] <button> ;
+

library/inference/print-dataflow.factor

@@ -11,7 +11,7 @@ TUPLE: comment node text ;
 
 M: comment pprint* ( ann -- )
     "( " over comment-text " )" append3
-    swap comment-node presented swons unit format ;
+    swap comment-node presented swons unit text ;
 
 : comment, ( ? node text -- )
     rot [ <comment> , ] [ 2drop ] ifte ;

library/ui/buttons.factor

@@ -29,12 +29,20 @@ sequences io sequences styles ;
     dup mouse-over?
     [ [ action ] swap handle-gesture drop ] [ drop ] ifte ;
 
+: button-theme ( button -- )
+    dup { 216 216 216 } background set-paint-prop
+    dup f reverse-video set-paint-prop
+    << solid f >> interior set-paint-prop ;
+
+: roll-button-theme ( button -- )
+    dup f reverse-video set-paint-prop
+    dup <rollover-only> interior set-paint-prop
+    <rollover-only> boundary set-paint-prop ;
+
 : button-action ( action -- quot )
     [ [ swap handle-gesture drop ] cons ] [ [ drop ] ] ifte* ;
 
 : button-gestures ( button quot -- )
-    over f reverse-video set-paint-prop
-    over << solid f >> interior set-paint-prop
     dupd [ action ] set-action
     dup [ dup button-update button-clicked ] [ button-up 1 ] set-action
     dup [ button-update ] [ button-down 1 ] set-action
@@ -42,9 +50,11 @@ sequences io sequences styles ;
     dup [ button-update ] [ mouse-enter ] set-action
     [ drop ] [ drag 1 ] set-action ;
 
+: (button) ( label quot -- button )
+    >r <label> bevel-border dup r> button-gestures ;
+
 : <button> ( label quot -- button )
-    >r
-    <label> bevel-border
-    dup { 216 216 216 } background set-paint-prop
-    dup
-    r> button-gestures ;
+    (button) dup button-theme ;
+
+: <roll-button> ( label quot -- button )
+    (button) dup roll-button-theme ;

library/ui/menus.factor

@@ -10,7 +10,8 @@ USING: generic kernel lists math namespaces sequences ;
     <plain-gadget> { 1 1 0 } <border> ;
 
 : <menu-item> ( label quot -- gadget )
-    >r <label> menu-item-border dup r> button-gestures ;
+    >r <label> menu-item-border dup roll-button-theme dup
+    r> button-gestures ;
 
 TUPLE: menu ;
 
@@ -24,8 +25,13 @@ TUPLE: menu ;
         uncons \ hide-glass swons <menu-item> swap add-gadget
     ] each-with ;
 
+: menu-theme ( menu -- )
+    << gradient f { 1 0 0 } { 240 240 255 } { 216 216 216 } >>
+    interior set-paint-prop ;
+
 C: menu ( assoc -- gadget )
     #! Given an association list mapping labels to quotations.
     [ f line-border swap set-delegate ] keep
     0 1 <pile> [ swap add-gadget ] 2keep
-    rot assoc>menu dup menu-actions ;
+    rot assoc>menu dup menu-actions
+    dup menu-theme ;

library/ui/paint.factor

@@ -64,6 +64,7 @@ GENERIC: draw-boundary ( gadget boundary -- )
 M: f draw-interior 2drop ;
 M: f draw-boundary 2drop ;
 
+! Solid fill/border
 TUPLE: solid ;
 
 : rect>screen ( shape -- x1 y1 x2 y2 )
@@ -78,6 +79,19 @@ M: solid draw-boundary
     drop >r surface get r> [ rect>screen ] keep
     fg rgb rectangleColor ;
 
+! Rollover only
+TUPLE: rollover-only ;
+
+C: rollover-only << solid f >> over set-delegate ;
+
+M: rollover-only draw-interior ( gadget interior -- )
+    over rollover paint-prop
+    [ delegate draw-interior ] [ 2drop ] ifte ;
+
+M: rollover-only draw-boundary ( gadget boundary -- )
+    over rollover paint-prop
+    [ delegate draw-boundary ] [ 2drop ] ifte ;
+
 ! Gradient pen
 TUPLE: gradient vector from to ;
 

library/ui/panes.factor

@@ -32,16 +32,29 @@ TUPLE: pane output active current input continuation ;
     dup pane-continuation f rot set-pane-continuation ;
 
 : pane-eval ( string pane -- )
-    2dup stream-print pop-continuation in-thread drop ;
+    pop-continuation in-thread drop ;
+
+SYMBOL: structured-input
+
+: elements. ( quot -- )
+    [
+        1 nesting-limit set
+        5 length-limit set
+        <block pprint-elements block> t newline
+    ] with-pprint ;
 
 : pane-call ( quot pane -- )
-    [ "(Structured input) " write dup . call ] with-stream* ;
+    2dup [ elements. ] with-stream*
+    >r structured-input global set-hash
+    "structured-input global hash call" r> pane-eval ;
+
+: editor-commit ( editor -- line )
+    #! Add current line to the history, and clear the editor.
+    [ commit-history line-text get line-clear ] with-editor ;
 
 : pane-return ( pane -- )
-    [
-        pane-input
-        [ commit-history line-text get line-clear ] with-editor
-    ] keep pane-eval ;
+    [ pane-input editor-commit ] keep
+    2dup stream-print pane-eval ;
  
 : pane-actions ( line -- )
     [

library/ui/presentations.factor

@@ -1,8 +1,9 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets
-USING: generic hashtables inspector io jedit kernel lists memory
-namespaces parser prettyprint sequences styles vectors words ;
+USING: compiler generic hashtables inference inspector io jedit
+kernel lists memory namespaces parser prettyprint sequences
+styles vectors words ;
 
 SYMBOL: commands
 
@@ -15,8 +16,10 @@ SYMBOL: commands
     commands get [ first call ] subset-with ;
 
 : command-quot ( presented quot -- quot )
-    [ swap literalize , % ] [ ] make
-    [ pane get pane-call drop ] cons ;
+    [
+        [ swap literalize , % ] [ ] make ,
+        [ pane get pane-call ] %
+    ] [ ] make ;
 
 : command-menu ( presented -- menu )
     dup applicable
@@ -24,6 +27,7 @@ SYMBOL: commands
     <menu> ;
 
 : init-commands ( gadget -- )
+    dup roll-button-theme
     dup presented paint-prop dup [
         [
             \ drop ,
@@ -49,10 +53,21 @@ SYMBOL: commands
 
 [ drop t ] "Prettyprint" [ . ] define-command
 [ drop t ] "Inspect" [ inspect ] define-command
-[ drop t ] "References" [ references inspect ] define-command
+[ drop t ] "Inspect variable" [ get inspect ] define-command
+[ drop t ] "Inspect references" [ references inspect ] define-command
+[ drop t ] "Push on data stack" [ ] define-command
 
-[ word? ] "See" [ see ] define-command
-[ word? ] "Usage" [ usage . ] define-command
-[ word? ] "jEdit" [ jedit ] define-command
+[ word? ] "See word" [ see ] define-command
+[ word? ] "Word usage" [ usage . ] define-command
+[ word? ] "Open in jEdit" [ jedit ] define-command
+[ word? ] "Reload original source" [ reload ] define-command
+[ compound? ] "Annotate with watchpoint" [ watch ] define-command
+[ compound? ] "Annotate with breakpoint" [ break ] define-command
+[ compound? ] "Annotate with profiling" [ profile ] define-command
+[ word? ] "Compile" [ recompile ] define-command
+[ word? ] "Decompile" [ decompile ] define-command
+[ word? ] "Show stack effect" [ unit infer . ] define-command
+[ word? ] "Show dataflow IR" [ word-def t dataflow. ] define-command
+[ word? ] "Show linear IR" [ precompile ] define-command
 
-[ [ gadget? ] is? ] "Display" [ gadget. ] define-command
+[ [ gadget? ] is? ] "Display gadget" [ gadget. ] define-command

library/ui/ui.factor

@@ -1,24 +1,37 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: help
-DEFER: tutorial
+DEFER: <tutorial-button>
 
 IN: gadgets
 USING: generic help io kernel listener math namespaces
-prettyprint sdl sequences styles threads words ;
+prettyprint sdl sequences styles threads words shells ;
 
 SYMBOL: stack-display
 
 : ui.s ( -- )
     stack-display get dup pane-clear [ .s ] with-stream* ;
 
+: listener-thread
+    pane get [
+        [ ui.s ] listener-hook set <tutorial-button> gadget. tty
+    ] with-stream* ;
+
+: listener-application
+    <pane> dup pane set <scroller>
+    <pane> dup stack-display set <scroller>
+    5/6 <x-splitter> add-layer
+    [ clear listener-thread ] in-thread
+    pane get request-focus ;
+
 : init-world
     global [
         <world> world set
+        { 700 800 0 } world get set-gadget-dim
         
         {{
             [[ background { 255 255 255 } ]]
-            [[ rollover-bg { 216 216 255 } ]]
+            [[ rollover-bg { 236 230 232 } ]]
             [[ bevel-1 { 160 160 160 } ]]
             [[ bevel-2 { 216 216 216 } ]]
             [[ foreground { 0 0 0 } ]]
@@ -28,25 +41,10 @@ SYMBOL: stack-display
             [[ font-style plain ]]
         }} world get set-gadget-paint
 
-        { 700 800 0 } world get set-gadget-dim
-        
         <plain-gadget> add-layer
 
-        <pane> dup pane set <scroller>
-        <pane> dup stack-display set <scroller>
-        5/6 <x-splitter> add-layer
-        
-        [
-            pane get [
-                [ ui.s ] listener-hook set
-                clear print-banner
-                "Tutorial" [ drop [ tutorial ] pane get pane-call ] <button> gadget.
-                listener
-            ] with-stream
-        ] in-thread
-    ] bind
-        
-        pane get request-focus ;
+        listener-application
+    ] bind ;
 
 SYMBOL: first-time
 
@@ -54,8 +52,12 @@ global [ first-time on ] bind
 
 : ?init-world
     first-time get [ init-world first-time off ] when ;
+
 IN: shells
 
+: ui-title
+    [ "Factor " % version % " - " % "image" get % ] "" make ;
+
 : ui ( -- )
     #! Start the Factor graphics subsystem with the given screen
     #! dimensions.
@@ -63,7 +65,7 @@ IN: shells
     ?init-world
     world get rect-dim 2unseq 0 SDL_RESIZABLE [
         [
-            "Factor " version append dup SDL_WM_SetCaption
+            ui-title dup SDL_WM_SetCaption
             start-world
             run-world
         ] with-screen

library/ui/world.factor

@@ -13,7 +13,9 @@ TUPLE: world running? hand glass invalid ;
 
 DEFER: <hand>
 DEFER: update-hand
-DEFER: do-timers
+
+: add-layer ( gadget -- )
+    world get add-gadget ;
 
 C: world ( -- world )
     <stack> over set-delegate
@@ -30,9 +32,6 @@ C: world ( -- world )
     world get world-invalid
     [ pop-invalid [ layout ] each layout-world ] when ;
 
-: add-layer ( gadget -- )
-    world get add-gadget ;
-
 : hide-glass ( -- )
     world get world-glass unparent f
     world get set-world-glass ;