[refactor] [structure] modularized project file structure

3 files changed, 372 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)))
diff --git a/src/events/listener-and-interactive.lisp b/src/events/listener-and-interactive.lisp
new file mode 100644
index 0000000..fdfe7b3
--- /dev/null
+++ b/src/events/listener-and-interactive.lisp
@@ -0,0 +1,108 @@
+;;;; listener.lisp
+
+(in-package #:wheelwork)
+
+(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."))
+
+(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 should-listen-for-p (event-type &optional (app *application*))
+  (plusp (hash-table-count (listener-table-for (listener app) event-type))))
+
+(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."))
+
+(defun add-handler (interactive handler)
+  (when (null (listener interactive))
+    (setf (listener interactive) (make-instance 'listener)))
+  (pushnew handler (slot-value (listener interactive) (event-type handler)) :test #'eq)
+  (setf
+   (gethash interactive (listener-table-for (listener interactive) (event-type handler)))
+   t))
+
+
+(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.  If is an event handler, only that
+  handler will be removed. If it is an event type, all events of that
+  type name are removed from the object."
+  (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)
+            (if (symbolp handler-or-event-type)
+                ;; remove everything if a symbol
+                nil
+                ;; delete just the handler
+                (delete handler-or-event-type
+                        (slot-value (listener interactive) event-type)
+                        :test #'eq)))
+      ;; remove from from the global table unless any listeners remain on this event
+      (unless (slot-value (listener interactive) event-type)
+        (remhash interactive (listener-table-for (listener interactive) event-type))))))
+
+
+(defmethod drop-unit :before ((unit interactive))
+  (when (unit-container unit) 
+    (when-let (handlers (get-handlers-for unit 'before-dropped))
+      (dolist (handler handlers) 
+        (funcall handler unit)))))
+
+(defmethod add-unit :before ((container container) (unit interactive))
+  (when-let (handlers (get-handlers-for unit 'before-added))
+    (dolist (handler handlers) 
+      (funcall handler container unit))))
+
+(defmethod add-unit :after ((container container) (unit interactive))
+  (when-let (handlers (get-handlers-for unit 'after-added))
+    (dolist (handler handlers) 
+      (funcall handler container unit))))
diff --git a/src/events/listener.lisp b/src/events/listener.lisp
new file mode 100644
index 0000000..2876c40
--- /dev/null
+++ b/src/events/listener.lisp
@@ -0,0 +1,4 @@
+;;;; listener.lisp
+
+(in-package #:wheelwork)
+