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

4 files changed, 98 insertions, 24 deletions

diff --git a/examples/01-bitmap-display.lisp b/examples/01-bitmap-display.lisp
index c9e0275..4bcdba8 100644
--- a/examples/01-bitmap-display.lisp
+++ b/examples/01-bitmap-display.lisp
@@ -8,6 +8,24 @@
 
 (defclass bitmap-display (ww::application ) ())
 
+(ww::defhandler dragging-unit
+    (ww::on-mousemotion (app x y)
+      (let ((unit
+              (first (ww:container-units app))))
+        (setf (ww:x unit) x
+              (ww:y unit) y))))
+
+(ww:defhandler start-drag
+    (ww:on-mousedown (target)
+      (ww::add-handler
+       (ww::unit-container target)
+       #'dragging-unit)))
+
+(ww:defhandler stop-drag
+    (ww::on-mouseup (app)
+      (ww::remove-handler app #'dragging-unit)))
+
+
 (defmethod ww::boot ((app bitmap-display))
   (let ((bm
           (make-instance 'ww::bitmap
@@ -15,13 +33,19 @@
     (describe (ww::model-matrix bm))
     (describe bm)
     (describe app)
-    (ww::add-unit app bm)))
+    (ww::add-unit app bm)
+    (ww::add-handler bm #'start-drag)
+    (ww::add-handler app #'stop-drag)
+    (format t "CLICK AND DRAG THE GHOUL~%")
+    ))
 
 
 (defun start ()
   (ww::start
    (make-instance
     'bitmap-display
+    :mouse-button-events-bubble-p t 
+    :mouse-motion-events-bubble-p t
     :asset-root (merge-pathnames
                  "examples/"
                  (asdf:system-source-directory :wheelwork)))))
diff --git a/src/application.lisp b/src/application.lisp
index e9a41dc..ef5e92f 100644
--- a/src/application.lisp
+++ b/src/application.lisp
@@ -22,7 +22,13 @@
     :std t
     :doc "When T, clicking on a visible object will set the
     application focus to that object.")
-   (focus last-motion-target :with :a)
+   (mouse-button-events-bubble-p
+    mouse-motion-events-bubble-p
+    :std nil
+    :doc "determines whether the search for event handlers stops at
+    the first visible unit under the xy position of the mouse or
+    not. ")
+  (focus last-motion-target :with :a)
    (fps :std 30 :doc "Frames Per Second")
    (frame-wait :r))
   (:documentation "The application contains the information and data
diff --git a/src/utils.lisp b/src/utils.lisp
index 4a35aee..f3dba06 100644
--- a/src/utils.lisp
+++ b/src/utils.lisp
@@ -118,7 +118,7 @@ the path."
     (sqrt (+ (* dx dx) (* dy dy)))))
 
 (let ((cache
-        (make-array 100 :adjustable t :initial-element nibbles:)))
+        (make-array 100 :adjustable t :initial-element nil)))
  (defun factorial (n)
    (cond
      ((zerop n) 1)
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