From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 21 Feb 2009 22:42:57 +0000 (-0600)
Subject: Implement gesture>string for actions
X-Git-Tag: 0.94~2191^2~142
X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=dcbb5bc692c510fe996b402ccb8c2f435d3d9fa4

Implement gesture>string for actions
---

diff --git a/basis/ui/commands/commands.factor b/basis/ui/commands/commands.factor
index 5bc4f2eeb0..d6c7c7905b 100644
--- a/basis/ui/commands/commands.factor
+++ b/basis/ui/commands/commands.factor
@@ -71,7 +71,7 @@ M: word command-description ( word -- str )
     [ props>> ] [ default-flags swap assoc-union ] bi* update ;
 
 : command-quot ( target command -- quot )
-    dup 1quotation swap +nullary+ word-prop
+    [ 1quotation ] [ +nullary+ word-prop ] bi
     [ nip ] [ curry ] if ;
 
 M: word invoke-command ( target command -- )
@@ -85,4 +85,4 @@ M: f invoke-command ( target command -- ) 2drop ;
     [
         command-name %
         gesture>string [ " (" % % ")" % ] when*
-    ] "" make ;
+    ] "" make ;
\ No newline at end of file
diff --git a/basis/ui/gadgets/editors/editors-docs.factor b/basis/ui/gadgets/editors/editors-docs.factor
index 04f161a8b6..244e36d640 100644
--- a/basis/ui/gadgets/editors/editors-docs.factor
+++ b/basis/ui/gadgets/editors/editors-docs.factor
@@ -90,6 +90,7 @@ ARTICLE: "gadgets-editors-commands" "Editor gadget commands"
 { $command-map editor "editing" }
 { $command-map editor "caret-motion" }
 { $command-map editor "selection" }
+{ $command-map editor "clipboard" }
 { $command-map multiline-editor "multiline" } ;
 
 ARTICLE: "ui.gadgets.editors" "Editor gadgets"
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index 1d129b39b8..560cea4d5e 100755
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -369,11 +369,11 @@ editor "editing" f {
 : com-cut ( editor -- ) clipboard get editor-cut ;
 
 editor "clipboard" f {
-    { paste-action com-paste }
-    { copy-action com-copy }
     { cut-action com-cut }
-    { T{ button-up f f 2 } paste-selection }
+    { copy-action com-copy }
+    { paste-action com-paste }
     { T{ button-up } com-copy-selection }
+    { T{ button-up f f 2 } paste-selection }
 } define-command-map
 
 : previous-character ( editor -- )
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
index 0a875cf7c8..ccfa83334b 100644
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@@ -4,7 +4,7 @@ USING: accessors arrays assocs continuations kernel math models
 call namespaces opengl sequences io combinators
 combinators.short-circuit fry math.vectors math.rectangles cache
 ui.gadgets ui.gestures ui.render ui.text ui.text.private
-ui.backend ui.gadgets.tracks ;
+ui.backend ui.gadgets.tracks ui.commands ;
 IN: ui.gadgets.worlds
 
 TUPLE: world < track
@@ -110,20 +110,20 @@ ui-error-hook [ [ rethrow ] ] initialize
         ] with-variable
     ] [ drop ] if ;
 
-world H{
-    { T{ key-down f { C+ } "z" } [ undo-action send-action ] }
-    { T{ key-down f { C+ } "Z" } [ redo-action send-action ] }
-    { T{ key-down f { C+ } "x" } [ cut-action send-action ] }
-    { T{ key-down f { C+ } "c" } [ copy-action send-action ] }
-    { T{ key-down f { C+ } "v" } [ paste-action send-action ] }
-    { T{ key-down f { C+ } "a" } [ select-all-action send-action ] }
+world
+action-gestures [
+    [ [ { C+ } ] dip f <key-down> ]
+    [ '[ _ send-action ] ]
+    bi*
+] H{ } assoc-map-as
+H{
     { T{ button-down f { C+ } 1 } [ drop T{ button-down f f 3 } button-gesture ] }
     { T{ button-down f { A+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
     { T{ button-down f { M+ } 1 } [ drop T{ button-down f f 2 } button-gesture ] }
     { T{ button-up f { C+ } 1 } [ drop T{ button-up f f 3 } button-gesture ] }
     { T{ button-up f { A+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
     { T{ button-up f { M+ } 1 } [ drop T{ button-up f f 2 } button-gesture ] }
-} set-gestures
+} assoc-union set-gestures
 
 PREDICATE: specific-button-up < button-up #>> ;
 PREDICATE: specific-button-down < button-down #>> ;
diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor
index 637e890715..3581edca47 100644
--- a/basis/ui/gestures/gestures.factor
+++ b/basis/ui/gestures/gestures.factor
@@ -84,6 +84,23 @@ delete-action select-all-action
 left-action right-action up-action down-action
 zoom-in-action zoom-out-action ;
 
+UNION: action
+undo-action redo-action
+cut-action copy-action paste-action
+delete-action select-all-action
+left-action right-action up-action down-action
+zoom-in-action zoom-out-action ;
+
+CONSTANT: action-gestures
+    {
+        { "z" undo-action }
+        { "Z" redo-action }
+        { "x" cut-action }
+        { "c" copy-action }
+        { "v" paste-action }
+        { "a" select-all-action }
+    }
+
 ! Modifiers
 SYMBOLS: C+ A+ M+ S+ ;
 
@@ -323,4 +340,14 @@ M: zoom-in-action gesture>string drop "Zoom in" ;
 
 M: zoom-out-action gesture>string drop "Zoom out (pinch)" ;
 
+HOOK: action-modifier os ( -- mod )
+
+M: object action-modifier C+ ;
+M: macosx action-modifier A+ ;
+
+M: action gesture>string
+    action-gestures value-at
+    action-modifier 1array
+    swap f <key-down> gesture>string ;
+
 M: object gesture>string drop f ;