From 76d137475350287f6eddf7083ff0b7507a305e8c Mon Sep 17 00:00:00 2001
From: Colin Okay <colin@cicadas.surf>
Date: Thu, 23 Jun 2022 08:56:28 -0500
Subject: [add] eventhandling for mousedown and keyup

---
 wheelwork.lisp | 57 ++++++++++++++++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 52 insertions(+), 5 deletions(-)

(limited to 'wheelwork.lisp')

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)))
 
-- 
cgit v1.2.3