[add] mouse event bubbling; [example] click-and-drag to 01

1 files changed, 65 insertions, 21 deletions

diff --git a/src/wheelwork.lisp b/src/wheelwork.lisp
index 41157e6..31efe14 100644
--- a/src/wheelwork.lisp
+++ b/src/wheelwork.lisp
@@ -71,8 +71,18 @@ TARGET is FOCUSABLEP"
 (defun unit-contains-point-p (unit pt)
   (path-encloses-point-p (get-rect unit) pt))
 
+(defun mouse-event-targets (app x y &optional bubblep)
+  "Returns a list of one or more objects found under the x y
+position.  The list always contains the app itself as the last element."
+  (nconc (if bubblep
+             (all-units-under app x y)
+             (unit-under app x y))
+         (list app)))
+
+
 (defun unit-under (app x y)
-  "Finds the visible unit that contains the point x y."
+  "Finds the visible unit that contains the point x y, returns it as a
+single elemtn list, or nil if none found"
   (let ((xy (vec:vec x y 0.0 1.0))) 
     (labels
         ((finder (thing)
@@ -83,9 +93,35 @@ TARGET is FOCUSABLEP"
                   (find-if #'finder (container-units thing) :from-end t)))
                (unit
                 (when (unit-contains-point-p thing xy)
-                  (return-from unit-under thing)))))))
+                  (return-from unit-under (list thing))))))))
       (finder app))))
 
+(defun all-units-under (app x y)
+  "Finds all units under the point x y"
+  (let ((xy
+          (vec:vec x y 0.0 1.0))
+        (units
+          nil)) 
+    (labels
+        ((finder (thing)
+           (when (unit-visiblep thing) 
+             (etypecase thing
+               (container
+                (when (unit-contains-point-p thing xy)
+                  (mapc #'finder (container-units thing))))
+               (unit
+                (when (unit-contains-point-p thing xy)
+                  (push thing units)))))))
+      (finder app))
+    units))
+
+(defvar *event-still-bubbling-p* nil
+  "Controls whether an event is bubbling")
+
+(defun stop-bubbling ()
+  (setf *event-still-bubbling-p* nil))
+
+
 (defun screen-to-world (x y &optional (app *application*))
   "Scales the screen point - the literal pixel position relative to
 the top corner of the application window - to reflect the
@@ -99,33 +135,42 @@ application's scaling factor."
 Additionally, if the APPLICATION's REFOCUS-ON-MOUSEDOWN-P is T, try to
 give focus to whatever was clicked."
   (destructuring-bind (x y) (screen-to-world wx wy)
-    (let ((target
-            (or (unit-under app x y)    ; if no unit is under the mouse,
-                app)))                  ; then target the app itself
-      (when (and (refocus-on-mousedown-p app) (focusablep target))
-        (refocus-on target))              
-      (when-let (handlers (get-handlers-for target 'mousedown))
-        (dolist (handler handlers) 
-          (funcall handler target x y clicks button wx wy))))))
+    (let ((candidate-targets
+            (mouse-event-targets app x y (mouse-button-events-bubble-p app))))  
+      ;; refocus always occurs on the "top" focasable thing
+      (when (and (refocus-on-mousedown-p app)
+                 (focusablep (first candidate-targets)))
+        (refocus-on (first candidate-targets)))              
+      (let ((*event-still-bubbling-p*
+              (mouse-button-events-bubble-p app))) 
+        (loop for target in candidate-targets
+              do
+                 (dolist (handler (get-handlers-for target 'mousedown)) 
+                   (funcall handler target x y clicks button wx wy))
+              while *event-still-bubbling-p*)))))
 
 (defun eventloop-mousebuttonup (app wx wy clicks button)
   (when (should-listen-for-p 'mouseup app)
     (destructuring-bind (x y) (screen-to-world wx wy)
-      (when-let* ((target (or (unit-under app x y)
-                              app))
-                  (handlers (get-handlers-for target 'mouseup)))
-        (dolist (handler handlers) 
-          (funcall handler target x y clicks button wx wy))))))
+      (let ((*event-still-bubbling-p*
+              (mouse-button-events-bubble-p app))) 
+        (loop for target in (mouse-event-targets app x y (mouse-button-events-bubble-p app))
+              do 
+                (dolist (handler (get-handlers-for target 'mouseup)) 
+                  (funcall handler target x y clicks button wx wy))
+              while *event-still-bubbling-p*)))))
 
 (defun eventloop-mousemotion (app wx wy wxrel wyrel state)
   (when (should-listen-for-p 'mousemotion app)
     (destructuring-bind (x y) (screen-to-world wx wy)
       (destructuring-bind (xrel yrel) (screen-to-world wxrel wyrel)
-        (when-let* ((target (or (unit-under app x y)
-                                app))
-                    (handlers (get-handlers-for target 'mousemotion)))
-          (dolist (handler handlers) 
-            (funcall handler target x y xrel yrel state wx wy wxrel wyrel)))))))
+        (let ((*event-still-bubbling-p*
+                (mouse-motion-events-bubble-p app))) 
+          (loop for target in (mouse-event-targets app x y (mouse-motion-events-bubble-p app))
+                do 
+                  (dolist (handler (get-handlers-for target 'mousemotion)) 
+                    (funcall handler target x y xrel yrel state wx wy wxrel wyrel))
+                while *event-still-bubbling-p*))))))
 
 (defun eventloop-mousewheel (app wx wy dir)
   (when (should-listen-for-p 'mousewheel app)
@@ -134,7 +179,6 @@ give focus to whatever was clicked."
       (dolist (handler handlers) 
         (funcall handler focus wx wy dir)))))
 
-
 (defun eventloop (app)
   (sdl2:with-event-loop (:method :poll)
     (:mousebuttondown