diff options
| -rw-r--r-- | examples/01-bitmap-display.lisp | 26 | ||||
| -rw-r--r-- | src/application.lisp | 8 | ||||
| -rw-r--r-- | src/utils.lisp | 2 | ||||
| -rw-r--r-- | src/wheelwork.lisp | 86 |
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 |