path: root/wheelwork.lisp

;;;; wheelwork.lisp

(in-package #:wheelwork)

(defvar *application* nil
  "current 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
    :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)
   (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)
    (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))

(defmethod cleanup ((app application))
  (loop for asset being the hash-value of (application-assets app)
        do (cleanup asset))
  (call-next-method))

(defmethod cleanup ((container container))
  (dolist (u (container-units container))
    (cleanup u)))

(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)) 
          (unwind-protect
               (progn 
                 (boot app)
                 (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 (container-units app))
    (render thing))
  (sdl2:gl-swap-window (application-window app)))

(defun eventloop (app)
  (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."))

(defclass/std asset ()
  ((path :with :ri :std (error "An asset requires a path"))
   (loadedp :with :a)))

(defmethod cleanup :around ((asset asset))
  (when (asset-loadedp asset)
    (call-next-method))
  (setf (asset-loadedp asset) nil))

(defmethod ensure-loaded :around ((thing asset))
  (unless (asset-loadedp thing) 
    (call-next-method)
    (setf (asset-loadedp thing) t))
  thing) 

(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 cleanup ((texture texture))
  (gl:delete-texture (texture-id texture)))

(defmethod ensure-loaded ((texture texture))
  (with-slots
        (width height id wrap-s wrap-t min-filter mag-filter internal-format image-format)
      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 id)
      (gl:tex-parameter :texture-2d :texture-wrap-s wrap-s)
      (gl:tex-parameter :texture-2d :texture-wrap-t wrap-t)
      (gl:tex-parameter :texture-2d :texture-min-filter min-filter)
      (gl:tex-parameter :texture-2d :texture-min-filter mag-filter)
      (gl:tex-image-2d :texture-2d
                       0
                       internal-format
                       width
                       height
                       0
                       image-format
                       :unsigned-byte
                       (pngload:data png)))))

(defclass/std bitmap (unit)
  ((texture :ri :std (error "A bitmap requires a texture."))
   (vao shader :with :r :static)))

(defmethod cleanup ((bitmap bitmap))
  (with-slots (vao shader) bitmap
    (when vao
      (gl:delete-vertex-arrays (list vao)))
    (when shader
      (gl:delete-program shader))
    (setf vao nil
          shader nil)))

(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 (mat:m* (application-projection *application*) (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)
;;       (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))


;; (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."))