Menus

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 1e2299056e62c761b23450af5955157b810a41f4..acb61aaba2771a8419ea90b440941705f2e80e8d 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -2,16 +2,16 @@
 - fix alien-callback/SEH bug on win32
 - list mouse gestures
 - maybe simplify list into displaying list a sequence of strings
-- the mouse button overload sucks, use popup menus instead
 - nested presentation mouse over is not right
 - ui quick start doc
 - x11: scroll up/down wiggles caret
 - slider needs to be modelized
 - some way of intercepting all gestures
 - better help result ranking
-- minibuffer should show a title
 - clean up listener's minibuffer-related code
 - help search looks funny
+- menus should not require mouse to be held
+- tab completion: add a USE: if necessary
 
 + ui:
 

diff --git a/library/ui/commands.factor b/library/ui/commands.factor
index c9910ae1924bb15ef0d7084a646e2c9023192c2c..8c7d485fd63fc4bf75881e660bee33190d48da51 100644 (file)
--- a/library/ui/commands.factor
+++ b/library/ui/commands.factor
@@ -54,19 +54,13 @@ M: object gesture>string drop f ;
     swap pick commands set-hash
     dup commands>gestures "gestures" set-word-prop ;
 
-: categorize-commands ( seq -- hash )
-    dup
-    [ hash-keys ] map concat prune
-    [ dup pick [ hash ] map-with concat ] map>hash
-    nip ;
-
 SYMBOL: +name+
 SYMBOL: +quot+
 SYMBOL: +listener+
 SYMBOL: +keyboard+
-SYMBOL: +mouse+
+SYMBOL: +default+
 
-TUPLE: operation predicate mouse listener? ;
+TUPLE: operation predicate listener? default? ;
 
 : (command) ( -- command )
     +name+ get +keyboard+ get +quot+ get <command> ;
@@ -74,7 +68,7 @@ TUPLE: operation predicate mouse listener? ;
 C: operation ( predicate hash -- operation )
     swap [
         (command) over set-delegate
-        +mouse+ get over set-operation-mouse
+        +default+ get over set-operation-default?
         +listener+ get over set-operation-listener?
     ] bind
     [ set-operation-predicate ] keep ;
@@ -88,10 +82,8 @@ SYMBOL: operations
     "predicate" word-prop
     operations get [ operation-predicate = ] subset-with ;
 
-: mouse-operation ( obj gesture -- command )
-    swap object-operations
-    [ operation-mouse = ] subset-with
-    dup empty? [ drop f ] [ peek ] if ;
+: default-operation ( obj -- command )
+    object-operations [ operation-default? ] find-last nip ;
 
 : modify-operation ( quot operation -- operation )
     clone

diff --git a/library/ui/gadgets/lists.factor b/library/ui/gadgets/lists.factor
index f52a7d4b05a0e2344d0651195ffaf70b3b468249..9e8ae8149cb1af79d8677d8bcaebc8df660b5395 100644 (file)
--- a/library/ui/gadgets/lists.factor
+++ b/library/ui/gadgets/lists.factor
@@ -41,7 +41,10 @@ M: list focusable-child* drop t ;
     dup list-index swap control-value ?nth ;
 
 : scroll>selected ( list -- )
-    dup selected-rect swap scroll>rect ;
+    #! We change the rectangle's width to zero to avoid
+    #! scrolling right.
+    [ selected-rect rect-bounds { 0 1 } v* <rect> ] keep
+    scroll>rect ;
 
 : list-empty? ( list -- ? ) control-value empty? ;
 

