;;;; 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))))