diff options
| -rw-r--r-- | examples/03-font-render.lisp | 23 | ||||
| -rw-r--r-- | wheelwork.lisp | 95 |
2 files changed, 78 insertions, 40 deletions
diff --git a/examples/03-font-render.lisp b/examples/03-font-render.lisp index e47341b..60ffcf2 100644 --- a/examples/03-font-render.lisp +++ b/examples/03-font-render.lisp @@ -26,6 +26,24 @@ -800)) (incf (ww::unit-x target) 5))) +(defvar *spin-table* (make-hash-table :synchronized t)) + +(ww::defhandler spin + (ww::on-perframe () + (let ((rot + (gethash target *spin-table* 0.0))) + (if (< rot (* 8 pi)) + (setf + (gethash target *spin-table*) (+ rot 0.2) + (ww::unit-rotation target) rot) + (progn + (ww::remove-handler target #'spin) + (remhash target *spin-table*)))))) + +(ww::defhandler twirl-on-click + (ww::on-mousedown () + (ww::add-handler target #'spin))) + (defmethod ww::boot ((app font-display)) (let ((hello (make-instance @@ -39,10 +57,7 @@ (ww::unit-y hello) 400) (ww::add-handler hello #'marquee) (ww::add-handler hello #'change-text-color) - (ww::add-handler hello - (ww::on-mousedown () - (format t "I Was Clicked at ~a,~a!~%" - x y))) + (ww::add-handler hello #'twirl-on-click) (ww::refocus-on hello) (ww::add-unit app hello))) diff --git a/wheelwork.lisp b/wheelwork.lisp index b4149ff..37a7bfc 100644 --- a/wheelwork.lisp +++ b/wheelwork.lisp @@ -128,16 +128,19 @@ necessary." (defmethod drop-unit :before ((unit interactive)) (when (unit-container unit) - (when-let (handler (get-handler-for unit 'before-dropped)) - (funcall handler unit)))) + (when-let (handlers (get-handlers-for unit 'before-dropped)) + (dolist (handler handlers) + (funcall handler unit))))) (defmethod add-unit :before ((container container) (unit interactive)) - (when-let (handler (get-handler-for unit 'before-added)) - (funcall handler container unit))) + (when-let (handlers (get-handlers-for unit 'before-added)) + (dolist (handler handlers) + (funcall handler container unit)))) (defmethod add-unit :after ((container container) (unit interactive)) - (when-let (handler (get-handler-for unit 'after-added)) - (funcall handler container unit))) + (when-let (handlers (get-handlers-for unit 'after-added)) + (dolist (handler handlers) + (funcall handler container unit)))) (defun listener-table-for (listener event-type) (ecase event-type @@ -158,21 +161,33 @@ necessary." (defun add-handler (interactive handler) (when (null (listener interactive)) (setf (listener interactive) (make-instance 'listener))) + (pushnew handler (slot-value (listener interactive) (event-type handler)) :test #'eq) (setf - (slot-value (listener interactive) (event-type handler)) handler - (gethash interactive (listener-table-for (listener interactive) (event-type handler))) handler)) + (gethash interactive (listener-table-for (listener interactive) (event-type handler))) + t)) (defun remove-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." + whose name is an event type. If is an event handler, only that + handler will be removed. If it is an event type, all events of that + type name are removed from the object." (when (listener interactive) (let ((event-type (etypecase handler-or-event-type (keyword (intern (symbol-name handler-or-event-type) :wheelwork)) (symbol (intern (symbol-name handler-or-event-type) :wheelwork)) (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))))) + (setf (slot-value (listener interactive) event-type) + (if (symbolp handler-or-event-type) + ;; remove everything if a symbol + nil + ;; delete just the handler + (delete handler-or-event-type + (slot-value (listener interactive) event-type) + :test #'eq))) + ;; remove from from the global table unless any listeners remain on this event + (unless (slot-value (listener interactive) event-type) + (remhash interactive (listener-table-for (listener interactive) event-type)))))) @@ -219,12 +234,14 @@ necessary." (setf (listener app) (make-instance 'listener))) (defun fire-blur-event-on (thing) - (when-let (blur-handler (and thing (get-handler-for thing 'blur))) - (funcall blur-handler thing))) + (when-let (blur-handlers (and thing (get-handlers-for thing 'blur))) + (dolist (handler blur-handlers) + (funcall handler thing)))) (defun fire-focus-event-on (thing) - (when-let (focus-handler (and thing (get-handler-for thing 'focus))) - (funcall focus-handler thing))) + (when-let (focus-handlers (and thing (get-handlers-for thing 'focus))) + (dolist (handler focus-handlers) + (funcall handler thing)))) (defmethod (setf closer-mop:slot-value-using-class ) :before (new-value class (app application) slot) @@ -310,8 +327,8 @@ necessary." (let ((table (perframe-table (listener app))) (time (get-universal-time))) (loop for target being the hash-key of table - for handler being the hash-value of table - do (funcall handler target time))) + for handlers = (slot-value (listener target) 'perframe) + do (loop for handler in handlers do (funcall handler target time)))) (gl:clear-color 0.0 0.0 0.0 1.0) (gl:clear :depth-buffer-bit :color-buffer-bit) (dolist (thing (container-units app)) @@ -415,25 +432,27 @@ TARGET is FOCUSABLEP" (defun get-focus (&optional (app *application*)) (or (application-focus app) app)) -(defun get-handler-for (unit event-type) +(defun get-handlers-for (unit event-type) "EVENT-TYPE must be one of the slot value names for WHEELWORK::LISTENER." (?> (unit) listener #$(slot-value $listener event-type))) (defun eventloop-keydown (app sdl-keysym) (let ((target (get-focus app))) - (when-let (handler (get-handler-for target 'keydown)) - (apply handler - target - (sdl2:scancode sdl-keysym) - (sdl2:mod-keywords (sdl2:mod-value sdl-keysym)))))) + (when-let (handlers (get-handlers-for target 'keydown)) + (dolist (handler handlers) + (apply handler + target + (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)))))) + (when-let (handlers (get-handlers-for target 'keyup)) + (dolist (handler handlers) + (apply handler + target + (sdl2:scancode sdl-keysym) + (sdl2:mod-keywords (sdl2:mod-value sdl-keysym))))))) (defun contains-point-p (unit px py) (with-accessors ((x unit-x) (y unit-y) (width unit-width) (height unit-height)) unit @@ -466,16 +485,18 @@ give focus to whatever was clicked." app))) ; then target the app itself (when (and (refocus-on-mousedown-p app) (focusablep target)) (refocus-on target)) - (when-let (handler (get-handler-for target 'mousedown)) - (funcall handler target x y clicks button wx wy))))) + (when-let (handlers (get-handlers-for target 'mousedown)) + (dolist (handler handlers) + (funcall handler target x y clicks button wx wy)))))) (defun eventloop-mousebuttonup (app wx wy clicks button) (when (should-listen-for-p 'mouseup app) (destructuring-bind (x y) (screen-to-world wx wy) (when-let* ((target (or (unit-under app x y) app)) - (handler (get-handler-for target 'mouseup))) - (funcall handler target x y clicks button wx wy))))) + (handlers (get-handlers-for target 'mouseup))) + (dolist (handler handlers) + (funcall handler target x y clicks button wx wy)))))) (defun eventloop-mousemotion (app wx wy wxrel wyrel state) (when (should-listen-for-p 'mousemotion app) @@ -483,14 +504,16 @@ give focus to whatever was clicked." (destructuring-bind (xrel yrel) (screen-to-world wxrel wyrel) (when-let* ((target (or (unit-under app x y) app)) - (handler (get-handler-for target 'mousemotion))) - (funcall handler target x y xrel yrel state wx wy wxrel wyrel)))))) + (handlers (get-handlers-for target 'mousemotion))) + (dolist (handler handlers) + (funcall handler target x y xrel yrel state wx wy wxrel wyrel))))))) (defun eventloop-mousewheel (app wx wy dir) (when (should-listen-for-p 'mousewheel app) (when-let* ((focus (get-focus app)) - (handler (get-handler-for focus 'mousewheel))) - (funcall handler focus wx wy dir)))) + (handlers (get-handlers-for focus 'mousewheel))) + (dolist (handler handlers) + (funcall handler focus wx wy dir))))) (defun eventloop (app) |