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