;;;; 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
    "ON-MOUSEMOTION defines a mouse motion event handler.  All
variable arguments supplied the the ON-MOUSEDOWN 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.
"
    ((&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)))