diff options
Diffstat (limited to 'src/events')
| -rw-r--r-- | src/events/event-handler.lisp | 260 | ||||
| -rw-r--r-- | src/events/listener-and-interactive.lisp | 108 | ||||
| -rw-r--r-- | src/events/listener.lisp | 4 |
3 files changed, 372 insertions, 0 deletions
diff --git a/src/events/event-handler.lisp b/src/events/event-handler.lisp new file mode 100644 index 0000000..bd40849 --- /dev/null +++ b/src/events/event-handler.lisp @@ -0,0 +1,260 @@ +;;;; event-handler.lisp + +(in-package #:wheelwork) + + +(defclass/std event-handler () + ((event-type handler-function :ri)) + (:metaclass closer-mop:funcallable-standard-class)) + +(defmethod initialize-instance :after ((eh event-handler) &key) + (with-slots (handler-function) eh + (closer-mop:set-funcallable-instance-function eh handler-function))) + + +(defmacro defhandler (name handler) + "Defines a handler - binds (FDEFINITION NAME) to HANDLER, which +should be an expression that evaluates to an instance of +EVENT-HANDLER, which is funcallable. It is define such that handlers +can be redefined using this form to support interactive development." + (let ((handler-var (gensym))) + `(let ((,handler-var ,handler)) + (if-let (extant (and (fboundp ',name) + (fdefinition ',name))) + (closer-mop:set-funcallable-instance-function extant (handler-function ,handler-var)) + (setf (fdefinition ',name) ,handler-var))))) + + +(defmacro on-perframe + ((&optional (target 'target) (time 'time)) &body body) + "Creates a handler for 'PERFRAME events" + `(make-instance + 'event-handler + :event-type 'wheelwork::perframe + :handler-function (lambda (,(intern (symbol-name target)) + ,(intern (symbol-name time))) + (declare (ignorable ,(intern (symbol-name target)) + ,(time (intern (symbol-name time))))) + ,@body))) + +(defmacro on-keydown + ((&optional (target 'target) (scancode 'scancode) (modifiers 'modifiers)) &body body) + "Creates a lambda suitable for the value of a keydown event + handler. The function accepts two positional arguments TARGET and + SCANCODE and one &REST argument MODIFIERS. + + SCANCODE will be a keyword of the form :SCANCODE-A, :SCANCODE-B ... + + The members of MODIFIERS look like :LSHIFT, :RCTRL, RALT, etc" + `(make-instance + 'event-handler + :event-type 'wheelwork::keydown + :handler-function (lambda (,(intern (symbol-name target)) + ,(intern (symbol-name scancode)) + &rest ,(intern (symbol-name modifiers))) + (declare (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name scancode)) + ,(intern (symbol-name modifiers)))) + ,@body))) + +(defmacro on-keyup + ((&optional (target 'target) (scancode 'scancode) (modifiers 'modifiers)) &body body) + "Creates a lambda suitable for the value of a keyup event + handler. The function accepts two positional arguments TARGET and + SCANCODE and one &REST argument MODIFIERS. + + SCANCODE will be a keyword of the form :SCANCODE-A, :SCANCODE-B ... + + The members of MODIFIERS look like :LSHIFT, :RCTRL, RALT, etc" + `(make-instance + 'event-handler + :event-type 'wheelwork::keyup + :handler-function (lambda (,(intern (symbol-name target)) + ,(intern (symbol-name scancode)) + &rest ,(intern (symbol-name modifiers))) + (declare (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name scancode)) + ,(intern (symbol-name modifiers)))) + ,@body))) + +(defmacro on-mousemotion + ((&optional + (target 'target) + (x 'x) (y 'y) + (xrel 'xrel) (yrel 'yrel) + (state 'state) + (win-x 'win-x) (win-y 'win-y) + (win-xrel 'win-xrel) (win-yrel 'win-yrel)) + &body body) + "Creates a handler for MOUSEMOTION events" + `(make-instance + 'event-handler + :event-type 'wheelwork::mousemotion + :handler-function (lambda (,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name xrel)) + ,(intern (symbol-name yrel)) + ,(intern (symbol-name state)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y)) + ,(intern (symbol-name win-xrel)) + ,(intern (symbol-name win-yrel))) + (declare (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name xrel)) + ,(intern (symbol-name yrel)) + ,(intern (symbol-name state)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y)) + ,(intern (symbol-name win-xrel)) + ,(intern (symbol-name win-yrel)))) + ,@body))) + +(defmacro on-mousedown + ((&optional (target 'target) + (x 'x) (y 'y) + (clicks 'clicks) (button 'button) + (win-x 'win-x) (win-y 'win-y)) + &body body) + "Creates a handler for MOUSEDOWN events" + `(make-instance + 'event-handler + :event-type 'wheelwork::mousedown + :handler-function (lambda + (,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name clicks)) + ,(intern (symbol-name button)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y))) + (declare + (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name clicks)) + ,(intern (symbol-name button)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y)))) + ,@body))) + +(defmacro on-mouseup + ((&optional (target 'target) + (x 'x) (y 'y) + (clicks 'clicks) (button 'button) + (win-x 'win-x) (win-y 'win-y)) + &body body) + "Creates a handler for MOUSEUP events" + `(make-instance + 'event-handler + :event-type 'wheelwork::mouseup + :handler-function (lambda + (,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name clicks)) + ,(intern (symbol-name button)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y))) + (declare + (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name x)) + ,(intern (symbol-name y)) + ,(intern (symbol-name clicks)) + ,(intern (symbol-name button)) + ,(intern (symbol-name win-x)) + ,(intern (symbol-name win-y)))) + ,@body))) + +(defmacro on-mousewheel + ((&optional (target 'target) (horiz 'horiz) (vert 'vert) (dir 'dir)) &body body) + "Creates a handler for MOUSEWHEEL events" + `(make-instance + 'event-handler + :event-type 'wheelwork::mousewheel + :handler-function (lambda + (,(intern (symbol-name target)) + ,(intern (symbol-name horiz)) + ,(intern (symbol-name vert)) + ,(intern (symbol-name dir))) + (declare + (ignorable ,(intern (symbol-name target)) + ,(intern (symbol-name horiz)) + ,(intern (symbol-name vert)) + ,(intern (symbol-name dir)))) + ,@body))) + +(defmacro on-blur + ((&optional (target 'target)) &body body) + "Creates a handler for BLUR events. BLUR is a psuedo event that +fires whenever an object loses focus." + `(make-instance + 'event-handler + :event-type 'wheelwork::blur + :handler-function (lambda + (,(intern (symbol-name target))) + (declare + (ignorable ,(intern (symbol-name target)))) + ,@body))) + +(defmacro on-focus + ((&optional (target 'target)) &body body) + "Creates a handler for a FOCUS event. FOCUS is a pusedo event that +fires when the FOCUS slot of the current APPLICATION instance is changed. +" + `(make-instance + 'event-handler + :event-type 'wheelwork::focus + :handler-function (lambda + (,(intern (symbol-name target))) + (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))) diff --git a/src/events/listener-and-interactive.lisp b/src/events/listener-and-interactive.lisp new file mode 100644 index 0000000..fdfe7b3 --- /dev/null +++ b/src/events/listener-and-interactive.lisp @@ -0,0 +1,108 @@ +;;;; listener.lisp + +(in-package #:wheelwork) + +(defclass/std listener () + ((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 + mouseup-table + mousemotion-table + mousewheel-table + 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.")) + (:documentation "Event handlers per object. The static hash tables + are keyed by UNIT and hold Event-Handler instances.")) + +(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)) + (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 should-listen-for-p (event-type &optional (app *application*)) + (plusp (hash-table-count (listener-table-for (listener app) event-type)))) + +(defclass/std interactive () + ((listener :type (or null listener) :std nil :a) + (focusablep :std t :doc "Whether or not this object can receive application focus.")) + (:documentation "Supplies an object with a listener slot.")) + +(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 + (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. 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) + (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)))))) + + +(defmethod drop-unit :before ((unit interactive)) + (when (unit-container 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 (handlers (get-handlers-for unit 'before-added)) + (dolist (handler handlers) + (funcall handler container unit)))) + +(defmethod add-unit :after ((container container) (unit interactive)) + (when-let (handlers (get-handlers-for unit 'after-added)) + (dolist (handler handlers) + (funcall handler container unit)))) diff --git a/src/events/listener.lisp b/src/events/listener.lisp new file mode 100644 index 0000000..2876c40 --- /dev/null +++ b/src/events/listener.lisp @@ -0,0 +1,4 @@ +;;;; listener.lisp + +(in-package #:wheelwork) + |