From f044b47e96c050dc8e62a7c1ab835df76720afbb Mon Sep 17 00:00:00 2001 From: slava Date: Sat, 7 Oct 2006 06:17:32 +0000 Subject: [PATCH] Menus --- TODO.FACTOR.txt | 4 +- library/ui/commands.factor | 18 ++---- library/ui/gadgets/lists.factor | 5 +- library/ui/gadgets/menus.factor | 36 +++++++++++ library/ui/gadgets/presentations.factor | 79 +++++++------------------ library/ui/gestures.factor | 11 ++-- library/ui/load.factor | 1 + library/ui/tools/operations.factor | 34 +++-------- library/ui/tools/search.factor | 8 +-- library/ui/ui.factor | 10 +++- library/ui/world.factor | 17 +++++- 11 files changed, 110 insertions(+), 113 deletions(-) create mode 100644 library/ui/gadgets/menus.factor diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 1e2299056e..acb61aaba2 100644 --- 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 c9910ae192..8c7d485fd6 100644 --- 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 ; @@ -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 f52a7d4b05..9e8ae8149c 100644 --- 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* ] 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 index 0000000000..d8860abe0c --- /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 [ ] keep [ show-glass ] keep + t menu-mode? set-global ; diff --git a/library/ui/gadgets/presentations.factor b/library/ui/gadgets/presentations.factor index 617ee10d79..9c173db248 100644 --- 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 ) : ( target command -- button ) dup command-name f -rot ; -: 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 ; +: ( target commands -- gadget ) + [ hand-clicked get find-world hide-glass ] modify-operations + [ ] map-with + make-pile 1 over set-pack-fill ; -: invoke-presentation ( gadget modifiers button# -- ) - - presentation-command* dup [ invoke-command ] [ 2drop ] if ; +: operations-menu ( presentation -- gadget ) + dup presentation-object + dup object-operations + 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 -: ( model -- ) - [ - [ - presentation-object summary - ] [ - "Mouse over a presentation for help." - ] if* - ] dup reverse-video-theme ; - -: ( model gesture -- gadget ) - [ - over [ - tuck presentation-command* nip dup [ - >r gesture>string ": " r> command-name append3 - ] [ - 2drop "" - ] if - ] [ - 2drop "" - ] if - ] curry ; - -: ( model -- help ) - { f { S+ } } [ - 3 [ - 1+ >r 2dup r> - ] map nip - ] map nip - { 10 0 } over set-grid-gap ; - : ( model -- gadget ) - [ - dup , - , - ] { } make make-pile 1 over set-pack-fill ; + [ [ presentation-object summary ] [ "" ] if* ] + dup reverse-video-theme ; : ( gadget quot -- button ) [ call-listener ] curry ; diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor index a0c8651d92..2f8f9aa414 100644 --- 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 ; +: 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 7e86b03406..1bc8573397 100644 --- 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 b007736ef0..f4e51ebaad 100644 --- 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 66a2d6dbea..e3e8fd03ef 100644 --- 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. ] - ; + "Word search" ; : ( string action -- gadget ) [ search-help ] [ first ($link) ] - ; + "Help search" ; : 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 [ [ ] string-completion. ] - ; + "Source file search" ; : ( string action -- gadget ) vocabs [ string-completions ] curry [ [ ] string-completion. ] - ; + "Vocabulary search" ; diff --git a/library/ui/ui.factor b/library/ui/ui.factor index bc81e37a00..77bcb3ea24 100644 --- 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. ; -: ( gadget title -- gadget ) +TUPLE: labelled-gadget content ; + +C: labelled-gadget ( gadget title -- gadget ) { { [