path: root/chickadee/graphics/sprite.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2016, 2019, 2020, 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 sprite)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-4)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-11)
  #:use-module (chickadee math matrix)
  #:use-module (chickadee math rect)
  #:use-module (chickadee math vector)
  #:use-module (chickadee graphics blend)
  #:use-module (chickadee graphics color)
  #:use-module (chickadee graphics engine)
  #:use-module (chickadee graphics seagull)
  #:use-module (chickadee graphics shader)
  #:use-module (chickadee graphics texture)
  #:use-module (chickadee graphics buffer)
  #:export (draw-sprite*
            draw-sprite

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

            with-batched-sprites
            draw-nine-patch*
            draw-nine-patch))

(define-geometry-type <sprite-vertex>
  sprite-vertex-ref
  sprite-vertex-set!
  sprite-vertex-append!
  (position vec2)
  (texture vec2))

(define-graphics-variable sprite-geometry
  (make-geometry <sprite-vertex> 4 #:index-capacity 6))
(define-graphics-variable sprite-model-matrix (make-null-matrix4))
(define-graphics-variable sprite-mvp-matrix (make-null-matrix4))

(define-vertex-shader sprite-vertex
  (in vec2 position)
  (in vec2 tex)
  (out vec2 frag-tex)
  (uniform mat4 mvp)
  (set! vertex:position (* mvp (vec4 position 0.0 1.0)))
  (set! frag-tex tex))

(define-fragment-shader sprite-fragment
  (in vec2 frag-tex)
  (out vec4 frag-color)
  (uniform sampler-2d color-texture)
  (uniform vec4 tint)
  (set! frag-color (* (texture color-texture frag-tex) tint)))

(define-graphics-variable sprite-shader
  (compile-shader sprite-vertex sprite-fragment))

(define* (draw-sprite* texture
                       rect
                       matrix
                       #:key
                       (tint white)
                       (blend-mode blend:alpha)
                       (texcoords (texture-gl-tex-rect texture)))
  (let ((shader (graphics-variable-ref sprite-shader))
        (geometry (graphics-variable-ref sprite-geometry))
        (mvp (graphics-variable-ref sprite-mvp-matrix)))
    (with-geometry geometry
      (let* ((x1 (rect-x rect))
             (y1 (rect-y rect))
             (x2 (+ x1 (rect-width rect)))
             (y2 (+ y1 (rect-height rect)))
             (s1 (rect-x texcoords))
             (t1 (rect-y texcoords))
             (s2 (+ (rect-x texcoords) (rect-width texcoords)))
             (t2 (+ (rect-y texcoords) (rect-height texcoords))))
        (sprite-vertex-append! geometry
                               (x1 y1 s1 t1)
                               (x2 y1 s2 t1)
                               (x2 y2 s2 t2)
                               (x1 y2 s1 t2))
        (geometry-index-append! geometry 0 3 2 0 2 1)))
    (with-graphics-state ((g:blend-mode blend-mode)
                          (g:texture-0 texture))
      (shader-apply shader
                    (geometry-vertex-array geometry)
                    #:tint tint
                    #:mvp (if matrix
                              (begin
                                (matrix4-mult! mvp matrix
                                               (current-projection))
                                mvp)
                              (current-projection))))))

(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 (texture-gl-rect texture))
                      (rotation 0.0)
                      (scale %default-scale)
                      (shear %default-shear)
                      (tint white))
  "Draw TEXTURE 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 ((matrix (graphics-variable-ref sprite-model-matrix)))
    (matrix4-2d-transform! matrix
                           #:origin origin
                           #:position position
                           #:rotation rotation
                           #:scale scale
                           #:shear shear)
    (draw-sprite* texture rect matrix
                  #:tint tint
                  #:blend-mode blend-mode)))


;;;
;;; Sprite Batches
;;;

(define-geometry-type <batched-sprite-vertex>
  batched-sprite-ref
  batched-sprite-set!
  batched-sprite-append!
  (position vec2)
  (texture vec2)
  (tint vec4))

(define-vertex-shader sprite-batch-vertex
  (in vec2 position)
  (in vec2 tex)
  (in vec4 tint)
  (out vec2 frag-tex)
  (out vec4 frag-tint)
  (uniform mat4 mvp)
  (outputs
   (vertex:position (* mvp (vec4 position 0.0 1.0)))
   (frag-tex tex)
   (frag-tint tint)))

(define-fragment-shader sprite-batch-fragment
  (in vec2 frag-tex)
  (in vec4 frag-tint)
  (out vec4 frag-color)
  (uniform sampler-2d color-texture)
  (outputs
   (frag-color (* (texture color-texture frag-tex) frag-tint))))

(define-graphics-variable sprite-batch-shader
  (compile-shader sprite-batch-vertex sprite-batch-fragment))

(define-record-type <sprite-batch>
  (%make-sprite-batch texture geometry size)
  sprite-batch?
  (texture sprite-batch-texture set-sprite-batch-texture!)
  (geometry sprite-batch-geometry)
  (size sprite-batch-size set-sprite-batch-size!))

(define* (make-sprite-batch texture #:key (capacity 256))
  "Make a sprite batch that can hold CAPACITY sprites before needing
to resize."
  (%make-sprite-batch texture
                      (make-geometry <batched-sprite-vertex> (* capacity 4)
                                     #:index-capacity (* capacity 6))
                      0))

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

(define (sprite-batch-flush! batch)
  "Submit the contents of BATCH to the GPU."
  (geometry-end! (sprite-batch-geometry batch)))

(define* (sprite-batch-add* batch rect matrix
                            #:key
                            (tint white)
                            texture-region)
  "Add RECT, transformed by MATRIX, to BATCH.  To render a subsection
of the batch's texture, a texture object whose parent is the batch
texture may be specified via the TEXTURE-REGION argument."
  (let* ((geometry (sprite-batch-geometry batch))
         (vertex-offset (geometry-vertex-count geometry <batched-sprite-vertex>))
         (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))
         (texcoords (texture-gl-tex-rect
                     (or texture-region
                         (sprite-batch-texture batch))))
         (s1 (rect-x texcoords))
         (t1 (rect-y texcoords))
         (s2 (+ (rect-x texcoords) (rect-width texcoords)))
         (t2 (+ (rect-y texcoords) (rect-height texcoords)))
         (r (color-r tint))
         (g (color-g tint))
         (b (color-b tint))
         (a (color-a tint)))
    (batched-sprite-append! geometry
                            (x1 y1 s1 t1 r g b a)
                            (x2 y2 s2 t1 r g b a)
                            (x3 y3 s2 t2 r g b a)
                            (x4 y4 s1 t2 r g b a))
    (geometry-index-append! geometry
                            vertex-offset
                            (+ vertex-offset 3)
                            (+ vertex-offset 2)
                            vertex-offset
                            (+ vertex-offset 2)
                            (+ vertex-offset 1))
    (set-sprite-batch-size! batch (+ (sprite-batch-size batch) 1))))

(define* (sprite-batch-add! batch
                            position
                            #:key
                            (origin %null-vec2)
                            (rotation 0.0)
                            (scale %default-scale)
                            (shear %null-vec2)
                            texture-region
                            (tint white))
  "Add sprite to BATCH at POSITION.  To render a subsection of the
batch's texture, a texture object whose parent is the batch texture
may be specified via the TEXTURE-REGION argument."
  (let ((matrix (graphics-variable-ref sprite-model-matrix))
        (rect (texture-gl-rect
               (or texture-region (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
                       #:texture-region texture-region)))

(define* (draw-sprite-batch* batch matrix #:key (blend-mode blend:alpha))
  "Render the contents of BATCH."
  (let ((shader (graphics-variable-ref sprite-batch-shader))
        (mvp (graphics-variable-ref sprite-mvp-matrix)))
    (sprite-batch-flush! batch)
    (matrix4-mult! mvp matrix (current-projection))
    (with-graphics-state ((g:blend-mode blend-mode)
                          (g:texture-0 (sprite-batch-texture batch)))
      (let ((geometry (sprite-batch-geometry batch)))
        (shader-apply* shader
                       (geometry-vertex-array geometry)
                       0
                       (geometry-index-count geometry)
                       #:mvp mvp)))))

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