path: root/chickadee/graphics/texture.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2016, 2021 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(define-module (chickadee graphics texture)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-11)
  #:use-module (system foreign)
  #:use-module (chickadee math rect)
  #:use-module (chickadee graphics color)
  #:use-module ((chickadee graphics backend) #:prefix gpu:)
  #:use-module (chickadee graphics pixbuf)
  #:use-module (chickadee image)
  #:use-module (chickadee utils)
  #:export (make-texture
            destroy-texture
            texture?
            texture-destroyed?
            texture-1d?
            texture-2d?
            texture-3d?
            texture-destroyed?
            texture-name
            texture-width
            texture-height
            texture-depth
            texture-mip-levels
            texture-samples
            texture-dimension
            texture-format
            texture-view
            black-texture
            white-texture
            gray-texture
            flat-texture
            pixbuf->texture
            load-image

            make-texture-view
            destroy-texture-view
            texture-view?
            texture-view-1d?
            texture-view-2d?
            texture-view-2d-array?
            texture-view-3d?
            texture-view-cube?
            texture-view-cube-array?
            texture-view-destroyed?
            texture-view-texture
            texture-view-name
            texture-view-format
            texture-view-dimension
            texture-view-aspect
            texture-view-base-mip-level
            texture-view-mip-levels
            texture-view-base-layer
            texture-view-layers
            texture-view-width
            texture-view-height
            texture-view-depth

            make-sampler
            destroy-sampler
            sampler?
            sampler-destroyed?
            sampler-name
            sampler-address-mode-u
            sampler-address-mode-v
            sampler-address-mode-w
            sampler-mag-filter
            sampler-min-filter
            sampler-mipmap-filter))


;;;
;;; Textures
;;;

(define-record-type <texture>
  (%make-texture gpu handle name destroyed? width height depth mip-levels
                 samples dimension format)
  texture?
  (gpu texture-gpu)
  (handle texture-handle)
  (name texture-name)
  (destroyed? texture-destroyed? set-texture-destroyed!)
  (width texture-width)
  (height texture-height)
  (depth texture-depth)
  (mip-levels texture-mip-levels)
  (samples texture-samples)
  (dimension texture-dimension)
  (format texture-format)
  (view %texture-view set-texture-view!))

(define (print-texture texture port)
  (match texture
    (($ <texture> _ _ name _ width height depth _ _ dimension format*)
     (format #t "#<texture name: ~s width: ~s height: ~s depth: ~s dimension: ~s format: ~s>"
             name width height depth dimension format*))))

(set-record-type-printer! <texture> print-texture)

