98 lines
4.4 KiB
Common Lisp
98 lines
4.4 KiB
Common Lisp
;;;; wh-engine/render/resources.lisp
|
|
;;;; shader & texture resource management
|
|
(in-package wh-engine/render)
|
|
|
|
(defclass texture ()
|
|
((texture :documentation "The OpenGL texture ID."
|
|
:type fixnum
|
|
:initarg :texture
|
|
:reader texture)
|
|
(path :documentation "The path to the file this texture was loaded from."
|
|
:type (or string null)
|
|
:initarg :path
|
|
:reader path)
|
|
(alphap :documentation "Whether or not this texture has an alpha channel."
|
|
:type boolean
|
|
:initarg :alphap
|
|
:reader alphap)
|
|
(wrap-mode :documentation "The wrap mode for this texture."
|
|
:type keyword
|
|
:initarg :wrap-mode
|
|
:accessor wrap-mode)
|
|
(filterp :documentation "Whether or not this texture has filtering enabled."
|
|
:type boolean
|
|
:initarg :filterp
|
|
:accessor filterp))
|
|
(:documentation "A class representing a texture."))
|
|
|
|
(defmethod make-load-form ((this texture) &optional environment)
|
|
`(fetch-texture ,#[this path] :alphap ,#[this alphap] :wrap-mode ,#[this wrap-mode] :filterp ,#[this filterp]))
|
|
|
|
(defmethod (setf wrap-mode) (new-val (texture texture))
|
|
(setf #[texture :slot wrap-mode] new-val)
|
|
(let ((old (gl:get-integer :texture-binding-2d)))
|
|
(unwind-protect
|
|
(progn (gl:bind-texture :texture-2d #[texture texture])
|
|
(gl:tex-parameter :texture-2d :texture-wrap-s new-val)
|
|
(gl:tex-parameter :texture-2d :texture-wrap-t new-val))
|
|
(gl:bind-texture :texture-2d old))))
|
|
|
|
(defmethod (setf filterp) (new-val (texture texture))
|
|
(setf #[texture :slot filterp] new-val)
|
|
(let ((old (gl:get-integer :texture-binding-2d)))
|
|
(unwind-protect
|
|
(progn (gl:bind-texture :texture-2d #[texture texture])
|
|
(gl:tex-parameter :texture-2d :texture-min-filter (if new-val :linear :nearest))
|
|
(gl:tex-parameter :texture-2d :texture-mag-filter (if new-val :linear :nearest)))
|
|
(gl:bind-texture :texture-2d old))))
|
|
|
|
(defvar *fallback-texdata* nil)
|
|
(defun load-image-gracefully (path)
|
|
"Return an SDL surface for the given image file, or a fallback magenta-and-black checkerboard."
|
|
(declare (type (or string pathname) path))
|
|
(unless *fallback-texdata*
|
|
(setf *fallback-texdata* (cffi:foreign-alloc :uint32 :count 4))
|
|
(setf (cffi:mem-aref *fallback-texdata* :uint32 0) #xFF00FFFF
|
|
(cffi:mem-aref *fallback-texdata* :uint32 1) #x000000FF
|
|
(cffi:mem-aref *fallback-texdata* :uint32 2) #x000000FF
|
|
(cffi:mem-aref *fallback-texdata* :uint32 3) #xFF00FFFF))
|
|
(handler-case (sdl2-image:load-image path)
|
|
(sdl2-image:sdl-image-error (c)
|
|
(warn "Failed to load image: ~S~%" path)
|
|
(sdl2:create-rgb-surface-with-format-from *fallback-texdata* 2 2 32 8 :format sdl2:+pixelformat-rgba8888+))))
|
|
|
|
(defun make-texture (path &key (alphap t) (wrap-mode :repeat) (filterp nil))
|
|
"Create a texture instance from a file."
|
|
(declare (type (or string pathname) path)
|
|
(type boolean alphap filterp)
|
|
(type keyword wrap-mode))
|
|
(let* ((raw-surf (load-image-gracefully path))
|
|
(surf (sdl2:convert-surface-format raw-surf (if alphap :abgr8888 :bgr888)))
|
|
(texture (gl:gen-texture)))
|
|
(sdl2:free-surface raw-surf)
|
|
(gl:bind-texture :texture-2d texture)
|
|
(gl:tex-image-2d :texture-2d 0 (if alphap :rgba8 :rgb8)
|
|
(sdl2:surface-width surf) (sdl2:surface-height surf)
|
|
0 (if alphap :rgba :rgb) :unsigned-byte
|
|
(sdl2:surface-pixels surf))
|
|
(gl:tex-parameter :texture-2d :texture-wrap-s wrap-mode)
|
|
(gl:tex-parameter :texture-2d :texture-wrap-t wrap-mode)
|
|
(gl:tex-parameter :texture-2d :texture-min-filter (if filterp :linear :nearest))
|
|
(gl:tex-parameter :texture-2d :texture-mag-filter (if filterp :linear :nearest))
|
|
(gl:bind-texture :texture-2d 0)
|
|
(sdl2:free-surface surf)
|
|
(make-instance 'texture
|
|
:texture texture
|
|
:path path
|
|
:alphap alphap
|
|
:wrap-mode wrap-mode
|
|
:filterp filterp)))
|
|
|
|
(defvar *texture-registry* (make-hash-table :test #'equal))
|
|
(defun fetch-texture (path &rest make-args)
|
|
"Try to fetch the texture for PATH from the registry, or create it using MAKE-ARGS if it doesn't exist."
|
|
(declare (type (or string pathname) path))
|
|
(or (gethash path *texture-registry*)
|
|
(setf (gethash path *texture-registry*)
|
|
(apply #'make-texture path make-args))))
|