[add] mousemotion handlers; [modify] app subclass interactive

2 files changed, 61 insertions, 44 deletions

diff --git a/examples/02-moving-bitmp.lisp b/examples/02-moving-bitmp.lisp
index 4706d1b..5d33de8 100644
--- a/examples/02-moving-bitmp.lisp
+++ b/examples/02-moving-bitmp.lisp
@@ -29,6 +29,10 @@
     (ww::on-mousedown (unit x y clicks button)
       (format t "~a was clicked at ~a,~a!~%" unit x y)))
 
+(ww::defhandler mouse-over
+    (ww::on-mousemotion (target x y xrel yrel state)
+      (print (list target x y xrel yrel state))))
+
 (defmethod ww::boot ((app bitmap-display))
   (let ((bm
           (make-instance 'ww::bitmap
@@ -39,7 +43,8 @@
     ;; first 
     (ww::refocus-on bm)
     (ww::set-handler bm #'move-thing)
-    (ww::set-handler bm #'thing-clicked )
+    (ww::set-handler bm #'thing-clicked)
+    (ww::set-handler bm #'mouse-over)
     (ww::add-unit app bm)
     ;;second
     (setf (ww::unit-x bm2) 90
diff --git a/wheelwork.lisp b/wheelwork.lisp
index 629b485..34efd3c 100644
--- a/wheelwork.lisp
+++ b/wheelwork.lisp
@@ -40,7 +40,44 @@ order). Makes sure to remove the unit from its current container if necessary."
      (unit-container unit) nil)
     t))
           
-(defclass/std application (container)
+(defclass/std interactive ()
+  ((listener :type (or null listener) :std nil :a)))
+
+(defun set-handler (interactive handler)
+  (when (null (listener interactive))
+    (setf (listener interactive) (make-instance 'listener)))
+  (setf
+   (slot-value (listener interactive) (event-type handler))        handler
+   (gethash interactive (listener-table-for (listener interactive) (event-type handler))) t))
+
+(defun unset-handler (interactive handler-or-event-type)
+  "Handler can be an instance of EVENT-HANDLER or can be a symbol
+  whose name is an event type."
+  (when (listener interactive)
+    (let ((event-type (etypecase handler-or-event-type
+                        (keyword (intern (symbol-name handler-or-event-type)))
+                        (symbol (intern (symbol-name handler-or-event-type)))
+                        (event-handler (event-type handler-or-event-type)))))
+      (setf (slot-value (listener interactive) event-type) nil)
+      (remhash interactive (listener-table-for (listener interactive) event-type)))))
+
+(defun listener-table-for (listener event-type)
+  (ecase event-type
+    (keydown (keydown-table listener))
+    (keyup   (keyup-table listener))
+    (mousedown (mousewheel-table listener))
+    (mouseup (mouseup-table listener))
+    (mousemotion (mousemotion-table listener))
+    (mousewheel (mousewheel-table listener))
+    (focus (focus-table listener))
+    (blur (blur-table listener))
+    (perframe (perframe-table listener))))
+
+(defun should-listen-for-p (event-type &optional (app *application*))
+  (plusp (hash-table-count (listener-table-for (listener app) event-type))))
+
+
+(defclass/std application (container interactive)
   ((title :with :std "Wheelwork App")
    (asset-root :ri :std #P"./" :doc "Directory under which assets are stored.")
    (asset-classifiers
@@ -56,6 +93,7 @@ order). Makes sure to remove the unit from its current container if necessary."
    (focus last-motion-target :with :a)
    (frame-wait :std (/ 1000 30) :doc "Frames Per Second" :a)))
 
+
 (defun can-set-projection-p (app)
   (and (slot-boundp app 'width)
        (slot-boundp app 'height)
@@ -68,7 +106,8 @@ order). Makes sure to remove the unit from its current container if necessary."
       (setf projection (mat:mortho 0.0 (/ width scale) 0 (/ height scale) -1.0 1.0)))))
 
 (defmethod initialize-instance :after ((app application) &key)
-  (set-projection app))
+  (set-projection app)
+  (setf (listener app) (make-instance 'listener)))
 
 (defmethod (setf closer-mop:slot-value-using-class) :after
     (new-value class (app application) slot)
@@ -227,13 +266,13 @@ order). Makes sure to remove the unit from its current container if necessary."
 
 
 (defclass/std listener ()
-  ((keydown keyup mousedown mouseup mousemove mousewheel focus blur perframe
+  ((keydown keyup mousedown mouseup mousemotion mousewheel focus blur perframe
             :r :with :type (or null event-handler) :std nil)
    (keydown-table
     keyup-table
     mousedown-table
     mouseup-table
-    mousemove-table
+    mousemotion-table
     mousewheel-table
     focus-table
     blur-table
@@ -244,41 +283,8 @@ order). Makes sure to remove the unit from its current container if necessary."
   (:documentation "Event handlers per object. The static hash tables
   are keyed by UNIT and hold Event-Handler instances."))
 
-(defclass/std interactive-unit (unit)
-  ((listener :type (or null listener) :std nil :a)))
-
-(defun set-handler (unit handler)
-  (when (null (listener unit))
-    (setf (listener unit) (make-instance 'listener)))
-  (setf
-   (slot-value (listener unit) (event-type handler))        handler
-   (gethash unit (listener-table-for (listener unit) (event-type handler))) t))
-
-(defun unset-handler (unit handler-or-event-type)
-  "Handler can be an instance of EVENT-HANDLER or can be a symbol
-  whose name is an event type."
-  (when (listener unit)
-    (let ((event-type (etypecase handler-or-event-type
-                        (keyword (intern (symbol-name handler-or-event-type)))
-                        (symbol (intern (symbol-name handler-or-event-type)))
-                        (event-handler (event-type handler-or-event-type)))))
-      (setf (slot-value (listener unit) event-type) nil)
-      (remhash unit (listener-table-for (listener unit) event-type)))))
 
-(defun listener-table-for (listener event-type)
-  (ecase event-type
-    (keydown (keydown-table listener))
-    (keyup   (keyup-table listener))
-    (mousedown (mousewheel-table listener))
-    (mouseup (mouseup-table listener))
-    (mousemove (mousemove-table listener))
-    (mousewheel (mousewheel-table listener))
-    (focus (focus-table listener))
-    (blur (blur-table listener))
-    (perframe (perframe-table listener))))
 
-(defun should-listen-for-p (listener event-type)
-  (plusp (hash-table-count (listener-table-for listener event-type))))
 
 (defun refocus-on (target &optional (app *application*))
   "Handles changing application focus, calling appropriate blur and focus handlers."
@@ -344,15 +350,21 @@ give focus to whatever was clicked."
       (when-let (handler (get-handler-for target 'mousedown))
         (funcall handler target x y clicks button)))))
 
-
-
-
+(defun eventloop-mousemotion (app x y xrel yrel state)
+  (when (should-listen-for-p 'mousemotion app)
+    (destructuring-bind (x y) (screen-to-world x y)
+      (when-let* ((target (unit-under app x y))
+                  (handler (get-handler-for target 'mousemotion)))
+        (funcall handler target x y xrel yrel state)))))
 
 (defun eventloop (app)
   (sdl2:with-event-loop (:method :poll)
     (:mousebuttondown
      (:x x :y y :clicks clicks :button button)
      (eventloop-mousebuttondown app x y clicks button))
+    (:mousemotion
+     (:x x :y y :xrel xrel :yrel yrel :state state)
+     (eventloop-mousemotion app x y xrel yrel state))
     (:keydown
      (:keysym keysym)
      (eventloop-keydown app keysym))
@@ -362,7 +374,7 @@ give focus to whatever was clicked."
     (:idle () (render app))
     (:quit () t)))
 
-(defclass/std bitmap (interactive-unit)
+(defclass/std bitmap (unit interactive)
   ((texture :ri :std (error "A bitmap requires a texture."))
    (vao shader :with :r :static)))
 
@@ -557,11 +569,11 @@ disk."
                         (declare (ignorable ,target ,scancode ,modifiers))
                         ,@body)))
 
-(defmacro on-mousemove
+(defmacro on-mousemotion
     ((target x y xrel yrel state) &body body)
   `(make-instance
     'event-handler
-    :event-type 'wheelwork::mousemove
+    :event-type 'wheelwork::mousemotion
     :handler-function (lambda (,target ,x ,y ,xrel ,yrel ,state)
                         (declare (ignorable ,target ,x ,y ,xrel ,yrel ,state))
                         ,@body)))