[add] start function and event loop

2 files changed, 140 insertions, 1 deletions

diff --git a/wheelwork.asd b/wheelwork.asd
index e9f5629..582c9ab 100644
--- a/wheelwork.asd
+++ b/wheelwork.asd
@@ -12,6 +12,8 @@
                #:defclass-std
                #:3d-vectors
                #:3d-matrices
-               #:hyperquirks)
+               #:hyperquirks
+               #:pngload
+               #:closer-mop)
   :components ((:file "package")
                (:file "wheelwork")))
diff --git a/wheelwork.lisp b/wheelwork.lisp
index e7c3546..23b328a 100644
--- a/wheelwork.lisp
+++ b/wheelwork.lisp
@@ -1,3 +1,140 @@
 ;;;; wheelwork.lisp
 
 (in-package #:wheelwork)
+
+(defvar *application* nil
+  "current application")
+
+(defclass/std application ()
+  ((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 :a :std 1.0)
+   (width height :with :std 800)
+   (projection :with :a :doc "The projection matrix for the scene. Orthographic by default.")
+   (window :with :a)
+   (display-root :doc "A list of objects to display, the root of a tree")
+   (refocus-on-mousedown-p :std t)
+   (focus last-motion-target :with :a)
+   (frame-wait :std (/ 1000 30) :doc "Frames Per Second" :a)))
+
+(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)q
+    (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))
+
+(defmethod (setf closer-mop:slot-value-using-class) :after
+    (new-value class (app application) slot)
+  (when (member (closer-mop:slot-definition-name slot)
+                '(scale width height))
+    (set-projection app)))
+
+
+(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 cleanup (thing)
+  (:documentation "Clean up applications, textures, and so on.")
+  (:method ((any t)) nil))
+
+(defun start (app &key (x :centered) (y :centered))
+  (sdl2:with-init (:everything)
+    (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))
+        (let ((*application* app)) 
+          (boot app)
+          (eventloop app)
+          (cleanup app))))))
+
+(defun eventloop (app)
+  (sdl2:with-event-loop (:method :poll)
+    (:quit () t)))
+
+
+
+;; (defun get-focus (&optional (app *application*))
+;;   (or (application-focus app)
+;;       (display-root app)))
+
+;; (defun get-projection (&optional (app *application*))
+;;   (application-projection app))
+
+;; (defun application-width (&optional (app *application*))
+;;   (multiple-value-bind (w h) (sdl2:get-window-size (application-window app))
+;;     (declare (ignore h))
+;;     w))
+
+;; (defun application-height (&optional (app *application*))
+;;   (multiple-value-bind (w h) (sdl2:get-window-size (application-window app))
+;;     (declare (ignore w))
+;;     h))
+
+;; (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))
+;;             (initialize
+;;              (make-instance (asset-class-for asset-id)
+;;                             :path (uiop:merge-pathnames* asset-id (asset-root app)))))))
+
+;; (defclass/std event-handler ()
+;;   ((event-type handler-function :ri)))
+
+;; (defclass/std listener ()
+;;   ((keydown keyup mousedown mouseup mousemove mousewheel focus blur perframe
+;;             :r :with :type event-handler)
+;;    (keydown-table
+;;     keyup-table
+;;     mousedown-table
+;;     mouseup-table
+;;     mousemove-table
+;;     mousewheel-table
+;;     focus-table
+;;     blur-table
+;;     perframe-table
+;;     :static
+;;     :std (make-hash-table)
+;;     :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 display-unit ()
+;;   ((x y width height rotation :a :with :std 0.0 :type float :doc "Geometric properties")
+;;    (cached-model cached-real-model container listener :a :doc "Internal use.")
+;;    (focusablep :doc "T indicates it cannot be made the object of focus.")
+;;    (opacity :std 1.0 :doc "0.0 indicates it will not be rendred.")))
+