From 30a4275c135517141578e1197ea5c072ed49600a Mon Sep 17 00:00:00 2001
From: slava <slava@factorcode.org>
Date: Mon, 27 Nov 2006 04:26:08 +0000
Subject: [PATCH] Gesture protocol allows a gadget to intercept arbitrary
 gestures

---
 TODO.FACTOR.txt                    |  1 -
 library/ui/cocoa/view-utils.factor |  2 +-
 library/ui/gestures.factor         | 33 +++++++++++++++---------------
 library/ui/windows/ui.factor       |  4 ++--
 library/ui/x11/ui.factor           |  4 ++--
 5 files changed, 21 insertions(+), 23 deletions(-)

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 431df4bc55..b49e5877e6 100644
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -7,7 +7,6 @@
 - http://paste.lisp.org/display/30426
 - robustify stepper -- see if step back past a throw works
 - listener: if partial parse, RETURN should insert newline
-- some way of intercepting all gestures
 - compiled call traces:
   - should be independent of whenever the runtime was built with
     -fomit-frame-pointer or not
diff --git a/library/ui/cocoa/view-utils.factor b/library/ui/cocoa/view-utils.factor
index 01ff1dca27..d6bb776719 100644
--- a/library/ui/cocoa/view-utils.factor
+++ b/library/ui/cocoa/view-utils.factor
@@ -79,7 +79,7 @@ opengl sequences ;
 
 : send-key-event ( view event quot -- ? )
     >r key-event>gesture r> call swap window-focus
-    handle-gesture ; inline
+    send-gesture ; inline
 
 : send-user-input ( view event -- )
     -> characters CF>string swap window-focus user-input ;
diff --git a/library/ui/gestures.factor b/library/ui/gestures.factor
index b2637f83a6..bceedca786 100644
--- a/library/ui/gestures.factor
+++ b/library/ui/gestures.factor
@@ -4,20 +4,19 @@ IN: gadgets
 USING: arrays generic hashtables kernel math models namespaces
 queues sequences words ;
 
-: gestures ( gadget -- seq )
-    delegates [ class "gestures" word-prop ] map [ ] subset ;
-
 : set-gestures ( class hash -- ) "gestures" set-word-prop ;
 
-: handle-gesture* ( gesture gadget -- )
-    tuck gestures hash-stack [ call f ] [ drop t ] if* ;
+GENERIC: handle-gesture* ( gadget gesture delegate -- ? )
+
+M: object handle-gesture*
+    class "gestures" word-prop ?hash*
+    [ call f ] [ 2drop t ] if ;
 
 : handle-gesture ( gesture gadget -- ? )
-    #! If a gadget's handle-gesture* generic returns t, the
-    #! event was not consumed and is passed on to the gadget's
-    #! parent. This word returns t if no gadget handled the
-    #! gesture, otherwise returns f.
-    [ dupd handle-gesture* ] each-parent nip ;
+    tuck delegates [ >r 2dup r> handle-gesture* ] all? 2nip ;
+
+: send-gesture ( gesture gadget -- ? )
+    [ dupd handle-gesture ] each-parent nip ;
 
 : user-input ( str gadget -- )
     [ dupd user-input* ] each-parent 2drop ;
@@ -41,7 +40,7 @@ TUPLE: delete-action ;
 TUPLE: select-all-action ;
 
 : handle-action ( gadget constructor -- )
-    execute swap handle-gesture drop ; inline
+    execute swap send-gesture drop ; inline
 
 : generalize-gesture ( gesture -- gesture )
     #! Strip button number from drag/button-up/button-down.
@@ -85,8 +84,8 @@ SYMBOL: double-click-timeout
 300 double-click-timeout set-global
 
 : button-gesture ( gesture -- )
-    hand-clicked get-global 2dup handle-gesture [
-        >r generalize-gesture r> handle-gesture drop
+    hand-clicked get-global 2dup send-gesture [
+        >r generalize-gesture r> send-gesture drop
     ] [
         2drop
     ] if ;
@@ -99,13 +98,13 @@ SYMBOL: double-click-timeout
     #! and if a mouse button is down, fire a drag gesture to the
     #! gadget that was clicked.
     hand-buttons get-global empty? [
-        T{ motion } hand-gadget get-global handle-gesture drop
+        T{ motion } hand-gadget get-global send-gesture drop
     ] [
         drag-gesture
     ] if ;
 
 : each-gesture ( gesture seq -- )
-    [ handle-gesture* drop ] each-with ;
+    [ handle-gesture drop ] each-with ;
 
 : hand-gestures ( new old -- )
     drop-prefix <reversed>
@@ -199,11 +198,11 @@ SYMBOL: double-click-timeout
 : send-wheel ( direction loc world -- )
     move-hand
     scroll-direction set-global
-    T{ mouse-scroll } hand-gadget get-global handle-gesture
+    T{ mouse-scroll } hand-gadget get-global send-gesture
     drop ;
 
 : send-action ( world gesture -- )
-    swap world-focus handle-gesture drop ;
+    swap world-focus send-gesture drop ;
 
 : resend-button-down ( gesture world -- )
     hand-loc get-global swap send-button-down ;
diff --git a/library/ui/windows/ui.factor b/library/ui/windows/ui.factor
index d815179a59..81c079b143 100644
--- a/library/ui/windows/ui.factor
+++ b/library/ui/windows/ui.factor
@@ -128,7 +128,7 @@ SYMBOL: hWnd
     lParam set wParam set uMsg set hWnd set
     wParam get exclude-key-wm-keydown? [
         wParam get keystroke>gesture <key-down>
-        hWnd get window-focus handle-gesture drop 
+        hWnd get window-focus send-gesture drop 
     ] unless ;
 
 : handle-wm-char ( hWnd uMsg wParam lParam -- )
@@ -141,7 +141,7 @@ SYMBOL: hWnd
 : handle-wm-keyup ( hWnd uMsg wParam lParam -- )
     lParam set wParam set uMsg set hWnd set
     wParam get keystroke>gesture <key-up>
-    hWnd get window-focus handle-gesture
+    hWnd get window-focus send-gesture
     drop ;
 
 : cleanup-window ( handle -- )
diff --git a/library/ui/x11/ui.factor b/library/ui/x11/ui.factor
index 23456b8950..95bd513ed5 100644
--- a/library/ui/x11/ui.factor
+++ b/library/ui/x11/ui.factor
@@ -80,7 +80,7 @@ M: world configure-event
 
 M: world key-down-event
     world-focus over key-down-event>gesture [
-        over handle-gesture
+        over send-gesture
         [ swap lookup-string nip swap user-input ] [ 2drop ] if
     ] [
         2drop
@@ -88,7 +88,7 @@ M: world key-down-event
 
 M: world key-up-event
     world-focus swap key-event>gesture dup [
-        <key-up> dup [ swap handle-gesture drop ] [ 2drop ] if
+        <key-up> dup [ swap send-gesture drop ] [ 2drop ] if
     ] [
         3drop
     ] if ;