1 files changed, 108 insertions, 0 deletions
diff --git a/src/application.lisp b/src/application.lisp
new file mode 100644
index 0000000..5d8135e
--- /dev/null
+++ b/src/application.lisp
@@ -0,0 +1,108 @@
+;;;; application
+
+(in-package #:wheelwork)
+
+(defvar *application* nil
+  "current application")
+
+(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-handlers (and thing (get-handlers-for thing 'blur)))
+    (dolist (handler blur-handlers) 
+      (funcall handler thing))))
+
+(defun fire-focus-event-on (thing)
+  (when-let (focus-handlers (and thing (get-handlers-for thing 'focus)))
+    (dolist (handler focus-handlers)
+      (funcall 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)))))
+
+(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))
+
+(defun run-perframe (app)
+  "Runs all of the handlers objects listening for perframe events, if
+those objects are currently part of the scene tree."
+  (let ((table (perframe-table (listener app)))
+        (time (get-universal-time)))
+    (loop for target being the hash-key of table
+          for handlers = (slot-value (listener target) 'perframe)
+          ;; only fire perframe when target is in scene
+          when (or (eq app target) (unit-container target)) 
+            do (loop for handler in handlers do (funcall handler target time)))))
+
+(defmethod render ((app application))
+  (run-perframe app)
+  (gl:clear-color 0.0 0.0 0.0 1.0)
+  ;(gl:clear :depth-buffer-bit :color-buffer-bit)
+  (gl:clear :color-buffer-bit)
+  (gl:enable :blend)
+  (gl:blend-func :src-alpha :one-minus-src-alpha )
+  (dolist (thing (container-units app))
+    (render thing))
+  (sdl2:gl-swap-window (application-window app))
+  (sleep (frame-wait app)))