path: root/chickadee/graphics/sprite.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2016, 2019, 2020, 2021, 2024 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.

;;; Commentary:
;;
;; 2D sprite rendering.
;;
;;; Code:

(define-module (chickadee graphics sprite)
  #:use-module (chickadee data bytestruct)
  #:use-module (chickadee graphics)
  #:use-module (chickadee graphics buffer)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics pipeline)
  #:use-module (chickadee graphics shader)
  #:use-module (chickadee graphics texture)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee math rect)
  #:use-module (chickadee math vector)
  #:use-module (chickadee utils)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-4)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (srfi srfi-11)
  #:export (make-sprite
            sprite?
            sprite-texture-view
            sprite-rect
            sprite-rect-uv

            list->sprite-sheet
            sprite-sheet
            tileset
            load-tileset
            sprite-sheet?
            sprite-sheet-length
            sprite-sheet-ref

            draw-sprite*
            draw-sprite

            make-sprite-batch
            sprite-batch?
            sprite-batch-texture
            set-sprite-batch-texture!
            sprite-batch-clear!
            sprite-batch-end!
            sprite-batch-add*
            sprite-batch-set!*
            sprite-batch-add!
            sprite-batch-set!
            draw-sprite-batch*
            draw-sprite-batch))


;;;
;;; Sprite sheets
;;;

(define-record-type <sprite>
  (%make-sprite texture-view rect rect-uv)
  sprite?
  (texture-view sprite-texture-view)
  (rect sprite-rect)
  (rect-uv sprite-rect-uv))

(define (make-sprite texture-view rect)
  (unless (texture-view-2d? texture-view)
    (error "expected 2D texture view" texture-view))
  (let* ((width (texture-view-width texture-view))
         (height (texture-view-height texture-view))
         (uv (make-rect (/ (rect-x rect) width)
                        (/ (rect-y rect) height)
                        (/ (rect-width rect) width)
                        (/ (rect-height rect) height))))
    (%make-sprite texture-view rect uv)))

(define-record-type <sprite-sheet>
  (%make-sprite-sheet texture-view sprites)
  sprite-sheet?
  (texture-view sprite-sheet-texture-view)
  (sprites sprite-sheet-sprites))

(define (print-sprite-sheet sheet port)
  (format port
          "#<sprite-sheet texture-view: ~a size: ~d>"
          (sprite-sheet-texture-view sheet)
          (vector-length (sprite-sheet-sprites sheet))))

(set-record-type-printer! <sprite-sheet> print-sprite-sheet)

(define (list->sprite-sheet texture-view rects)
  "Return a new sprite sheet containing RECTS, a list of
rectangles describing the various sprites within TEXTURE-VIEW."
  (let ((v (make-vector (length rects))))
    (let loop ((i 0) (rects rects))
      (match rects
        (() (%make-sprite-sheet texture-view v))
        ((rect . rest)
         (vector-set! v i (make-sprite texture-view rect))
         (loop (1+ i) rest))))))

(define (sprite-sheet texture-view . rects)
  "Return a new sprite sheet containing RECTS, a list of
rectangles describing the various sprites within TEXTURE-VIEW."
  (list->sprite-sheet texture-view rects))

(define (sprite-sheet-length sprite-sheet)
  "Return the number of sprites in the SPRITE-SHEET."
  (vector-length (sprite-sheet-sprites sprite-sheet)))

(define (sprite-sheet-ref sprite-sheet index)
  "Return the sprite associated with INDEX in
SPRITE-SHEET."
  (vector-ref (sprite-sheet-sprites sprite-sheet) index))

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

