diff options
Diffstat (limited to 'wheelwork.lisp')
| -rw-r--r-- | wheelwork.lisp | 57 |
1 files changed, 52 insertions, 5 deletions
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))) |