diff --git a/library/ui/gadgets/menus.factor b/library/ui/gadgets/menus.factor
new file mode 100644 (file)
index 0000000..d8860ab
--- /dev/null
+++ b/library/ui/gadgets/menus.factor
@@ -0,0 +1,36 @@
+! Copyright (C) 2005, 2006 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: gadgets
+USING: arrays errors freetype gadgets-frames generic hashtables
+kernel math models namespaces opengl sequences ;
+
+: menu-loc ( world menu -- loc )
+    >r rect-dim r> pref-dim [v-] hand-loc get-global vmin ;
+
+TUPLE: menu-glass ;
+
+C: menu-glass ( menu world -- glass )
+    dup delegate>gadget
+    >r over menu-loc over set-rect-loc r>
+    [ add-gadget ] keep ;
+
+M: menu-glass layout* gadget-child prefer ;
+
+: retarget-drag ( gadget -- )
+    hand-gadget get-global hand-clicked get-global eq? [
+        drop
+    ] [
+        hand-loc get-global swap find-world move-hand
+    ] if ;
+
+: hide-menu ( -- )
+    find-world hide-glass f menu-mode? set-global ;
+
+\ menu-glass H{
+    { T{ button-up } [ hide-menu ] }
+    { T{ drag } [ retarget-drag ] }
+} set-gestures
+
+: show-menu ( gadget owner -- )
+    find-world [ <menu-glass> ] keep [ show-glass ] keep
+    t menu-mode? set-global ;

diff --git a/library/ui/gadgets/presentations.factor b/library/ui/gadgets/presentations.factor
index 617ee10d79ed1e74f2fe267389510833964b0153..9c173db248b76546b156634a7463ad5b7674b9ba 100644 (file)
--- a/library/ui/gadgets/presentations.factor
+++ b/library/ui/gadgets/presentations.factor
@@ -6,8 +6,8 @@ DEFER: call-listener
 IN: gadgets-presentations
 USING: arrays definitions gadgets gadgets-borders
 gadgets-buttons gadgets-grids gadgets-labels gadgets-outliner
-gadgets-panes gadgets-paragraphs gadgets-theme generic
-hashtables tools io kernel prettyprint sequences strings
+gadgets-panes gadgets-paragraphs gadgets-theme
+generic hashtables tools io kernel prettyprint sequences strings
 styles words help math models namespaces ;
 
 ! Clickable objects
@@ -24,21 +24,20 @@ C: presentation ( button object command -- button )
 : <command-presentation> ( target command -- button )
     dup command-name f <bevel-button> -rot <presentation> ;
 
-: presentation-command* ( presentation gesture -- obj cmd )
-    over presentation-command [
-        dup T{ button-up f f 1 } = [
-            drop
-            dup presentation-object swap presentation-command
-        ] [
-            >r presentation-command dup r> mouse-operation
-        ] if
-    ] [
-        >r presentation-object dup r> mouse-operation
-    ] if ;
+: <commands-menu> ( target commands -- gadget )
+    [ hand-clicked get find-world hide-glass ] modify-operations
+    [ <command-presentation> ] map-with
+    make-pile 1 over set-pack-fill ;
 
