;;;; wheelwork.lisp (in-package #:wheelwork) (defvar *application* nil "current application") (defclass/std unit () ((cached-model :a) (container :with :a) (width height :with :std 1.0) (rotation x y :with :std 0.0) (opacity :std 1.0 :doc "0.0 indicates it will not be rendred."))) (defmethod (setf closer-mop:slot-value-using-class) :after (newval class (unit unit) slot) (case (closer-mop:slot-definition-name slot) ((x y width height rotation ) (setf (cached-model unit) nil)))) (defclass/std container () ((units :with :a)) (:documentation "Just a list of units. Made into a class so that transformation affine transformations methods can be specialzied on whole groups of units")) (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 unit))) (unit-container unit) nil) t)) (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) (drop-unit unit)) (setf (container-units container) (nconc (container-units container) (list unit))) unit) (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))) (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.")) (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.")) (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)) (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 set-handler (interactive handler) (when (null (listener interactive)) (setf (listener interactive) (make-instance 'listener))) (setf (slot-value (listener interactive) (event-type handler)) handler (gethash interactive (listener-table-for (listener interactive) (event-type handler))) handler)) (defun unset-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." (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))))) (defun should-listen-for-p (event-type &optional (app *application*)) (plusp (hash-table-count (listener-table-for (listener app) event-type)))) (defclass/std application (container interactive) ((title :with :std "Wheelwork App") (asset-root :ri :std #P"./" :doc "Directory under which assets are stored.") (asset-classifiers :std '(("png" texture)) :doc "ALIST of (EXT CLASS). EXT is a string, file estension. CLASS is a symbol, class name.") (assets :with :a :std (make-hash-table :test 'equal) :doc "maps asset names to asset instances.") (scale :with :std 1.0) (width height :with :std 800) (projection :with :a :doc "The projection matrix for the scene. Orthographic by default.") (window :with :a) (refocus-on-mousedown-p :std t) (focus last-motion-target :with :a) (fps :with :std 30 :doc "Frames Per Second") (frame-wait :r))) (defun fps (&optional (app *application*)) (application-fps app)) (defun (setf fps) (new-val &optional (app *application*)) (setf (application-fps app) new-val)) (defun can-set-projection-p (app) (and (slot-boundp app 'width) (slot-boundp app 'height) (slot-boundp app 'scale))) (defun set-projection (app) (when (can-set-projection-p app) (with-slots (projection scale width height) app ;; set projection matrix (setf projection (mat:mortho 0.0 (/ width scale) 0 (/ height scale) -1.0 1.0))))) (defmethod initialize-instance :after ((app application) &key) (set-projection app) (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))) (defun fire-focus-event-on (thing) (when-let (focus-handler (and thing (get-handler-for thing 'focus))) (funcall focus-handler thing))) (defmethod (setf closer-mop:slot-value-using-class ) :before (new-value class (app application) slot) (case (closer-mop:slot-definition-name slot) (focus (when (slot-boundp app 'focus) (unless (eq new-value (slot-value app 'focus)) (fire-blur-event-on (slot-value app 'focus)) (fire-focus-event-on new-value)))))) (defmethod (setf closer-mop:slot-value-using-class) :after (new-value class (app application) slot) (case (closer-mop:slot-definition-name slot) ((scale width height) (set-projection app)) (fps (setf (slot-value app 'frame-wait) (/ 1.0 new-value))))) (defgeneric boot (app) (:documentation "Specialized for each subclass of APPLICATION. Responsble for setting the app up once the system resoruces are avaialble.") (:method ((app application)) nil)) (defgeneric shutdown (app) (:documentation "Specialzied for each subclass of APPLICATION. Called just before cleanup.") (:method ((app application)) nil)) (defgeneric cleanup (thing) (:documentation "Clean up applications, textures, and so on.") (:method ((any t)) nil)) (defconstant +listener-table-slot-names+ '(keydown-table keyup-table mousedown-table mouseup-table mousemotion-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) do (cleanup asset)) ;; drop all current handlers (let ((listener (listener app))) (dolist (table +listener-table-slot-names+) (setf (slot-value listener table) (make-hash-table :synchronized t)))) (call-next-method)) (defmethod cleanup ((container container)) (dolist (u (container-units container)) (cleanup u))) (defun start (app &key (x :centered) (y :centered)) (sdl2:with-init (:everything) (sdl2:gl-set-attr :context-major-version 3) (sdl2:gl-set-attr :context-minor-version 3) (sdl2:gl-set-attr :context-profile-mask sdl2-ffi:+sdl-gl-context-profile-core+) (sdl2:gl-set-attr :doublebuffer 1) (sdl2:with-window (window :flags '(:shown :opengl) :title (application-title app) :w (application-width app) :h (application-height app) :x x :y y) (setf (application-window app) window) (sdl2:with-gl-context (ctx window) (sdl2:gl-make-current window ctx) (gl:viewport 0 0 (application-width app) (application-height app)) (gl:enable :depth-test) (let ((*application* app)) (unwind-protect (progn (boot app) (eventloop app) (shutdown app)) (cleanup app))))))) (defvar *frame-time* nil "Bound and available once per frame. The result of GET-UNIVERSAL-TIME.") (defgeneric render (thing)) (defmethod render ((app application)) (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))) (gl:clear-color 0.0 0.0 0.0 1.0) (gl:clear :depth-buffer-bit :color-buffer-bit) (dolist (thing (container-units app)) (render thing)) (sdl2:gl-swap-window (application-window app)) (sleep (frame-wait app))) (defgeneric translate-by (thing dx dy)) (defgeneric rotate-by (thing radians)) (defgeneric scale-by (thing sx sy)) (defgeneric pixel-width (thing)) (defgeneric (setf pixel-width) (newval thing)) (defgeneric pixel-height (thing)) (defgeneric (setf pixel-height) (newval thing)) (defgeneric visible-pixel-at-p (object x y) (:documentation "returns T if the visible pixel at screen coordintaes x and y belogns to object. Used for event handling.")) (defgeneric model-matrix (thing) (:documentation "Returns the model matrix")) (defmethod model-matrix ((u unit)) (or (cached-model u) (setf (cached-model u) (let ((m (mat:meye 4))) (mat:nmtranslate m (vec:vec (unit-x u) (unit-y u) 0.0)) (mat:nmtranslate m (vec:v* 0.5 (vec:vec (unit-width u) (unit-height u) 0.0))) (mat:nmrotate m vec:+vz+ (unit-rotation u)) (mat:nmtranslate m (vec:v* -0.5 (vec:vec (unit-width u) (unit-height u) 0.0))) (mat:nmscale m (vec:vec (unit-width u) (unit-height u) 1.0)) m)))) (defgeneric ensure-loaded (asset) (:documentation "Ensures that the asset is loaded into memory and ready for use. Returns the asset.")) (defclass/std asset () ((path :with :ri :std (error "An asset requires a path")) (loadedp :with :a))) (defmethod cleanup :around ((asset asset)) (when (asset-loadedp asset) (call-next-method)) (setf (asset-loadedp asset) nil)) (defmethod ensure-loaded :around ((thing asset)) (unless (asset-loadedp thing) (call-next-method) (setf (asset-loadedp thing) t)) thing) (defclass/std texture (asset) ((width height id mipmap :with :r) (internal-format image-format :ri :with :std :rgba) (wrap-s wrap-t :ri :with :std :repeat) (min-filter mag-filter :ri :with :std :nearest))) (defmethod cleanup ((texture texture)) (gl:delete-texture (texture-id texture))) (defmethod ensure-loaded ((texture texture)) (with-slots (width height id wrap-s wrap-t min-filter mag-filter internal-format image-format) texture (pngload:with-png-in-static-vector (png (asset-path texture) :flip-y t) (setf width (pngload:width png) height (pngload:height png) id (gl:gen-texture)) (gl:bind-texture :texture-2d id) (gl:tex-parameter :texture-2d :texture-wrap-s wrap-s) (gl:tex-parameter :texture-2d :texture-wrap-t wrap-t) (gl:tex-parameter :texture-2d :texture-min-filter min-filter) (gl:tex-parameter :texture-2d :texture-mag-filter mag-filter) (gl:tex-image-2d :texture-2d 0 internal-format width height 0 image-format :unsigned-byte (pngload:data png)) (gl:bind-texture :texture-2d 0) (when (texture-mipmap texture) (gl:generate-mipmap :texture-2d))))) (defun refocus-on (target &optional (app *application*)) "Sets focus of application to TARGET, if TARGET is focusable. " (when (focusablep target) (setf (application-focus app) target))) (defun get-focus (&optional (app *application*)) (or (application-focus app) app)) (defun get-handler-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)))))) (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)))))) (defun contains-point-p (unit px py) (with-slots (x y width height) unit (and (<= x px (+ x width)) (<= y py (+ y height))))) (defun unit-under (app x y) (labels ((finder (thing) (etypecase thing (container (find-if #'finder (container-units thing) :from-end t)) (unit (when (contains-point-p thing x y) (return-from unit-under thing)))))) (finder app))) (defun screen-to-world (x y &optional (app *application*)) (with-slots (height scale) app (list (/ x scale) (/ (- height y) scale)))) (defun eventloop-mousebuttondown (app wx wy clicks button) "Searches for a handler to handle applies it if found. Additionally, if the APPLICATION's REFOCUS-ON-MOUSEDOWN-P is T, try to give focus to whatever was clicked." (destructuring-bind (x y) (screen-to-world wx wy) (let ((target (or (unit-under app x y) ; if no unit is under the mouse, app))) ; then target the app itself (when (refocus-on-mousedown-p app) (refocus-on target)) (when-let (handler (get-handler-for target 'mousedown)) (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) (destructuring-bind (x y) (screen-to-world wx wy) (destructuring-bind (xrel yrel) (screen-to-world wxrel wyrel) (when-let* ((target (unit-under app x y)) (handler (get-handler-for target 'mousemotion))) (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)))) (defun eventloop (app) (sdl2:with-event-loop (:method :poll) (:mousebuttondown (:x x :y y :clicks clicks :button button) (eventloop-mousebuttondown app x y clicks button)) (:mousemotion (:x x :y y :xrel xrel :yrel yrel :state state) (eventloop-mousemotion app x y xrel yrel state)) (:keydown (:keysym keysym) (eventloop-keydown app keysym)) (:keyup (:keysym keysym) (eventloop-keyup app keysym)) (:mousewheel (:x x :y y :direction dir) (eventloop-mousewheel app x y dir)) (:idle () (render app)) (:quit () t))) (defclass/std bitmap (unit interactive) ((texture :ri :std (error "A bitmap requires a texture.")) (vao shader :with :r :static))) (defmethod cleanup ((bitmap bitmap)) (with-slots (vao shader) bitmap (when vao (gl:delete-vertex-arrays (list vao))) (when shader (gl:delete-program shader)) (setf vao nil shader nil))) (defun shader-by-type (type) (case type (:vertex :vertex-shader) (:geometry :geometry-shader) (:fragment :fragment-shader))) (defun gl-shader (type stage) (let ((shader (gl:create-shader type))) (gl:shader-source shader (varjo:glsl-code stage)) (gl:compile-shader shader) (unless (gl:get-shader shader :compile-status) (error "failed to compile ~a shader:~%~a~%" type (gl:get-shader-info-log shader))) shader)) (defun create-shader (&rest sources) (let* ((stages (varjo:rolling-translate (mapcar (lambda (source) (destructuring-bind (type inputs uniforms code) source (varjo:make-stage type inputs uniforms '(:330) code))) sources))) (shaders (loop :for stage :in stages :for source :in sources :collect (gl-shader (shader-by-type (car source)) stage))) (program (gl:create-program))) (dolist (shader shaders) (gl:attach-shader program shader)) (gl:link-program program) (unless (gl:get-program program :link-status) (error "failed to link program: ~%~a~%" (gl:get-program-info-log program))) (dolist (shader shaders) (gl:detach-shader program shader) (gl:delete-shader shader)) program)) (defun gl-array (type &rest contents) (let ((array (gl:alloc-gl-array type (length contents)))) (dotimes (i (length contents) array) (setf (gl:glaref array i) (elt contents i))))) (defmacro with-gl-array ((var type &rest contents) &body body) `(let ((,var (gl-array ,type ,@contents))) (unwind-protect (progn ,@body) (gl:free-gl-array ,var)))) (define-symbol-macro +float-size+ (cffi:foreign-type-size :float)) (defmethod initialize-instance :after ((bitmap bitmap) &key) (with-slots (vao shader width height texture) bitmap (setf texture (ensure-loaded texture) height (texture-height texture) width (texture-width texture)) (unless shader (setf shader (create-shader '(:vertex ((vert :vec2)) ((transform :mat4)) ((values (* transform (vari:vec4 vert 0.0 1.0)) vert))) ;color '(:fragment ((tc :vec2)) ((tex :sampler-2d)) ((let ((frag (vari:texture tex tc))) (if (< (aref frag 3) 0.01) (vari:discard) frag)))))) (gl:program-uniformi shader (gl:get-uniform-location shader "TEX") 0)) (unless vao (setf vao (gl:gen-vertex-array)) (gl:bind-vertex-array vao) (let ((vbo (gl:gen-buffer))) (with-gl-array (verts :float 0.0 1.0 1.0 0.0 0.0 0.0 0.0 1.0 1.0 1.0 1.0 0.0 ) (gl:bind-buffer :array-buffer vbo) (gl:buffer-data :array-buffer :static-draw verts))) (gl:enable-vertex-attrib-array 0) (gl:vertex-attrib-pointer 0 2 :float 0 (* +float-size+ 2) 0) (gl:bind-buffer :array-buffer 0) (gl:bind-vertex-array 0)))) (defmethod render ((bitmap bitmap)) (with-slots (texture vao shader) bitmap (gl:active-texture 0) (gl:bind-texture :texture-2d (texture-id texture)) (gl:use-program shader) (gl:program-uniform-matrix-4fv shader (gl:get-uniform-location shader "TRANSFORM") (mat:marr (mat:m* (application-projection *application*) (model-matrix bitmap)))) (gl:bind-vertex-array vao) (gl:draw-arrays :triangles 0 6) (gl:bind-vertex-array 0))) (defun asset-class-for (asset-id &optional (app *application*)) "Given an asset-id (see GET-ASSET), retrieve the symbol name of a the class that will be used to instantiate the asset object. That class should be a subclass of ASSET. Additional clases can be added to the application's ASSET-CLASSIFIERS association list." (second (assoc (pathname-type asset-id) (asset-classifiers app) :test #'string-equal))) (defun get-asset (asset-id &optional (app *application*)) "ASSET-ID is a pathname namestring relative to the application's ASSET-ROOT. GET-ASSET retrieves an already-available asset from the application's ASSETS table, or, if not available, loads the asset from disk." (or (gethash asset-id (application-assets app)) (setf (gethash asset-id (application-assets app)) (ensure-loaded (make-instance (asset-class-for asset-id) :path (uiop:merge-pathnames* asset-id (asset-root app))))))) (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)))