;;;; wheelwork.lisp

(in-package #:wheelwork)

(defvar *application* nil
  "current application")

(defclass/std unit ()
  ((cached-model cached-projected-matrix :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
           (cached-projected-matrix 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))
(defgeneric add-unit (container 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))

(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 add-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 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."
  (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" png) ("ttf" font))
    :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))

(defparameter +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 model-matrix (thing)
  (:documentation "Returns the model matrix"))

(defgeneric projected-matrix (thing)
  (:documentation "Returns the raw array of the model matrix after it
  has been prjected by the application's projecion 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))))

(defmethod projected-matrix ((thing unit))
  (or (cached-projected-matrix thing)
      (setf (cached-projected-matrix thing)
            (mat:marr (mat:m* (application-projection *application*)
                              (model-matrix thing))))))

(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 ()
  ((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)))

(defclass/std png (asset texture) ())

(defmethod ensure-loaded ((png png))
  (with-slots
        (width height id wrap-s wrap-t min-filter mag-filter internal-format image-format)
      png
    (pngload:with-png-in-static-vector (data (asset-path png) :flip-y t)
      (setf width (pngload:width data)
            height (pngload:height data)
            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 data))
      (gl:bind-texture :texture-2d 0)
      (when (texture-mipmap png)
        (gl:generate-mipmap :texture-2d)))))


(defun refocus-on (target &optional (app *application*))
  "Sets focus of application to TARGET. This works whether or not
TARGET is FOCUSABLEP"
  (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 (and (refocus-on-mousedown-p app) (focusablep target))
        (refocus-on target))              
      (when-let (handler (get-handler-for target 'mousedown))
        (funcall handler target x y clicks button wx wy)))))

(defun eventloop-mousebuttonup (app wx wy clicks button)
  (when (should-listen-for-p 'mouseup app)
    (destructuring-bind (x y) (screen-to-world wx wy)
      (when-let* ((target (or (unit-under app x y)
                              app))
                  (handler (get-handler-for target 'mouseup)))
        (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 (or (unit-under app x y)
                                app))
                    (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))
    (:mousebuttonup
     (:x x :y y :clicks clicks :button button)
     (eventloop-mousebuttonup app x y clicks button))
    (: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 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")
     (projected-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 &key (app *application*) asset-args)
  "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.

ASSET-ARGS is a plist to pass to make-instance for the given resource.
"
  (or (gethash asset-id (application-assets app))
      (setf (gethash asset-id (application-assets app))
            (ensure-loaded
             (apply 'make-instance
                    (asset-class-for asset-id)
                    :path (uiop:merge-pathnames* asset-id (asset-root app))
                    asset-args)))))

(define-symbol-macro +standard-font-chars+
  " ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz01234567890\".,!?-'"  )

(defclass/std font (asset)
  ((characters :i :std +standard-font-chars+)
   (oversample :i :doc "ovesampling factor to pass to cl-fond:make-font")
   (object :with :r :doc "The font as returned from cl-fond:make-font")))

(defmethod ensure-loaded ((font font))
  (with-slots (path characters oversample object) font
    (setf object (cl-fond:make-font path characters :oversample oversample))))


(defclass/std text (unit interactive)
  ((font :with :ri :std (error "A font is required") :type font)
   (content :with :ri :std "")
   (color :with :std #(1.0 1.0 1.0 1.0))
   (vao elem-count :r)
   (shader :with :static :r)))

(defmethod initialize-instance :after ((text text) &key)
  (with-slots (content font vao elem-count shader) text
    (unless shader
      (setf shader
            (create-shader
             '(:vertex
               ((vert :vec2) (col :vec2))
               ((transform :mat4))
               ((values
                 (* transform (vari:vec4 vert 0.0 1.0))
                 col)))
             '(:fragment
               ((tc :vec2))
               ((tex :sampler-2d)
                (color :vec4))
               ((* color (aref (vari:texture tex tc) 0)))))))
    (multiple-value-bind (vao% count%) (cl-fond:compute-text (font-object font) content)
      (setf vao vao%
            elem-count count%))))

(defmethod cleanup ((text text))
  (with-slots (vao shader) text
    (gl:delete-vertex-arrays (list vao))
    (when shader
      (gl:delete-program shader))
    (setf vao nil
          shader nil)))

(defmethod render ((text text))
  (with-slots (shader font vao elem-count color) text
    (gl:use-program shader)
    (gl:active-texture 0)
    (gl:bind-texture :texture-2d (cl-fond:texture (font-object font)))
    (gl:program-uniform-matrix-4fv
     shader
     (gl:get-uniform-location shader "TRANSFORM")
     (projected-matrix text))
    (gl:program-uniformi
     shader
     (gl:get-uniform-location shader "TEX")
     0)
    (gl:program-uniformfv
     shader
     (gl:get-uniform-location shader "COLOR")
     color)
    (gl:bind-vertex-array vao)
    (%gl:draw-elements :triangles elem-count :unsigned-int 0)
    (gl:bind-vertex-array 0)))




(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)))

;;; Utility

(define-symbol-macro +pi-over-180+ 0.017453292519943295d0)

(defun radians (degrees)
  "Converse DEGREES to radians"
  (* degrees +pi-over-180+))