[add] example; [add] basic stuff to run example

1 files changed, 256 insertions, 28 deletions

diff --git a/wheelwork.lisp b/wheelwork.lisp
index 23b328a..799f28c 100644
--- a/wheelwork.lisp
+++ b/wheelwork.lisp
@@ -5,7 +5,42 @@
 (defvar *application* nil
   "current application")
 
-(defclass/std application ()
+(defclass/std unit ()
+  ((cached-model :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)
+  (when (member (closer-mop:slot-definition-name slot)
+                '(scale-y scale-x rotation tx ty))
+    (setf (cached-model 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"))
+
+(defun add-unit (container 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)
+    (remove-unit unit))
+  (setf (container-units container)
+        (nconc (container-units container)
+               (list unit)))
+  unit)
+
+(defun remove-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 units)))
+     (unit-container unit) nil)
+    t))
+          
+(defclass/std application (container)
   ((title :with :std "Wheelwork App")
    (asset-root :ri :std #P"./" :doc "Directory under which assets are stored.")
    (asset-classifiers
@@ -17,7 +52,6 @@
    (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)))
@@ -42,7 +76,6 @@
                 '(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
@@ -70,11 +103,229 @@
           (eventloop 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))
+  (gl:clear-color 0.0 0.0 0.0 1.0)
+  (gl:clear :depth-buffer-bit :color-buffer-bit)
+  (dolist (thing (display-root app))
+    (render thing))
+  (sdl2:gl-swap-window (application-window app)))
+
 (defun eventloop (app)
-  (sdl2:with-event-loop (:method :poll)
-    (:quit () t)))
+  (let ((next-frame-time
+          (get-universal-time))
+        (*frame-time*
+          (get-universal-time))) 
+    (sdl2:with-event-loop (:method :poll)
+      (:idle ()
+             (when (<= next-frame-time (setf *frame-time* (get-universal-time)))
+               (setf next-frame-time (+ *frame-time* (frame-wait app)))
+               (render app)))
+      (:quit () t))))
+
+(defgeneric translate-by (thing dx dy))
+(defgeneric rotate-by (thing radians))
+(defgeneric scale-by (thing sx sy))
+(defgeneric pixel-width (thing))
+(defgeneric (setf pixel-width) (newval thing))
+(defgeneric pixel-height (thing))
+(defgeneric (setf pixel-height) (newval thing))
+
+(defgeneric visible-pixel-at-p (object x y)
+  (:documentation "returns T if the visible pixel at screen
+  coordintaes x and y belogns to object. Used for event handling."))
+
+(defgeneric model-matrix (thing)
+  (:documentation "Returns the model 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))))
+
+(defgeneric ensure-loaded (asset)
+  (:documentation "Ensures that the asset is loaded into memory and ready for use. Returns the asset."))
+
+(defmethod ensure-loaded :around ((thing asset))
+  (unless (asset-loadedp thing) 
+    (call-next-method)
+    (setf (asset-loadedp thing) t)
+    thing))
 
+(defclass/std asset ()
+  ((path :with :ri :std (error "An asset requires a path"))
+   (loadedp :with :a)))
 
+(defclass/std texture (asset)
+  ((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 ensure-loaded ((texture texture))
+  (with-slots (width height id) texture 
+    (pngload:with-png-in-static-vector (png (asset-path texture) :flip-y t)
+      (setf width (pngload:width png)
+            height (pngload:height png)
+            id (gl:gen-texture))
+      (gl:bind-texture :texture-2d (texture-id texture))
+      (gl:tex-parameter :texture-2d :texture-wrap-s (texture-wrap-s texture))
+      (gl:tex-parameter :texture-2d :texture-wrap-t (texture-wrap-t texture))
+      (gl:tex-parameter :texture-2d :texture-min-filter (texture-min-filter texture))
+      (gl:tex-parameter :texture-2d :texture-min-filter (texture-mag-filter texture))
+      (gl:tex-image-2d :texture-2d
+                       0
+                       (texture-internal-format texture)
+                       (texture-width texture)
+                       (texture-height texture)
+                       0
+                       (texture-image-format texture)
+                       :unsigned-byte
+                       (pngload:data png)))))
+
+(defclass/std bitmap (unit)
+  ((texture :ri :std (error "A bitmap requires a texture."))
+   (vao shader :with :r :static)))
+
+(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 texture (ensure-loaded texture)
+          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))
+               ((vari:texture tex tc)))))
+      (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")
+     (mat:marr (model-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 &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))
+            (ensure-loaded
+             (make-instance (asset-class-for asset-id)
+                            :path (uiop:merge-pathnames* asset-id (asset-root app)))))))
 
 ;; (defun get-focus (&optional (app *application*))
 ;;   (or (application-focus app)
@@ -93,23 +344,6 @@
 ;;     (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)))
@@ -132,9 +366,3 @@
 ;;   (: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.")))
-