(define* (make-texture #:key
                       name
                       (width 1)
                       (height 1)
                       (depth 1)
                       (mip-levels 0)
                       (samples 1)
                       (dimension '2d)
                       (format 'rgba8))
  (let* ((gpu (gpu:current-gpu))
         (handle (gpu:make-texture gpu width height depth mip-levels
                                   samples dimension format)))
    (%make-texture gpu handle name #f width height depth mip-levels samples
                   dimension format)))

(define (destroy-texture texture)
  (unless (texture-destroyed? texture)
    (gpu:destroy-texture (texture-gpu texture) (texture-handle texture))
    (set-texture-destroyed! texture #t)))

(define (texture-1d? texture)
  "Return #t if TEXTURE is a one-dimensional texture."
  (eq? (texture-dimension texture) '1d))

(define (texture-2d? texture)
  "Return #t if TEXTURE is a two-dimensional texture."
  (eq? (texture-dimension texture) '2d))

(define (texture-3d? texture)
  "Return #t if TEXTURE is a three-dimensional texture."
  (eq? (texture-dimension texture) '3d))

;; TODO: This should be temporary???
(define (texture-view texture)
  (or (%texture-view texture)
      (let ((view (make-texture-view texture)))
        (set-texture-view! texture view)
        view)))

(define* (texture-write! texture data #:key
                         (x 0) (y 0) (z 0)
                         (width 0) (height 0) (depth 0)
                         (mip-level 0) (offset 0)
                         (format 'rgba8))
  (gpu:write-texture (texture-gpu texture) (texture-handle texture)
                     x y z width height depth mip-level format data offset))

(define (texture-copy-pixbuf! texture pixbuf)
  "Copy the contents of PIXBUF to TEXTURE."
  (texture-write! texture (pixbuf-pixels pixbuf)
                  #:width (pixbuf-width pixbuf)
                  #:height (pixbuf-height pixbuf)))

(define* (pixbuf->texture pixbuf #:key name)
  "Return a new 2D texture loaded with the contents of PIXBUF and the
debug name NAME."
  (let ((texture (make-texture #:name name
                               #:width (pixbuf-width pixbuf)
                               #:height (pixbuf-height pixbuf))))
    (texture-copy-pixbuf! texture pixbuf)
    texture))

(define (make-simple-texture name width height pixels)
  (pixbuf->texture (bytevector->pixbuf pixels width height)
                   #:name name))

(define-syntax-rule (define-simple-texture name name* width height pixels)
  (define name
    (let ((promise (delay (make-simple-texture name* width height pixels))))
      (define (name) (force promise))
      name)))

(define-simple-texture black-texture "Black texture" 2 2 (u32vector 0 0 0 0))

(define-simple-texture white-texture "White texture" 2 2
  (u32vector #xffffffff #xffffffff #xffffffff #xffffffff))

(define-simple-texture gray-texture "Gray texture" 2 2
  (u32vector #xff808080 #xff808080 #xff808080 #xff808080))

;; A "flat" normal map, in tangent space.  It's like the identity
;; property for normals. The colors are used to store 3D tangent space
;; vectors, with positive Z being "up".  Each coordinate is in the
;; [-1,1] range and then remapped to an 8-bit color channel in the
;; 0-255 range.  Thus, 0 maps to 127 or #x80, -1 maps to 0, and 1 maps
;; to 255.  A flat tangent normal is (0, 0, 1), which is encoded as
;; the color #xffff8080.  Such a value means that a mesh's vertex
;; normals remain completely unchanged by this normal map.
(define-simple-texture flat-texture "Flat texture" 2 2
  (u32vector #xffff8080 #xffff8080 #xffff8080 #xffff8080))

(define (%load-image image transparent-color flip?)
  (let ((pixbuf (read-image image)))
    (when flip?
      (pixbuf-flip-vertically! pixbuf))
    (when transparent-color
      (pixbuf-color-key! pixbuf transparent-color))
    pixbuf))

(define* (load-image image #:key
                     name
                     transparent-color
                     (flip? #t))
  "Load a texture from an image in IMAGE, which can be an image object
or a file name string."
  (let* ((image* (if (image? image) image (make-image image)))
         (pixbuf (%load-image image* transparent-color flip?)))
    (pixbuf->texture pixbuf #:name name)))


;;;
;;; Texture views
;;;

(define-record-type <texture-view>
  (%make-texture-view gpu handle name destroyed? texture format dimension
                      aspect base-mip-level mip-levels base-layer layers)
  texture-view?
  (gpu texture-view-gpu)
  (handle texture-view-handle)
  (name texture-view-name)
  (destroyed? texture-view-destroyed? set-texture-view-destroyed!)
  (texture texture-view-texture)
  (format texture-view-format)
  (dimension texture-view-dimension)
  (aspect texture-view-aspect)
  (base-mip-level texture-view-base-mip-level)
  (mip-levels texture-view-mip-levels)
  (base-layer texture-view-base-layer)
  (layers texture-view-layers))

(define (print-texture-view view port)
  (match view
    (($ <texture-view> _ _ name _ texture format* dimension aspect)
     (format port "#<texture-view name: ~s texture: ~s format: ~s dimension: ~s aspect: ~s>"
             name texture format* dimension aspect))))

(set-record-type-printer! <texture-view> print-texture-view)

(define* (make-texture-view texture #:key
                            name
                            (format (texture-format texture))
                            (dimension (texture-dimension texture))
                            (aspect 'all)
                            (base-mip-level 0)
                            (mip-levels (texture-mip-levels texture))
                            (base-layer 0)
                            (layers (match dimension
                                      ((or 'cube 'cube-array) 6)
                                      (_ 1))))
  (let* ((gpu (gpu:current-gpu))
         (handle (gpu:make-texture-view gpu (texture-handle texture) format
                                        dimension aspect
                                        base-mip-level mip-levels
                                        base-layer layers)))
    (%make-texture-view gpu handle name #f texture format dimension aspect
                        base-mip-level mip-levels base-layer layers)))

(define (destroy-texture-view view)
  (unless (texture-view-destroyed? view)
    (gpu:destroy-texture-view (texture-view-gpu view) (texture-view-handle view))
    (set-texture-view-destroyed! view #t)))

(define (texture-view-1d? view)
  "Return #t if TEXTURE-VIEW is a one-dimensional texture view."
  (eq? (texture-view-dimension view) '1d))

(define (texture-view-2d? view)
  "Return #t if TEXTURE-VIEW is a two-dimensional texture view."
  (eq? (texture-view-dimension view) '2d))

(define (texture-view-2d-array? view)
  "Return #t if TEXTURE-VIEW is a two-dimensional array texture view."
  (eq? (texture-view-dimension view) '2d-array))

(define (texture-view-3d? view)
  "Return #t if TEXTURE-VIEW is a three-dimensional texture view."
  (eq? (texture-view-dimension view) '3d))

(define (texture-view-cube? view)
  "Return #t if TEXTURE-VIEW is a cube texture view."
  (eq? (texture-view-dimension view) 'cube))

(define (texture-view-cube-array? view)
  "Return #t if TEXTURE-VIEW is a cube array texture view."
  (eq? (texture-view-dimension view) 'cube-array))

(define (texture-view-width view)
  (texture-width (texture-view-texture view)))

(define (texture-view-height view)
  (texture-height (texture-view-texture view)))

(define (texture-view-depth view)
  (texture-depth (texture-view-texture view)))


;;;
;;; Samplers
;;;

(define-record-type <sampler>
  (%make-sampler gpu handle name destroyed?
                 address-mode-u address-mode-v address-mode-w
                 mag-filter min-filter mipmap-filter)
  sampler?
  (gpu sampler-gpu)
  (handle sampler-handle)
  (name sampler-name)
  (destroyed? sampler-destroyed? set-sampler-destroyed!)
  (address-mode-u sampler-address-mode-u)
  (address-mode-v sampler-address-mode-v)
  (address-mode-w sampler-address-mode-w)
  (mag-filter sampler-mag-filter)
  (min-filter sampler-min-filter)
  (mipmap-filter sampler-mipmap-filter))

(define (print-sampler sampler port)
  (match sampler
    (($ <sampler> _ _ name _ u v w mag min mip)
     (format port
             "#<sampler name: ~s address-mode: (u: ~s v: ~s w: ~s) filter: (mag: ~s min: ~s: mipmap: ~s)>"
             name u v w mag min mip))))

(set-record-type-printer! <sampler> print-sampler)

(define* (make-sampler #:key name
                       (address-mode-u 'clamp-to-edge)
                       (address-mode-v 'clamp-to-edge)
                       (address-mode-w 'clamp-to-edge)
                       (mag-filter 'nearest)
                       (min-filter 'nearest)
                       (mipmap-filter 'nearest))
  (let* ((gpu (gpu:current-gpu))
         (handle (gpu:make-sampler gpu address-mode-u address-mode-v
                                   address-mode-w mag-filter min-filter
                                   mipmap-filter)))
    (%make-sampler gpu handle name #f
                   address-mode-u address-mode-v address-mode-w
                   mag-filter min-filter mipmap-filter)))

(define (destroy-sampler sampler)
  (unless (sampler-destroyed? sampler)
    (gpu:destroy-sampler (sampler-gpu sampler) (sampler-handle sampler))
    (set-sampler-destroyed! sampler #t)))

;; 
;; ;;;
;; ;;; Textures
;; ;;;

;; ;; The <texture> object is a simple wrapper around an OpenGL texture
;; ;; id.
;; (define-record-type <texture>
;;   (%make-texture id type parent min-filter mag-filter wrap-s wrap-t
;;                  x y width height gl-rect gl-tex-rect)
;;   texture?
;;   (id texture-id)
;;   (type texture-type)
;;   (parent texture-parent)
;;   (min-filter texture-min-filter)
;;   (mag-filter texture-mag-filter)
;;   (wrap-s texture-wrap-s)
;;   (wrap-t texture-wrap-t)
;;   (x texture-x)
;;   (y texture-y)
;;   (width texture-width)
;;   (height texture-height)
;;   (gl-rect texture-gl-rect)
;;   (gl-tex-rect texture-gl-tex-rect))

;; (set-record-type-printer! <texture>
;;   (lambda (texture port)
;;     (format port
;;             "#<texture id: ~d region?: ~a x: ~d y: ~d width: ~d height: ~d min-filter: ~a mag-filter: ~a wrap-s: ~a wrap-t: ~a>"
;;             (texture-id texture)
;;             (texture-region? texture)
;;             (texture-x texture)
;;             (texture-y texture)
;;             (texture-width texture)
;;             (texture-height texture)
;;             (texture-min-filter texture)
;;             (texture-mag-filter texture)
;;             (texture-wrap-s texture)
;;             (texture-wrap-t texture))))

;; (define null-texture
;;   (%make-texture 0 '2d #f 'linear 'linear 'repeat 'repeat 0 0 0 0
;;                  (make-rect 0.0 0.0 0.0 0.0) (make-rect 0.0 0.0 0.0 0.0)))

;; (define (texture-null? texture)
;;   "Return #t if TEXTURE is the null texture."
;;   (eq? texture null-texture))

;; (define (texture-region? texture)
;;   (texture? (texture-parent texture)))

;; (define (cube-map? texture)
;;   (and (texture? texture) (eq? (texture-type texture) 'cube-map)))

;; (define (free-texture texture)
;;   (gl-delete-texture (texture-id texture)))

;; (define (gl-texture-target type)
;;   (case type
;;     ((2d)
;;      (texture-target texture-2d))
;;     ((cube-map)
;;      (version-1-3 texture-cube-map))))

;; (define (make-bind-texture n)
;;   (lambda (texture)
;;     (let ((texture-unit (+ (version-1-3 texture0) n)))
;;       (set-gl-active-texture texture-unit)
;;       (gl-bind-texture (gl-texture-target (texture-type texture))
;;                        (texture-id texture)))))


;; (define* (make-texture width height #:key
;;                        pixels flip?
;;                        (min-filter 'nearest)
;;                        (mag-filter 'nearest)
;;                        (wrap-s 'repeat)
;;                        (wrap-t 'repeat)
;;                        (format 'rgba))
;;   "Return a new GPU texture of WIDTH x HEIGHT pixels in size.  PIXELS
;; may be a bytevector of WIDTH x HEIGHT pixels in 32-bit RGBA format, in
;; which case the texture will contain a copy of that data.  If PIXELS is
;; not provided, the texture data will not be initialized.  If FLIP? is
;; #t then the texture coordinates will be flipped vertically.  The
;; generated texture uses MIN-FILTER for downscaling and MAG-FILTER for
;; upscaling.  WRAP-S and WRAP-T are symbols that control how texture
;; access is handled for texture coordinates outside the [0, 1] range.
;; Allowed symbols are: repeat (the default), mirrored-repeat, clamp,
;; clamp-to-border, clamp-to-edge.  FORMAT specifies the pixel format.
;; Currently only 32-bit RGBA format is supported."
;;   (assert-current-graphics-engine)
;;   (let ((texture (%make-texture (gl-generate-texture) '2d #f
;;                                 min-filter mag-filter wrap-s wrap-t
;;                                 0 0 width height
;;                                 (make-rect 0.0 0.0 width height)
;;                                 (if flip?
;;                                     (make-rect 0.0 1.0 1.0 -1.0)
;;                                     (make-rect 0.0 0.0 1.0 1.0)))))
;;     (graphics-engine-guard! texture)
;;     (with-graphics-state! ((g:texture-0 texture))
;;       ;; Ensure that we are using texture unit 0 because
;;       ;; with-graphics-state! doesn't guarantee it.
;;       (set-gl-active-texture (version-1-3 texture0))
;;       (gl-texture-parameter (texture-target texture-2d)
;;                             (texture-parameter-name texture-min-filter)
;;                             (gl-min-filter min-filter))
;;       (gl-texture-parameter (texture-target texture-2d)
;;                             (texture-parameter-name texture-mag-filter)
;;                             (gl-mag-filter mag-filter))
;;       (gl-texture-parameter (texture-target texture-2d)
;;                             (texture-parameter-name texture-wrap-s)
;;                             (gl-wrap-mode wrap-s))
;;       (gl-texture-parameter (texture-target texture-2d)
;;                             (texture-parameter-name texture-wrap-t)
;;                             (gl-wrap-mode wrap-t))
;;       (gl-texture-image-2d (texture-target texture-2d)
;;                            0 (pixel-format rgba) width height 0
;;                            (gl-pixel-format format)
;;                            (color-pointer-type unsigned-byte)
;;                            (or pixels %null-pointer))
;;       ;; Generate mipmaps, if needed.
;;       (when (memq min-filter
;;                   '(nearest-mipmap-nearest
;;                     linear-mipmap-nearest
;;                     nearest-mipmap-linear
;;                     linear-mipmap-linear))
;;         (gl-generate-mipmap (texture-target texture-2d))))
;;     texture))

;; (define* (make-cube-map #:key
;;                         right left top bottom front back
;;                         (min-filter 'linear)
;;                         (mag-filter 'linear)
;;                         (format 'rgba))
;;   (define (set-face name pixbuf)
;;     (gl-texture-image-2d (case name
;;                            ((right)
;;                             (version-1-3 texture-cube-map-positive-x))
;;                           ((left)
;;                             (version-1-3 texture-cube-map-negative-x))
;;                            ((top)
;;                             (version-1-3 texture-cube-map-positive-y))
;;                            ((bottom)
;;                             (version-1-3 texture-cube-map-negative-y))
;;                            ((front)
;;                             (version-1-3 texture-cube-map-positive-z))
;;                            ((back)
;;                             (version-1-3 texture-cube-map-negative-z)))
;;                          0
;;                          (pixel-format rgba)
;;                          (pixbuf-width pixbuf)
;;                          (pixbuf-height pixbuf)
;;                          0
;;                          (gl-pixel-format format)
;;                          (color-pointer-type unsigned-byte)
;;                          (pixbuf-pixels pixbuf)))
;;   (assert-current-graphics-engine)
;;   (let ((texture (%make-texture (gl-generate-texture) 'cube-map #f
;;                                 min-filter mag-filter
;;                                 'clamp-to-edge 'clamp-to-edge
;;                                 0 0 0 0 #f #f)))
;;     (graphics-engine-guard! texture)
;;     (with-graphics-state! ((g:texture-0 texture))
;;       ;; Ensure that we are using texture unit 0 because
;;       ;; with-graphics-state! doesn't guarantee it.
;;       (set-gl-active-texture (version-1-3 texture0))
;;       (gl-texture-parameter (gl-texture-target 'cube-map)
;;                             (texture-parameter-name texture-min-filter)
;;                             (gl-min-filter min-filter))
;;       (gl-texture-parameter (gl-texture-target 'cube-map)
;;                             (texture-parameter-name texture-mag-filter)
;;                             (gl-mag-filter mag-filter))
;;       (gl-texture-parameter (gl-texture-target 'cube-map)
;;                             (texture-parameter-name texture-wrap-s)
;;                             (gl-wrap-mode 'clamp-to-edge))
;;       (gl-texture-parameter (gl-texture-target 'cube-map)
;;                             (texture-parameter-name texture-wrap-t)
;;                             (gl-wrap-mode 'clamp-to-edge))
;;       (gl-texture-parameter (gl-texture-target 'cube-map)
;;                             (texture-parameter-name texture-wrap-r-ext)
;;                             (gl-wrap-mode 'clamp-to-edge))
;;       (set-face 'right right)
;;       (set-face 'left left)
;;       (set-face 'top top)
;;       (set-face 'bottom bottom)
;;       (set-face 'front front)
;;       (set-face 'back back)
;;       ;; Generate mipmaps, if needed.
;;       (when (memq min-filter
;;                   '(nearest-mipmap-nearest
;;                     linear-mipmap-nearest
;;                     nearest-mipmap-linear
;;                     linear-mipmap-linear))
;;         (gl-generate-mipmap (gl-texture-target 'cube-map))))
;;     texture))

;; (define (make-texture-region texture rect)
;;   "Create a new texture region covering a section of TEXTURE defined
;; by the bounding box RECT."
;;   (let* ((pw (texture-width texture))
;;          (ph (texture-height texture))
;;          (x (rect-x rect))
;;          (y (rect-y rect))
;;          (w (rect-width rect))
;;          (h (rect-height rect))
;;          (vert-rect (make-rect 0.0 0.0 w h))
;;          (tex-rect (make-rect (/ x pw) (/ y ph) (/ w pw) (/ h ph))))
;;     (case (texture-type texture)
;;       ((2d)
;;        (%make-texture (texture-id texture)
;;                       '2d
;;                       texture
;;                       (texture-min-filter texture)
;;                       (texture-mag-filter texture)
;;                       (texture-wrap-s texture)
;;                       (texture-wrap-t texture)
;;                       x y w h
;;                       vert-rect
;;                       tex-rect))
;;       (else
;;        (error "regions can only be made from 2d textures")))))

;; (define* (load-cube-map #:key right left top bottom front back
;;                         (min-filter 'linear-mipmap-linear)
;;                         (mag-filter 'linear))
;;   (make-cube-map #:right (%load-image right #f #f)
;;                  #:left (%load-image left #f #f)
;;                  #:top (%load-image top #f #f)
;;                  #:bottom (%load-image bottom #f #f)
;;                  #:front (%load-image front #f #f)
;;                  #:back (%load-image back #f #f)
;;                  #:min-filter min-filter
;;                  #:mag-filter mag-filter))

;; (define (texture->pixbuf texture)
;;   "Return a new pixbuf with the contents of TEXTURE."
;;   (let* ((w (texture-width texture))
;;          (h (texture-height texture))
;;          (pixels (make-bytevector (* w h 4) 0)))
;;     (with-graphics-state! ((g:texture-0 texture))
;;       (gl-get-tex-image (texture-target texture-2d)
;;                         0
;;                         (gl-pixel-format 'rgba)
;;                         (color-pointer-type unsigned-byte)
;;                         (bytevector->pointer pixels)))
;;     (let ((pixbuf (bytevector->pixbuf pixels w h
;;                                       #:format 'rgba
;;                                       #:bit-depth 8)))
;;       (pixbuf-flip-vertically! pixbuf)
;;       pixbuf)))

;; (define* (write-texture texture
;;                         #:optional (file-name (temp-image-file-name 'png))
;;                         #:key (format 'png))
;;   "Write TEXTURE to FILE-NAME using FORMAT ('png' by default.)"
;;   (write-image (texture->pixbuf texture) file-name #:format format))