aboutsummaryrefslogtreecommitdiffhomepage
path: root/src/events/event-handler.lisp
diff options
context:
space:
mode:
Diffstat (limited to 'src/events/event-handler.lisp')
-rw-r--r--src/events/event-handler.lisp260
1 files changed, 260 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)))
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 09:22:28 +0000