-: invoke-presentation ( gadget modifiers button# -- )
-    <button-up>
-    presentation-command* dup [ invoke-command ] [ 2drop ] if ;
+: operations-menu ( presentation -- gadget )
+    dup presentation-object
+    dup object-operations <commands-menu>
+    swap show-menu ;
+
+: invoke-presentation ( presentation -- )
+    dup presentation-object swap presentation-command
+    [ dup default-operation ] unless*
+    invoke-command ;
 
 : show-mouse-help ( presentation -- )
     dup find-world [ world-status set-model* ] [ drop ] if* ;
@@ -50,52 +49,16 @@ M: presentation ungraft* ( presentation -- )
     dup hide-mouse-help delegate ungraft* ;
 
 presentation H{
-    { T{ button-up f f 1 } [ [ f 1 invoke-presentation ] if-clicked ] }
-    { T{ button-up f f 2 } [ [ f 2 invoke-presentation ] if-clicked ] }
-    { T{ button-up f f 3 } [ [ f 3 invoke-presentation ] if-clicked ] }
-    { T{ button-up f { S+ } 1 } [ [ { S+ } 1 invoke-presentation ] if-clicked ] }
-    { T{ button-up f { S+ } 2 } [ [ { S+ } 2 invoke-presentation ] if-clicked ] }
-    { T{ button-up f { S+ } 3 } [ [ { S+ } 3 invoke-presentation ] if-clicked ] }
-    { T{ mouse-leave } [ dup hide-mouse-help button-update ] }
-    { T{ mouse-enter } [ dup show-mouse-help button-update ] }
+    { T{ button-up } [ [ invoke-presentation ] if-clicked ] }
+    { T{ button-down f f 3 } [ [ operations-menu ] if-clicked ] }
+    { T{ mouse-leave } [ global [ dup short. flush ] bind  dup hide-mouse-help button-update ] }
+    { T{ mouse-enter } [ global [ dup short. flush ] bind  dup show-mouse-help button-update ] }
 } set-gestures
 
 ! Presentation help bar
-: <presentation-summary> ( model -- )
-    [
-        [
-            presentation-object summary
-        ] [
-            "Mouse over a presentation for help."
-        ] if*
-    ] <filter> <label-control> dup reverse-video-theme ;
-
-: <gesture-help> ( model gesture -- gadget )
-    [
-        over [
-            tuck presentation-command* nip dup [
-                >r gesture>string ": " r> command-name append3
-            ] [
-                2drop ""
-            ] if
-        ] [
-            2drop ""
-        ] if
-    ] curry <filter> <label-control> ;
-
-: <presentation-mouse-help> ( model -- help )
-    { f { S+ } } [
-        3 [
-            1+ >r 2dup r> <button-up> <gesture-help>
-        ] map nip
-    ] map nip <grid>
-    { 10 0 } over set-grid-gap ;
-
 : <presentation-help> ( model -- gadget )
-    [
-        dup <presentation-summary> ,
-        <presentation-mouse-help> ,
-    ] { } make make-pile 1 over set-pack-fill ;
+    [ [ presentation-object summary ] [ "" ] if* ] <filter>
+    <label-control> dup reverse-video-theme ;
 
 : <listener-button> ( gadget quot -- button )
     [ call-listener ] curry <roll-button> ;

diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor
index a0c8651d920d8f28a221970a5f2c6f9886da92dc..2f8f9aa4146f5878268b4a99fd7b7f13a8f24f1c 100644 (file)
--- a/library/ui/gestures.factor
+++ b/library/ui/gestures.factor
@@ -146,16 +146,19 @@ V{ } clone hand-buttons set-global
     #! the current gadget, with all parents in between.
     hand-gadget get-global parents <reversed> ;
 
+: update-clicked ( -- )
+    hand-gadget get-global hand-clicked set-global
+    hand-loc get-global hand-click-loc set-global ;
+
+SYMBOL: menu-mode?
+
 : move-hand ( loc world -- )
     dup hand-world set-global
     under-hand >r over hand-loc set-global
     pick-up hand-gadget set-global
+    menu-mode? get-global [ update-clicked ] when
     under-hand r> hand-gestures ;
 
-: update-clicked ( -- )
-    hand-gadget get-global hand-clicked set-global
-    hand-loc get-global hand-click-loc set-global ;
-
 : send-button-down ( gesture loc world -- )
     move-hand
     update-clicked

diff --git a/library/ui/load.factor b/library/ui/load.factor
index 7e86b03406e6745ab7d359806b3eaa107446a7c3..1bc8573397b18badd30810b03af0705a3ef54a36 100644 (file)
--- a/library/ui/load.factor
+++ b/library/ui/load.factor
@@ -29,6 +29,7 @@ PROVIDE: library/ui {
     "gadgets/books.factor"
     "gadgets/outliner.factor"
     "gadgets/lists.factor"
+    "gadgets/menus.factor"
     "text/document.factor"
     "text/elements.factor"
     "text/editor.factor"

diff --git a/library/ui/tools/operations.factor b/library/ui/tools/operations.factor
index b007736ef0a73f03dd627f1a79e8df69710f7483..f4e51ebaad0253d241d2fc811063c0bee506df03 100644 (file)
--- a/library/ui/tools/operations.factor
+++ b/library/ui/tools/operations.factor
@@ -25,71 +25,58 @@ M: operation invoke-command ( target operation -- )
 
 ! Objects
 [ drop t ] H{
-    { +mouse+ T{ button-up f f 1 } }
+    { +default+ t }
     { +name+ "Inspect" }
     { +quot+ [ inspect ] }
     { +listener+ t }
 } define-operation
 
 [ drop t ] H{
-    { +mouse+ T{ button-up f { S+ } 1 } }
     { +name+ "Push" }
     { +quot+ [ ] }
     { +listener+ t }
 } define-operation
 
-! Commands
-[ [ command? ] is? ] H{
-    { +mouse+ T{ button-up f { S+ } 3 } }
-    { +name+ "Inspect" }
-    { +quot+ [ inspect ] }
-    { +listener+ t }
-} define-operation
-
 ! Input
 [ input? ] H{
-    { +mouse+ T{ button-up f f 1 } }
+    { +default+ t }
     { +name+ "Input" }
     { +quot+ [ listener-gadget call-tool ] }
 } define-operation
 
 ! Pathnames
 [ pathname? ] H{
-    { +mouse+ T{ button-up f f 1 } }
+    { +default+ t }
     { +name+ "Edit" }
     { +quot+ [ pathname-string edit-file ] }
 } define-operation
 
 [ pathname? ] H{
-    { +mouse+ T{ button-up f f 2 } }
     { +name+ "Run file" }
     { +quot+ [ pathname-string [ run-file ] curry call-listener ] }
 } define-operation
 
 ! Words
 [ word? ] H{
-    { +mouse+ T{ button-up f f 1 } }
+    { +default+ t }
     { +name+ "Browse" }
     { +keyboard+ T{ key-down f { A+ } "b" } }
     { +quot+ [ browser call-tool ] }
 } define-operation
 
 [ word? ] H{
-    { +mouse+ T{ button-up f f 2 } }
     { +name+ "Edit" }
     { +keyboard+ T{ key-down f { A+ } "e" } }
     { +quot+ [ edit ] }
 } define-operation
 
 [ word? ] H{
-    { +mouse+ T{ button-up f f 3 } }
     { +name+ "Documentation" }
     { +keyboard+ T{ key-down f { A+ } "h" } }
     { +quot+ [ help-gadget call-tool ] }
 } define-operation
 
 [ word? ] H{
-    { +mouse+ T{ button-up f { S+ } 3 } }
     { +name+ "Usage" }
     { +keyboard+ T{ key-down f { A+ } "u" } }
     { +quot+ [ usage. ] }
@@ -97,7 +84,6 @@ M: operation invoke-command ( target operation -- )
 } define-operation
 
 [ word? ] H{
-    { +mouse+ T{ button-up f { S+ } 2 } }
     { +name+ "Reload" }
     { +keyboard+ T{ key-down f { A+ } "r" } }
     { +quot+ [ reload ] }
@@ -118,44 +104,39 @@ M: operation invoke-command ( target operation -- )
 
 ! Vocabularies
 [ vocab-link? ] H{
-    { +mouse+ T{ button-up f f 1 } }
+    { +default+ t }
     { +name+ "Browse" }
     { +quot+ [ browser call-tool ] }
 } define-operation
 
 [ vocab-link? ] H{
-    { +mouse+ T{ button-up f f 2 } }
     { +name+ "Enter in" }
     { +quot+ [ vocab-link-name [ set-in ] curry call-listener ] }
 } define-operation
 
 [ vocab-link? ] H{
-    { +mouse+ T{ button-up f f 3 } }
     { +name+ "Use" }
     { +quot+ [ vocab-link-name [ use+ ] curry call-listener ] }
 } define-operation
 
 ! Link
 [ link? ] H{
-    { +mouse+ T{ button-up f f 1 } }
+    { +default+ t }
     { +name+ "Follow" }
     { +quot+ [ help-gadget call-tool ] }
 } define-operation
 
 [ link? ] H{
-    { +mouse+ T{ button-up f f 2 } }
     { +name+ "Edit" }
     { +quot+ [ edit ] }
 } define-operation
 
 [ link? ] H{
-    { +mouse+ T{ button-up f { S+ } 2 } }
     { +name+ "Reload" }
     { +quot+ [ reload ] }
 } define-operation
 
 [ word-link? ] H{
-    { +mouse+ T{ button-up f f 3 } }
     { +name+ "Definition" }
     { +quot+ [ link-name browser call-tool ] }
 } define-operation
@@ -192,13 +173,12 @@ M: operation invoke-command ( target operation -- )
 ! Dataflow nodes
 
 [ [ node? ] is? ] H{
-    { +mouse+ T{ button-up f f 1 } }
+    { +default+ t }
     { +name+ "Show dataflow" }
     { +quot+ [ dataflow-gadget call-tool ] }
 } define-operation
 
 [ [ node? ] is? ] H{
-    { +mouse+ T{ button-up f { S+ } 3 } }
     { +name+ "Inspect" }
     { +quot+ [ inspect ] }
     { +listener+ t }

diff --git a/library/ui/tools/search.factor b/library/ui/tools/search.factor
index 66a2d6dbeac8cd8167e9350edd8d378208e42ba5..e3e8fd03ef16a76b2916f9af590397ec4fbd3e4c 100644 (file)
--- a/library/ui/tools/search.factor
+++ b/library/ui/tools/search.factor
@@ -63,12 +63,12 @@ M: live-search focusable-child* live-search-field ;
     all-words
     [ word-completions ] curry
     [ word-completion. ]
-    <live-search> ;
+    <live-search> "Word search" <labelled-gadget> ;
 
 : <help-search> ( string action -- gadget )
     [ search-help ]
     [ first ($link) ]
-    <live-search> ;
+    <live-search> "Help search" <labelled-gadget> ;
 
 : string-completion. ( pair quot -- )
     >r first2 over completion>string swap r> call write-object ;
@@ -78,10 +78,10 @@ M: live-search focusable-child* live-search-field ;
     source-files get hash-keys natural-sort
     [ string-completions ] curry
     [ [ <pathname> ] string-completion. ]
-    <live-search> ;
+    <live-search> "Source file search" <labelled-gadget> ;
 
 : <vocabs-search> ( string action -- gadget )
     vocabs
     [ string-completions ] curry
     [ [ <vocab-link> ] string-completion. ]
-    <live-search> ;
+    <live-search> "Vocabulary search" <labelled-gadget> ;

diff --git a/library/ui/ui.factor b/library/ui/ui.factor
index bc81e37a0037d5afa2f72729ccaadf22afd0b24b..77bcb3ea241fb5b03c21ff46e84ca2ed35afcccc 100644 (file)
--- a/library/ui/ui.factor
+++ b/library/ui/ui.factor
@@ -142,11 +142,15 @@ C: titled-gadget ( gadget title -- )
 : $commands ( elt -- )
     dup array? [ first ] when commands commands. ;
 
-: <labelled-gadget> ( gadget title -- gadget )
+TUPLE: labelled-gadget content ;
+
+C: labelled-gadget ( gadget title -- gadget )
     {
         { [ <label> dup reverse-video-theme ] f f @top }
-        { [ ] f f @center }
-    } make-frame ;
+        { f set-labelled-gadget-content f @center }
+    } make-frame* ;
+
+M: labelled-gadget focusable-child* labelled-gadget-content ;
 
 : <labelled-pane> ( model quot title -- gadget )
     >r <pane-control> <scroller> r> <labelled-gadget> ;

diff --git a/library/ui/world.factor b/library/ui/world.factor
index fbddd3a5deb2fba7c4c8925f1bc09e47932c3ec0..e1af1a43b35bae9cfe9120a2395a8fc7bc76712c 100644 (file)
--- a/library/ui/world.factor
+++ b/library/ui/world.factor
@@ -16,7 +16,7 @@ kernel math models namespaces opengl sequences ;
 !   UI code assumes that everything starts at { 0 0 }.
 TUPLE: world
 active?
-gadget
+gadget glass
 title status
 focus focused?
 fonts handle
@@ -66,3 +66,18 @@ M: world model-changed
     >r world get font-sprites first2 r> (draw-string) ;
 
 M: world gadget-title world-gadget gadget-title ;
+
+M: world layout*
+    dup delegate layout*
+    dup world-glass [
+        >r dup rect-dim r> set-layout-dim
+    ] when* drop ;
+
+: hide-glass ( world -- )
+    dup world-glass [ unparent ] when*
+    f swap set-world-glass ;
+
+: show-glass ( gadget world -- )
+    [ hide-glass ] keep
+    [ add-gadget ] 2keep
+    set-world-glass ;