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 (gl)
  #:use-module ((gl enums) #:prefix gl:)
  #:use-module (chickadee math rect)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics engine)
  #:use-module (chickadee graphics gl)
  #:use-module (chickadee graphics pixbuf)
  #:use-module (chickadee image)
  #:use-module (chickadee utils)
  #:export (make-texture
            make-texture-region
            make-cube-map
            pixbuf->texture
            load-image
            load-cube-map
            texture-copy-pixbuf!
            texture->pixbuf
            write-texture
            texture?
            texture-region?
            cube-map?
            texture-null?
            texture-type
            texture-parent
            texture-min-filter
            texture-mag-filter
            texture-wrap-s
            texture-wrap-t
            texture-x
            texture-y
            texture-width
            texture-height
            texture-gl-rect
            texture-gl-tex-rect
            null-texture
            black-texture
            white-texture
            gray-texture
            flat-texture
            g:texture-0
            g:texture-1
            g:texture-2
            g:texture-3
            g:texture-4
            g:texture-5
            current-texture-0
            current-texture-1
            current-texture-2
            current-texture-3
            current-texture-4
            current-texture-5

            texture-atlas
            list->texture-atlas
            split-texture
            texture-tileset-dimensions
            texture-atlas?
            texture-atlas-size
            texture-atlas-texture
            texture-atlas-ref
            load-tileset))


;;;
;;; 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-graphics-finalizer texture-finalizer
  #:predicate texture?
  #:free free-texture)