(define* (tileset texture-view tile-width tile-height
                  #:key (margin 0) (spacing 0))
  "Return a new sprite sheet that splits TEXTURE-VIEW into a grid of
TILE-WIDTH by TILE-HEIGHT sprites.  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."
  (call-with-values (lambda ()
                      (texture-tileset-dimensions texture-view 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-sprite texture-view (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-sprite-sheet texture-view v)))))

(define* (load-tileset file-name tile-width tile-height #:key
                       (margin 0)
                       (spacing 0)
                       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."
  (tileset (texture-view
            (load-image file-name #:transparent-color transparent-color))
           tile-width
           tile-height
           #:margin margin
           #:spacing spacing))


;;;
;;; Sprite streaming
;;;

(define-record-type <sprite-state>
  (make-sprite-state shader uniforms sampler matrix
                     color-target-cache bindings rect-cache)
  sprite-state?
  (shader sprite-state-shader)
  (uniforms sprite-state-uniforms)
  (sampler sprite-state-sampler)
  (matrix sprite-state-matrix)
  (color-target-cache sprite-state-color-target-cache)
  (bindings sprite-state-bindings)
  (rect-cache sprite-state-rect-cache))

(define (sprite-color-target state blend-mode)
  (let ((cache (sprite-state-color-target-cache state)))
    (or (hashq-ref cache blend-mode)
        (let ((color-target (make-color-target #:blend-mode blend-mode)))
          (hashq-set! cache blend-mode color-target)
          color-target))))

(define (%sprite-rect state texture)
  (let ((cache (sprite-state-rect-cache state)))
    (or (hashq-ref cache texture)
        (let ((rect (make-rect 0.0 0.0
                               (texture-width texture)
                               (texture-height texture))))
          (hashq-set! cache texture rect)
          rect))))

(define-bytestruct <sprite-vertex>
  (struct (position <vec2>)
          (texture <vec2>)
          (color <color>)))

(define-bytestruct <sprite-uniforms>
  (struct (mvp <matrix4>)))

(define %sprite-vertex-layout
  (vector (make-vertex-buffer-layout
           #:stride (* 8 4)
           #:attributes (vector
                         (make-vertex-attribute
                          #:format 'float32x2)
                         (make-vertex-attribute
                          #:format 'float32x2
                          #:offset (* 2 4))
                         (make-vertex-attribute
                          #:format 'float32x4
                          #:offset (* 4 4))))))

(define %sprite-binding-layout
  (vector (make-texture-layout)
          (make-sampler-layout)
          (make-buffer-layout)))

(define-graphics-variable sprite-state
  (make-sprite-state
   (make-shader
    (lambda (lang)
      (values "
#ifdef GLSL330
layout (location = 0) in vec2 position;
layout (location = 1) in vec2 tex;
layout (location = 2) in vec4 tint;
#elif defined(GLSL130)
in vec2 position;
in vec2 tex;
in vec4 tint;
#elif defined(GLSL120)
attribute vec2 position;
attribute vec2 tex;
attribute vec4 tint;
#endif
#ifdef GLSL120
varying vec2 fragTex;
varying vec4 fragTint;
#else
out vec2 fragTex;
out vec4 fragTint;
#endif

#ifdef GLSL120
uniform mat4 matrix;
#else
layout (std140) uniform Sprite
{
    mat4 matrix;
};
#endif

void main(void) {
    fragTex = tex;
    fragTint = tint;
    gl_Position = matrix * vec4(position.xy, 0.0, 1.0);
}
"
              "
#ifdef GLSL120
varying vec2 fragTex;
varying vec4 fragTint;
#else
in vec2 fragTex;
in vec4 fragTint;
#endif
#ifdef GLSL330
out vec4 fragColor;
#else
#define fragColor gl_FragColor
#define texture texture2D
#endif

uniform sampler2D colorTexture;

void main (void) {
    fragColor = texture(colorTexture, fragTex) * fragTint;
}
"))
    #:name "Sprite shader")
   (make-buffer (* 16 4)
                #:name "Sprite uniform buffer"
                #:usage '(uniform))
   (make-sampler #:name "Sprite sampler")
   (make-null-matrix4)
   (make-hash-table)
   (make-vector 3 #f)
   (make-hash-table)))

(define %default-texcoords (make-rect 0.0 0.0 1.0 1.0))

(define-inlinable (sprite-set! vertices voffset indices ioffset i rect texcoords tint matrix)
  (let* ((minx (rect-x rect))
         (miny (rect-y rect))
         (maxx (+ minx (rect-width rect)))
         (maxy (+ miny (rect-height rect)))
         (x1 (matrix4-transform-x matrix minx miny))
         (y1 (matrix4-transform-y matrix minx miny))
         (x2 (matrix4-transform-x matrix maxx miny))
         (y2 (matrix4-transform-y matrix maxx miny))
         (x3 (matrix4-transform-x matrix maxx maxy))
         (y3 (matrix4-transform-y matrix maxx maxy))
         (x4 (matrix4-transform-x matrix minx maxy))
         (y4 (matrix4-transform-y matrix minx maxy))
         (s1 (rect-x texcoords))
         (t1 (rect-y texcoords))
         (s2 (+ s1 (rect-width texcoords)))
         (t2 (+ t1 (rect-height texcoords)))
         (r (color-r tint))
         (g (color-g tint))
         (b (color-b tint))
         (a (color-a tint)))
    (define-syntax-rule (set-vertex! j x* y* u v r* g* b* a*)
      (dbuffer-pack! <sprite-vertex>
                     (((position x) x*)
                      ((position y) y*)
                      ((texture x) u)
                      ((texture y) v)
                      ((color r) r*)
                      ((color g) g*)
                      ((color b) b*)
                      ((color a) a*))
                     vertices
                     (+ voffset (* j (bytestruct-sizeof <sprite-vertex>)))))
    (set-vertex! 0 x1 y1 s1 t1 r g b a)
    (set-vertex! 1 x2 y2 s2 t1 r g b a)
    (set-vertex! 2 x3 y3 s2 t2 r g b a)
    (set-vertex! 3 x4 y4 s1 t2 r g b a)
    (dbuffer-pack-indices-quad! indices ioffset i)))

(define-inlinable (sprite-append! vertices indices i rect texcoords tint matrix)
  (let ((voffset (dbuffer-reserve! vertices (* (bytestruct-sizeof <sprite-vertex>) 4)))
        (ioffset (dbuffer-reserve! indices (* 6 4))))
    (sprite-set! vertices voffset indices ioffset i rect texcoords tint matrix)))

(define* (draw-sprite* texture-view rect matrix #:key
                       (tint white)
                       (blend-mode blend:alpha)
                       (texcoords %default-texcoords))
  (match (graphics-variable-ref sprite-state)
    ((and state ($ <sprite-state> shader uniforms sampler _ _ bindings))
     (vector-set! bindings 0 texture-view)
     (vector-set! bindings 1 sampler)
     (vector-set! bindings 2 uniforms)
     (call-with-values
         (lambda ()
           (stream-draw #:count 4
                        #:shader shader
                        #:color-target (sprite-color-target state blend-mode)
                        #:vertex-layout %sprite-vertex-layout
                        #:binding-layout %sprite-binding-layout
                        #:bindings bindings))
       (lambda (vertices indices i)
         (when (eq? i 0)
           (let ((bv (map-buffer uniforms 'write 0
                                 (bytestruct-sizeof <sprite-uniforms>))))
             (bytestruct-pack! <sprite-uniforms>
                               (((mvp) (current-projection)))
                               bv 0)
             (unmap-buffer uniforms)))
         (sprite-append! vertices indices i rect texcoords tint matrix))))))

(define %null-vec2 (vec2 0.0 0.0))
(define %default-scale (vec2 1.0 1.0))
(define %default-shear (vec2 0.0 0.0))

(define* (draw-sprite texture
                      position
                      #:key
                      (blend-mode blend:alpha)
                      (origin %null-vec2)
                      rect
                      (rotation 0.0)
                      (scale %default-scale)
                      (shear %default-shear)
                      (tint white))
  "Draw TEXTURE, a 2D texture or texture view, at POSITION.

Optionally, other transformations may be applied to the sprite.
ROTATION specifies the angle to rotate the sprite, in radians.  SCALE
specifies the scaling factor as a 2D vector.  All transformations are
applied relative to ORIGIN, a 2D vector.

TINT specifies the color to multiply against all the sprite's pixels.
By default white is used, which does no tinting at all.

By default, alpha blending is used but can be changed by specifying
BLEND-MODE."
  (let* ((state (graphics-variable-ref sprite-state))
         (matrix (sprite-state-matrix state))
         (rect (or rect (%sprite-rect state texture))))
    (matrix4-2d-transform! matrix
                           #:origin origin
                           #:position position
                           #:rotation rotation
                           #:scale scale
                           #:shear shear)
    (draw-sprite* (if (texture? texture) (texture-view texture) texture)
                  rect matrix
                  #:tint tint
                  #:blend-mode blend-mode)))


;;;
;;; Sprite Batches
;;;

(define-record-type <sprite-batch>
  (%make-sprite-batch size texture vertices indices buffers pipeline
                      uniforms sampler bindings matrix)
  sprite-batch?
  (size sprite-batch-size set-sprite-batch-size!)
  (texture sprite-batch-texture set-sprite-batch-texture!)
  (vertices sprite-batch-vertices)
  (indices sprite-batch-indices)
  ;; A vector of 1 to vector-set! before each draw.
  (buffers sprite-batch-buffers)
  (pipeline sprite-batch-pipeline)
  (uniforms sprite-batch-uniforms)
  (sampler sprite-batch-sampler)
  (bindings sprite-batch-bindings)
  (matrix sprite-batch-matrix))

(define* (make-sprite-batch texture #:key
                            (capacity 256)
                            (blend-mode blend:alpha))
  "Make a sprite batch with enough storage to hold CAPACITY sprites
initially.  By default, alpha blending is used when rendering but can
be changed by specifying BLEND-MODE."
  (let ((shader (sprite-state-shader (graphics-variable-ref sprite-state)))
        (color-target (make-color-target #:blend-mode blend-mode)))
    (%make-sprite-batch 0 texture
                        (make-dbuffer
                         #:name "Sprite batch vertices"
                         #:capacity (* capacity 4))
                        (make-dbuffer
                         #:name "Sprite batch indices"
                         #:capacity (* capacity 6))
                        (vector #f)
                        (make-render-pipeline
                         #:name "Sprite batch"
                         #:shader shader
                         #:color-target color-target
                         #:vertex-layout %sprite-vertex-layout
                         #:binding-layout %sprite-binding-layout)
                        (make-buffer (* 16 4)
                                     #:name "Sprite batch uniform buffer"
                                     #:usage '(uniform))
                        (make-sampler #:name "Sprite batch sampler")
                        (make-vector 3 #f)
                        (make-null-matrix4))))

(define (sprite-batch-clear! batch)
  "Reset BATCH to size 0."
  (set-sprite-batch-size! batch 0))

(define* (sprite-batch-set!* batch i rect matrix
                             #:key
                             (tint white)
                             (texcoords %default-texcoords))
  (match batch
    (($ <sprite-batch> size texture vertices indices)
     (unless (< -1 i size)
       (error "sprite batch index out of range" i))
     (unless (dbuffer-mapped? vertices)
       (dbuffer-map! vertices)
       (dbuffer-map! indices))
     (let ((voffset (* i (bytestruct-sizeof <sprite-vertex>) 4))
           (ioffset (* i 6 4)))
       (sprite-set! vertices voffset indices ioffset (* i 4) rect texcoords tint matrix)))))

(define* (sprite-batch-add* batch rect matrix
                            #:key
                            (tint white)
                            (texcoords %default-texcoords))
  "Add RECT, transformed by MATRIX, to BATCH.  To render a subsection
of the batch's texture, specify a TEXCOORDS rect in texture uv
coordinates."
  (match batch
    (($ <sprite-batch> size texture vertices indices)
     (unless (dbuffer-mapped? vertices)
       (dbuffer-map! vertices)
       (dbuffer-map! indices))
     (sprite-append! vertices indices (* size 4) rect texcoords tint matrix)
     (set-sprite-batch-size! batch (+ size 1)))))

;; TODO: Specify sub-region in pixel coordinates.
(define* (sprite-batch-add! batch position
                            #:key
                            (origin %null-vec2)
                            (rotation 0.0)
                            (scale %default-scale)
                            (shear %null-vec2)
                            (tint white)
                            rect
                            (texcoords %default-texcoords))
  "Add sprite to BATCH at POSITION.  To render a subsection
of the batch's texture, specify a TEXCOORDS rect in texture uv
coordinates."
  (let* ((state (graphics-variable-ref sprite-state))
         (matrix (sprite-state-matrix state))
         (rect (or rect (%sprite-rect state (sprite-batch-texture batch)))))
    (matrix4-2d-transform! matrix
                           #:origin origin
                           #:position position
                           #:rotation rotation
                           #:scale scale
                           #:shear shear)
    (sprite-batch-add* batch rect matrix
                       #:tint tint
                       #:texcoords texcoords)))

(define* (sprite-batch-set! batch i position
                            #:key
                            (origin %null-vec2)
                            (rotation 0.0)
                            (scale %default-scale)
                            (shear %null-vec2)
                            (tint white)
                            rect
                            (texcoords %default-texcoords))
  "Overwrite sprite I in BATCH with a new sprite at POSITION.  To render
a subsection of the batch's texture, specify a TEXCOORDS rect in
texture uv coordinates."
  (let* ((state (graphics-variable-ref sprite-state))
         (matrix (sprite-state-matrix state))
         (rect (or rect (%sprite-rect state (sprite-batch-texture batch)))))
    (matrix4-2d-transform! matrix
                           #:origin origin
                           #:position position
                           #:rotation rotation
                           #:scale scale
                           #:shear shear)
    (sprite-batch-set!* batch i rect matrix
                        #:tint tint
                        #:texcoords texcoords)))

(define (draw-sprite-batch* batch matrix)
  "Render the contents of BATCH."
  (match batch
    (($ <sprite-batch> size texture vertices indices vertex-buffers pipeline
                       uniforms sampler bindings mvp)
     (when (dbuffer-mapped? vertices)
       (dbuffer-unmap! vertices)
       (dbuffer-unmap! indices))
     (unless (eq? size 0)
       (let ((view (if (texture-view? texture)
                       texture
                       (texture-view texture))))
         (matrix4-mult! mvp matrix (current-projection))
         (let ((bv (map-buffer uniforms 'write 0
                               (bytestruct-sizeof <sprite-uniforms>))))
           (bytestruct-pack! <sprite-uniforms>
                             (((mvp) mvp))
                             bv 0)
           (unmap-buffer uniforms))
         (vector-set! vertex-buffers 0 (dbuffer-buffer vertices))
         (vector-set! bindings 0 view)
         (vector-set! bindings 1 sampler)
         (vector-set! bindings 2 uniforms)
         (draw (* size 6)
               #:pipeline pipeline
               #:index-buffer (dbuffer-buffer indices)
               #:vertex-buffers vertex-buffers
               #:bindings bindings))))))

(define* (draw-sprite-batch batch
                            #:key
                            (position %null-vec2)
                            (origin %null-vec2)
                            (scale %default-scale)
                            (rotation 0.0))
  "Render the contents of BATCH."
  (let* ((state (graphics-variable-ref sprite-state))
         (matrix (sprite-state-matrix state)))
    (matrix4-2d-transform! matrix
                           #:origin origin
                           #:position position
                           #:rotation rotation
                           #:scale scale)
    (draw-sprite-batch* batch matrix)))