diff options
Diffstat (limited to 'wheelwork.lisp')
| -rw-r--r-- | wheelwork.lisp | 72 |
1 files changed, 51 insertions, 21 deletions
diff --git a/wheelwork.lisp b/wheelwork.lisp index 799f28c..6ad9107 100644 --- a/wheelwork.lisp +++ b/wheelwork.lisp @@ -62,7 +62,7 @@ order). Makes sure to remove the unit from its current container if necessary." (slot-boundp app 'scale))) (defun set-projection (app) - (when (can-set-projection-p app)q + (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))))) @@ -86,6 +86,15 @@ order). Makes sure to remove the unit from its current container if necessary." (: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 @@ -99,9 +108,11 @@ order). Makes sure to remove the unit from its current container if necessary." (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)))))) + (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.") @@ -110,7 +121,7 @@ order). Makes sure to remove the unit from its current container if necessary." (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)) + (dolist (thing (container-units app)) (render thing)) (sdl2:gl-swap-window (application-window app))) @@ -158,40 +169,50 @@ order). Makes sure to remove the unit from its current container if necessary." (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))) +(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) 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 (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: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 - (texture-internal-format texture) - (texture-width texture) - (texture-height texture) + internal-format + width + height 0 - (texture-image-format texture) + image-format :unsigned-byte (pngload:data png))))) @@ -199,6 +220,15 @@ order). Makes sure to remove the unit from its current container if necessary." ((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) |