;;;; event-handler.lisp (in-package #:wheelwork) (defclass/std event-handler () ((event-type handler-function tag :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))))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun get-tag-from-handler-body (body) (when (eq (first body) :tag) (second body))) (defun get-body-from-handler-body (body) (if (get-tag-from-handler-body body) (nthcdr 2 body) body))) (defmacro on-perframe ((&optional (target 'target) (time 'time)) &body body) "Creates a handler for 'PERFRAME events. All variable arguments supplied to this handler form are optional. You may supply your own variables to use in your BODY or you may just refer to the defaults - they will be interned in the appropriate package. TARGET - the object currently handling the event TIME - The current time in milliseconds " `(make-instance 'event-handler :tag ,(get-tag-from-handler-body body) :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))))) ,@(get-body-from-handler-body 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. All variable arguments supplied to this handler form are optional. You may supply your own variables to use in your BODY or you may just refer to the defaults - they will be interned in the appropriate package. 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 :tag ,(get-tag-from-handler-body body) :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)))) ,@(get-body-from-handler-body 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. All variable arguments supplied to this handler form are optional. You may supply your own variables to use in your BODY or you may just refer to the defaults - they will be interned in the appropriate package. 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 :tag ,(get-tag-from-handler-body body) :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)))) ,@(get-body-from-handler-body 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) "ON-MOUSEMOTION defines a mouse motion event handler. All variable arguments supplied to this handler form are optional. You may supply your own variables to use in your BODY or you may just refer to the defaults - they will be interned in the appropriate package. - TARGET is the object ontowhich the handler was installed - X and Y are the scaled screen coordinates - XREL and YREL are the relative motion of the X and Y positions since the last event, in scaled coordinates - STATE is the button state, see the SDL2 docs - WIN-* variables are the unscaled event values, if you require them. " `(make-instance 'event-handler :tag ,(get-tag-from-handler-body body) :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)))) ,@(get-body-from-handler-body 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. All variable arguments supplied to this handler form are optional. You may supply your own variables to use in your BODY or you may just refer to the defaults - they will be interned in the appropriate package. - TARGET is the object ontowhich the handler was installed - X and Y are the scaled screen coordinates - BUTTON is a code for the mouse button pressed (see sdl docs) - CLICKS is the number of clicks 1 for single, 2 for double. - WIN-* variables are the unscaled event values, if you require them. " `(make-instance 'event-handler :tag ,(get-tag-from-handler-body body) :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)))) ,@(get-body-from-handler-body 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 All variable arguments supplied to this handler form are optional. You may supply your own variables to use in your BODY or you may just refer to the defaults - they will be interned in the appropriate package. - TARGET is the object ontowhich the handler was installed - X and Y are the scaled screen coordinates - BUTTON is a code for the mouse button pressed (see sdl docs) - CLICKS is the number of clicks 1 for single, 2 for double. - WIN-* variables are the unscaled event values, if you require them. " `(make-instance 'event-handler :tag ,(get-tag-from-handler-body body) :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)))) ,@(get-body-from-handler-body body)))) (defmacro on-mousewheel ((&optional (target 'target) (horiz 'horiz) (vert 'vert) (dir 'dir)) &body body) "Creates a handler for MOUSEWHEEL events All variable arguments supplied to this handler form are optional. You may supply your own variables to use in your BODY or you may just refer to the defaults - they will be interned in the appropriate package. - TARGET is the object ontowhich the handler was installed - HORIZ, VERT are 1 or -1 - DIR is normal or flipped, see https://wiki.libsdl.org/SDL_MouseWheelEvent " `(make-instance 'event-handler :tag ,(get-tag-from-handler-body body) :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)))) ,@(get-body-from-handler-body 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. All variable arguments supplied to this handler form are optional. You may supply your own variables to use in your BODY or you may just refer to the defaults - they will be interned in the appropriate package. " `(make-instance 'event-handler :tag ,(get-tag-from-handler-body body) :event-type 'wheelwork::blur :handler-function (lambda (,(intern (symbol-name target))) (declare (ignorable ,(intern (symbol-name target)))) ,@(get-body-from-handler-body 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. All variable arguments supplied to this handler form are optional. You may supply your own variables to use in your BODY or you may just refer to the defaults - they will be interned in the appropriate package. " `(make-instance 'event-handler :tag ,(get-tag-from-handler-body body) :event-type 'wheelwork::focus :handler-function (lambda (,(intern (symbol-name target))) (declare (ignorable ,(intern (symbol-name target)))) ,@(get-body-from-handler-body body))))