diff options
| -rw-r--r-- | wheelwork.lisp | 99 |
1 files changed, 91 insertions, 8 deletions
diff --git a/wheelwork.lisp b/wheelwork.lisp index 3a39dd2..0fdfdf4 100644 --- a/wheelwork.lisp +++ b/wheelwork.lisp @@ -24,20 +24,24 @@ transformation affine transformations methods can be specialzied on whole groups of units")) -(defun remove-unit (unit) +(defgeneric drop-unit (unit)) + +(defmethod drop-unit ((unit unit)) "Removes a unit from its container. Returns T if the unit actually was removed." (when (unit-container unit) (setf - (container-units (unit-container unit)) (delete unit (container-units (unit-container units))) + (container-units (unit-container unit)) (delete unit (container-units (unit-container unit))) (unit-container unit) nil) t)) -(defun add-unit (container unit) +(defgeneric add-unit (container unit)) + +(defmethod add-unit ((container container) (unit unit)) "Adds a unit to the end of a container (thus affecting render order). Makes sure to remove the unit from its current container if necessary." (when (unit-container unit) - (remove-unit unit)) + (drop-unit unit)) (setf (container-units container) (nconc (container-units container) (list unit))) @@ -52,8 +56,19 @@ necessary." (closer-mop:set-funcallable-instance-function eh handler-function))) (defclass/std listener () - ((keydown keyup mousedown mouseup mousemotion mousewheel focus blur perframe - :r :with :type (or null event-handler) :std nil) + ((keydown + keyup + mousedown + mouseup + mousemotion + mousewheel + focus + blur + perframe + after-added + before-added + before-dropped + :r :with :type (or null event-handler) :std nil) (keydown-table keyup-table mousedown-table @@ -63,6 +78,9 @@ necessary." focus-table blur-table perframe-table + after-added-table + before-added-table + before-dropped-table :static :std (make-hash-table :synchronized t) :doc "Keyed by DISPLAY-UNIT instance, holds an EVENT-HANDLER if handler is defined for unit.")) @@ -74,6 +92,19 @@ necessary." (focusablep :std t :doc "Whether or not this object can receive application focus.")) (:documentation "Supplies an object with a listener slot.")) +(defmethod drop-unit :before ((unit interactive)) + (when (unit-container unit) + (when-let (handler (get-handler-for unit 'before-dropped)) + (funcall handler unit)))) + +(defmethod add-unit :before ((container container) (unit interactive)) + (when-let (handler (get-handler-for unit 'before-added)) + (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))) + (defun listener-table-for (listener event-type) (ecase event-type (keydown (keydown-table listener)) @@ -84,7 +115,11 @@ necessary." (mousewheel (mousewheel-table listener)) (focus (focus-table listener)) (blur (blur-table listener)) - (perframe (perframe-table listener)))) + (perframe (perframe-table listener)) + (after-added (after-added-table listener)) + (before-added (before-added-table listener)) + (after-dropped (after-dropped-table listener)) + (before-dropped (before-dropped-table listener)))) (defun set-handler (interactive handler) (when (null (listener interactive)) @@ -193,7 +228,8 @@ necessary." (defconstant +listener-table-slot-names+ '(keydown-table keyup-table mousedown-table mouseup-table mousemotion-table - focus-table blur-table perframe-table)) + focus-table blur-table perframe-table after-added-table before-added-table + before-dropped-table)) (defmethod cleanup ((app application)) (loop for asset being the hash-value of (application-assets app) @@ -780,3 +816,50 @@ fires when the FOCUS slot of the current APPLICATION instance is changed. (declare (ignorable ,(intern (symbol-name target)))) ,@body))) + +(defmacro on-before-dropped + ((&optional (target 'target)) &body body) + "Creates a handler for BEFORE-DROPPED events, which fire before a + unit is removed from its container." + `(make-instance + 'event-handler + :event-type 'wheelwork::before-dropped + :handler-function (lambda + (,(intern (symbol-name target))) + (declare + (ignorable ,(intern (symbol-name target)))) + ,@body))) + +(defmacro on-before-added + ((&optional (container 'container) (target 'target)) &body body) + "Creates a handler for BEFORE-ADDED events, which fire before a unit + is added to a container." + `(make-instance + 'event-handler + :event-type 'wheelwork::before-added + :handler-function (lambda + (,(intern (symbol-name container)) + ,(intern (symbol-name target))) + (declare + (ignorable + ,(intern (symbol-name container)) + ,(intern (symbol-name target)))) + ,@body))) + + +(defmacro on-after-added + ((&optional (container 'container) (target 'target)) &body body) + "Creates a handler for AFTER-ADDED events, which fire after a unit + is added to a container." + `(make-instance + 'event-handler + :event-type 'wheelwork::after-added + :handler-function (lambda + (,(intern (symbol-name container)) + ,(intern (symbol-name target))) + (declare + (ignorable + ,(intern (symbol-name container)) + ,(intern (symbol-name target)))) + ,@body))) + |