[add] eventhandling for mousedown and keyup

5 files changed, 78 insertions, 12 deletions

diff --git a/examples/02-moving-bitmp.lisp b/examples/02-moving-bitmp.lisp
index 425457b..4706d1b 100644
--- a/examples/02-moving-bitmp.lisp
+++ b/examples/02-moving-bitmp.lisp
@@ -21,21 +21,39 @@
            (incf                  (ww::unit-width unit) 20.0)))
         (:scancode-minus
          (decf (ww::unit-height unit) 20.0)
-         (decf                (ww::unit-width unit) 20.0)))))
+         (decf                (ww::unit-width unit) 20.0)))
+      (format t "ghoul pos: ~a,~a~%"
+              (ww::unit-x unit) (ww::unit-y unit))))
+
+(ww::defhandler thing-clicked
+    (ww::on-mousedown (unit x y clicks button)
+      (format t "~a was clicked at ~a,~a!~%" unit x y)))
 
 (defmethod ww::boot ((app bitmap-display))
   (let ((bm
           (make-instance 'ww::bitmap
-                         :texture (ww::get-asset "Fezghoul.png"))))
+                         :texture (ww::get-asset "Fezghoul.png")))
+        (bm2
+          (make-instance 'ww::bitmap
+                         :texture (ww::get-asset "RootBear.png"))))
+    ;; first 
     (ww::refocus-on bm)
     (ww::set-handler bm #'move-thing)
-    (ww::add-unit app bm)))
+    (ww::set-handler bm #'thing-clicked )
+    (ww::add-unit app bm)
+    ;;second
+    (setf (ww::unit-x bm2) 90
+          (ww::unit-y bm2) 90)
+    (ww::set-handler bm2 #'move-thing)
+    (ww::set-handler bm2 #'thing-clicked)
+    (ww::add-unit app bm2)))
 
 
 (defun start ()
   (ww::start (make-instance 'bitmap-display
-                            :scale 3.0
+                            :scale 2.0
                             :asset-root #P"~/projects/wheelwork/examples/")))
 
 
-(start)
+
+
diff --git a/examples/RootBear.png b/examples/RootBear.png
new file mode 100644
index 0000000..fd51298
--- /dev/null
+++ b/examples/RootBear.png
diff --git a/package.lisp b/package.lisp
index 85dce2a..74c9477 100644
--- a/package.lisp
+++ b/package.lisp
@@ -5,7 +5,7 @@
   (:nicknames #:ww)
   (:local-nicknames (#:mat #:3d-matrices)
                     (#:vec #:3d-vectors))
-  (:import-from #:hyperquirks #:defvarf)
+  (:import-from #:hyperquirks #:?>)
   (:import-from #:defclass-std #:defclass/std)
   (:import-from #:alexandria
                 #:when-let #:when-let* #:if-let))
diff --git a/wheelwork.asd b/wheelwork.asd
index 582c9ab..eac3bc5 100644
--- a/wheelwork.asd
+++ b/wheelwork.asd
@@ -14,6 +14,7 @@
                #:3d-matrices
                #:hyperquirks
                #:pngload
-               #:closer-mop)
+               #:closer-mop
+               #:lambda-riffs)
   :components ((:file "package")
                (:file "wheelwork")))
diff --git a/wheelwork.lisp b/wheelwork.lisp
index d30cf19..629b485 100644
--- a/wheelwork.lisp
+++ b/wheelwork.lisp
@@ -226,11 +226,9 @@ order). Makes sure to remove the unit from its current container if necessary."
     (closer-mop:set-funcallable-instance-function eh handler-function)))
 
 
-
-
 (defclass/std listener ()
   ((keydown keyup mousedown mouseup mousemove mousewheel focus blur perframe
-            :r :with :type event-handler)
+            :r :with :type (or null event-handler) :std nil)
    (keydown-table
     keyup-table
     mousedown-table
@@ -296,8 +294,7 @@ order). Makes sure to remove the unit from its current container if necessary."
 
 (defun get-handler-for (unit event-type)
   "EVENT-TYPE must be one of the slot value names for WHEELWORK::LISTENER."
-  (when (listener unit)
-    (slot-value (listener unit) event-type)))
+  (?> (unit) listener #$(slot-value $listener event-type)))
 
 (defun eventloop-keydown (app sdl-keysym)
   (let ((target (get-focus app))) 
@@ -307,11 +304,61 @@ order). Makes sure to remove the unit from its current container if necessary."
              (sdl2:scancode sdl-keysym)
              (sdl2:mod-keywords (sdl2:mod-value sdl-keysym))))))
 
+(defun eventloop-keyup (app sdl-keysym)
+  (let ((target (get-focus app))) 
+    (when-let (handler (get-handler-for target 'keyup)) 
+      (apply handler
+             target
+             (sdl2:scancode sdl-keysym)
+             (sdl2:mod-keywords (sdl2:mod-value sdl-keysym))))))
+
+(defun contains-point-p (unit px py)
+  (with-slots (x y width height) unit
+    (and (<= x px (+ x width))
+         (<= y py (+ y height)))))
+
+(defun unit-under (app x y)
+  (labels
+      ((finder (thing)
+         (etypecase thing
+           (container
+            (find-if #'finder (container-units thing) :from-end t))
+           (unit
+            (when  (contains-point-p thing x y)
+              (return-from unit-under thing))))))
+    (finder app)))
+
+(defun screen-to-world (x y &optional (app *application*))
+  (with-slots (height scale) app
+    (list (/ x scale) (/ (- height y) scale))))
+
+(defun eventloop-mousebuttondown (app x y clicks button)
+  "Searches for a handler to handle applies it if found.
+
+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 x y)
+    (when-let (target (unit-under app x y))
+      (when (refocus-on-mousedown-p app)
+        (refocus-on target))              
+      (when-let (handler (get-handler-for target 'mousedown))
+        (funcall handler target x y clicks button)))))
+
+
+
+
+
 (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))
     (:keydown
      (:keysym keysym)
      (eventloop-keydown app keysym))
+    (:keyup
+     (:keysym keysym)
+     (eventloop-keyup app keysym))
     (:idle () (render app))
     (:quit () t)))