(define-graphics-state g:texture-0
  current-texture-0
  #:default null-texture
  #:bind (make-bind-texture 0))

(define-graphics-state g:texture-1
  current-texture-1
  #:default null-texture
  #:bind (make-bind-texture 1))

(define-graphics-state g:texture-2
  current-texture-2
  #:default null-texture
  #:bind (make-bind-texture 2))

(define-graphics-state g:texture-3
  current-texture-3
  #:default null-texture
  #:bind (make-bind-texture 3))

(define-graphics-state g:texture-4
  current-texture-4
  #:default null-texture
  #:bind (make-bind-texture 4))

(define-graphics-state g:texture-5
  current-texture-5
  #:default null-texture
  #:bind (make-bind-texture 5))

(define (gl-wrap-mode mode)
  (case mode
    ((repeat)
     (texture-wrap-mode repeat))
    ('mirrored-repeat (version-1-4 mirrored-repeat))
    ((clamp)
     (texture-wrap-mode clamp))
    ((clamp-to-border)
     (texture-wrap-mode clamp-to-border-sgis))
    ((clamp-to-edge)
     (texture-wrap-mode clamp-to-edge-sgis))))

(define (gl-min-filter min-filter)
  (case min-filter
    ((nearest)
     (gl:texture-min-filter nearest))
    ((linear)
     (gl:texture-min-filter linear))
    ((nearest-mipmap-nearest)
     (gl:texture-min-filter nearest-mipmap-nearest))
    ((linear-mipmap-nearest)
     (gl:texture-min-filter linear-mipmap-nearest))
    ((nearest-mipmap-linear)
     (gl:texture-min-filter nearest-mipmap-linear))
    ((linear-mipmap-linear)
     (gl:texture-min-filter linear-mipmap-linear))))

(define (gl-mag-filter mag-filter)
  (case mag-filter
    ((nearest)
     (gl:texture-mag-filter nearest))
    ((linear)
     (gl:texture-mag-filter linear))))

(define (gl-pixel-format format)
  (case format
    ((rgba)
     (pixel-format rgba))))

(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* (pixbuf->texture pixbuf #:key
                          flip?
                          (min-filter 'nearest)
                          (mag-filter 'nearest)
                          (wrap-s 'repeat)
                          (wrap-t 'repeat)
                          (format 'rgba))
  "Translate PIXBUF into a texture stored on the GPU.  See
'make-texture' for documentation of all keyword arguments."
  (assert-current-graphics-engine)
  (let* ((width (pixbuf-width pixbuf))
         (height (pixbuf-height pixbuf))
         (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)
                           (pixbuf-pixels pixbuf))
      ;; 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-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 (->image obj)
  (match obj
    ((? image?) obj)
    ((? string?) (make-image obj))))

(define* (load-image image #:key
                     (min-filter 'nearest)
                     (mag-filter 'nearest)
                     (wrap-s 'repeat)
                     (wrap-t 'repeat)
                     transparent-color
                     (flip? #t))
  "Load a texture from an image in IMAGE, which can be an image object
or a file name string.  MIN-FILTER and MAG-FILTER describe the method
that should be used for minification and magnification.  Valid values
are 'nearest and 'linear.  By default, 'nearest is used."
  (let ((pixbuf (%load-image (->image image) transparent-color flip?)))
    (pixbuf->texture pixbuf
                     #:min-filter min-filter
                     #:mag-filter mag-filter
                     #:wrap-s wrap-s
                     #:wrap-t wrap-t)))

(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 (->image right) #f #f)
                 #:left (%load-image (->image left) #f #f)
                 #:top (%load-image (->image top) #f #f)
                 #:bottom (%load-image (->image bottom) #f #f)
                 #:front (%load-image (->image front) #f #f)
                 #:back (%load-image (->image back) #f #f)
                 #:min-filter min-filter
                 #:mag-filter mag-filter))

(define (texture-copy-pixbuf! texture pixbuf)
  "Copy the contents of PIXBUF to TEXTURE."
  (with-graphics-state! ((g:texture-0 texture))
    (gl-texture-sub-image-2d (texture-target texture-2d) 0
                             (texture-x texture) (texture-y texture)
                             (pixbuf-width pixbuf) (pixbuf-height pixbuf)
                             (gl-pixel-format 'rgba)
                             (color-pointer-type unsigned-byte)
  	                     (pixbuf-pixels pixbuf))))

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

(define (black-texture)
  null-texture)

(define %white-texture
  (delay
    (make-texture 2 2 #:pixels (u32vector #xffffffff #xffffffff
                                          #xffffffff #xffffffff))))

(define (white-texture)
  (force %white-texture))

(define %gray-texture
  (delay
    (make-texture 2 2 #:pixels (u32vector #xff808080 #xff808080
                                          #xff808080 #xff808080))))

(define (gray-texture)
  (force %gray-texture))

;; 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.  The color values are in ABGR ordering.  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 %flat-texture
  (delay
    (make-texture 2 2 #:pixels (u32vector #xffff8080 #xffff8080
                                          #xffff8080 #xffff8080))))

(define (flat-texture)
  (force %flat-texture))


;;;
;;; Texture Atlas
;;;

(define-record-type <texture-atlas>
  (%make-texture-atlas texture vector)
  texture-atlas?
  (texture texture-atlas-texture)
  (vector texture-atlas-vector))

(define (display-texture-atlas atlas port)
  (format port
          "#<texture-atlas texture: ~a size: ~d>"
          (texture-atlas-texture atlas)
          (vector-length (texture-atlas-vector atlas))))

(set-record-type-printer! <texture-atlas> display-texture-atlas)

(define (list->texture-atlas texture rects)
  "Return a new atlas for TEXTURE containing RECTS, a list of texture
coordinate rects denoting the various regions within."
  (let ((v (make-vector (length rects))))
    (let loop ((i 0)
               (rects rects))
      (match rects
        (() (%make-texture-atlas texture v))
        (((x y width height) . rest)
         (vector-set! v i (make-texture-region texture (make-rect x y width height)))
         (loop (1+ i) rest))))))

(define (texture-atlas texture . rects)
  "Return a new atlas for TEXTURE containing RECTS, a series of
4-tuples in the form (x y width height) describing the various tiles
within."
  (list->texture-atlas texture rects))

(define (texture-atlas-size atlas)
  "Return the size of ATLAS."
  (vector-length (texture-atlas-vector atlas)))

(define (texture-atlas-ref atlas index)
  "Return the texture region associated with INDEX in
ATLAS."
  (vector-ref (texture-atlas-vector atlas) index))

(define* (texture-tileset-dimensions texture tile-width tile-height #:key
                                     (margin 0) (spacing 0))
  (values (inexact->exact
           (ceiling (/ (- (texture-width texture) margin)
                       (+ tile-width spacing))))
          (inexact->exact
           (ceiling (/ (- (texture-height texture) margin)
                       (+ tile-height spacing))))))

(define* (split-texture texture tile-width tile-height #:key
                        (margin 0) (spacing 0))
  "Return a new texture atlas that splits TEXTURE into a grid of
TILE-WIDTH by TILE-HEIGHT rectangles.  Optionally, each tile may have
SPACING pixels of horizontal and vertical space between surrounding
tiles and the entire image may have MARGIN pixels of empty space
around its border.

This type of texture atlas layout is very common for tile map
terrain."
  (call-with-values (lambda ()
                      (texture-tileset-dimensions texture tile-width tile-height
                                                  #:margin margin
                                                  #:spacing spacing))
    (lambda (columns rows)
      (let ((v (make-vector (* rows columns))))
        (define (make-tile tx ty)
          (let* ((x (+ (* tx (+ tile-width spacing)) margin))
                 (y (+ (* ty (+ tile-height spacing)) margin)))
            (make-texture-region texture (make-rect x y tile-width tile-height))))
        (for-range ((x columns)
                    (y rows))
          (vector-set! v (+ x (* y columns)) (make-tile x y)))
        (%make-texture-atlas texture v)))))

(define* (load-tileset file-name tile-width tile-height #:key
                       (margin 0)
                       (spacing 0)
                       (min-filter 'nearest)
                       (mag-filter 'nearest)
                       (wrap-s 'repeat)
                       (wrap-t 'repeat)
                       transparent-color)
  "Return a new texture atlas that splits the texture loaded from the
file FILE-NAME into a grid of TILE-WIDTH by TILE-HEIGHT rectangles.
See load-image and split-texture for information about all keyword
arguments."
  (split-texture (load-image file-name
                             #:min-filter min-filter
                             #:mag-filter mag-filter
                             #:wrap-s wrap-s
                             #:wrap-t wrap-t
                             #:transparent-color transparent-color)
                 tile-width
                 tile-height
                 #:margin margin
                 #:spacing spacing))