path: root/chickadee/render/sprite.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2016 David Thompson <davet@gnu.org>
;;;
;;; Chickadee is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published
;;; by the Free Software Foundation, either version 3 of the License,
;;; or (at your option) any later version.
;;;
;;; Chickadee is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;; General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program.  If not, see
;;; <http://www.gnu.org/licenses/>.

(define-module (chickadee render sprite)
  #: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 render)
  #:use-module (chickadee render shader)
  #:use-module (chickadee render texture)
  #:use-module (chickadee render vertex-buffer)
  #:export (draw-sprite
            with-batched-sprites))

(define default-shader
  (delay
    (strings->shader
     "
#version 330

in vec2 position;
in vec2 tex;
out vec2 frag_tex;
uniform mat4 mvp;

void main(void) {
    frag_tex = tex;
    gl_Position = mvp * vec4(position.xy, 0.0, 1.0);
}
"
     "
#version 330

in vec2 frag_tex;
uniform sampler2D color_texture;

void main (void) {
    gl_FragColor = texture2D(color_texture, frag_tex);
}
")))

(define draw-sprite-unbatched
  (let* ((vertex-buffer
          (delay (make-streaming-vertex-buffer 'vec2 4)))
         (texcoord-buffer
          (delay (make-streaming-vertex-buffer 'vec2 4)))
         (index-buffer
          (delay (make-vertex-buffer 'index 'static (u32vector 0 3 2 0 2 1))))
         (vertex-array
          (delay (make-vertex-array (force index-buffer)
                                    (force vertex-buffer)
                                    (force texcoord-buffer))))
         (tmp-matrix (make-null-matrix4))
         (mvp (make-null-matrix4)))
    (lambda (texture dimensions scale rotation blend-mode shader texture-rect)
      (with-mapped-vertex-buffer (force vertex-buffer)
        (let* ((x1 0)
               (y1 0)
               (x2 (rect-width dimensions))
               (y2 (rect-height dimensions))
               (bv (vertex-buffer-data (force vertex-buffer))))
          (f32vector-set! bv 0 x1)
          (f32vector-set! bv 1 y1)
          (f32vector-set! bv 2 x2)
          (f32vector-set! bv 3 y1)
          (f32vector-set! bv 4 x2)
          (f32vector-set! bv 5 y2)
          (f32vector-set! bv 6 x1)
          (f32vector-set! bv 7 y2)))
      (with-mapped-vertex-buffer (force texcoord-buffer)
        (let ((s1 (rect-left texture-rect))
              (t1 (rect-bottom texture-rect))
              (s2 (rect-right texture-rect))
              (t2 (rect-top texture-rect))
              (bv (vertex-buffer-data (force texcoord-buffer))))
          (f32vector-set! bv 0 s1)
          (f32vector-set! bv 1 t1)
          (f32vector-set! bv 2 s2)
          (f32vector-set! bv 3 t1)
          (f32vector-set! bv 4 s2)
          (f32vector-set! bv 5 t2)
          (f32vector-set! bv 6 s1)
          (f32vector-set! bv 7 t2)))
      (matrix4-identity! mvp)
      (when rotation
        (matrix4-rotate-z! tmp-matrix rotation)
        (matrix4-mult! mvp mvp tmp-matrix))
      (when scale
        (matrix4-scale! tmp-matrix scale)
        (matrix4-mult! mvp mvp tmp-matrix))
      (matrix4-translate! tmp-matrix (rect-x dimensions) (rect-y dimensions))
      (matrix4-mult! mvp mvp tmp-matrix)
      (matrix4-mult! mvp mvp (current-projection))
      (with-blend-mode blend-mode
        (with-texture texture
          (gpu-apply shader (force vertex-array) #:mvp mvp))))))


;;;
;;; Sprite Batch
;;;

(define-record-type <sprite-batch>
  (%make-sprite-batch texture blend-mode shader size capacity index-buffer
                      position-buffer texture-buffer vertex-array)
  sprite-batch?
  (texture sprite-batch-texture set-sprite-batch-texture!)
  (blend-mode sprite-batch-blend-mode set-sprite-batch-blend-mode!)
  (shader sprite-batch-shader set-sprite-batch-shader!)
  (size sprite-batch-size set-sprite-batch-size!)
  (capacity sprite-batch-capacity)
  (index-buffer sprite-batch-index-buffer)
  (position-buffer sprite-batch-position-buffer)
  (texture-buffer sprite-batch-texture-buffer)
  (vertex-array sprite-batch-vertex-array))

(define (make-sprite-batch capacity)
  "Make a sprite batch that can hold CAPACITY sprites."
  (let* ((index (make-streaming-vertex-buffer 'index (* capacity 6)))
         (pos (make-streaming-vertex-buffer 'vec2  (* capacity 4)))
         (tex (make-streaming-vertex-buffer 'vec2  (* capacity 4)))
         (va (make-vertex-array index pos tex)))
    (%make-sprite-batch #f #f #f 0 capacity index pos tex va)))

(define (sprite-batch-full? batch)
  (= (sprite-batch-capacity batch) (sprite-batch-size batch)))

(define (double-sprite-batch-size! batch)
  #f)

(define (sprite-batch-reset! batch)
  "Reset BATCH to size 0."
  (set-sprite-batch-texture! batch #f)
  (set-sprite-batch-blend-mode! batch #f)
  (set-sprite-batch-shader! batch #f)
  (set-sprite-batch-size! batch 0))

(define (sprite-batch-begin! batch)
  (map-vertex-buffer! (sprite-batch-index-buffer batch))
  (map-vertex-buffer! (sprite-batch-position-buffer batch))
  (map-vertex-buffer! (sprite-batch-texture-buffer batch)))

(define (sprite-batch-flush! batch)
  "Render the contents of BATCH and clear the cache."
  (unless (zero? (sprite-batch-size batch))
    (with-blend-mode (sprite-batch-blend-mode batch)
      (with-texture (sprite-batch-texture batch)
        (unmap-vertex-buffer! (sprite-batch-index-buffer batch))
        (unmap-vertex-buffer! (sprite-batch-position-buffer batch))
        (unmap-vertex-buffer! (sprite-batch-texture-buffer batch))
        (gpu-apply* (sprite-batch-shader batch)
                    (sprite-batch-vertex-array batch)
                    (* (sprite-batch-size batch) 6)
                    #:mvp (current-projection))
        (sprite-batch-reset! batch)))))

(define sprite-batch-add!
  (let ((tmp-matrix (make-null-matrix4))
        (matrix (make-null-matrix4)))
    (lambda (batch texture dimensions scale rotation blend-mode
                   shader texture-rect)
      ;; Expand the buffers when necessary.
      (when (sprite-batch-full? batch)
        (double-sprite-batch-size! batch))
      ;; Flush the batch if any GL state needs changing.
      (unless (and (eq? (sprite-batch-texture batch) texture)
                   (eq? (sprite-batch-blend-mode batch) blend-mode)
                   (eq? (sprite-batch-shader batch) shader))
        (sprite-batch-flush! batch)
        (sprite-batch-begin! batch)
        (set-sprite-batch-texture! batch texture)
        (set-sprite-batch-blend-mode! batch blend-mode)
        (set-sprite-batch-shader! batch shader))
      (let ((size (sprite-batch-size batch)))
        (let* ((index-offset (* size 6))
               (index-vertex-offset (* size 4))
               (vertex-offset (* size 8)) ;; 4 vertices, 2 floats per vertex
               (texture-offset (* size 8))
               (indices (vertex-buffer-data (sprite-batch-index-buffer batch)))
               (vertices (vertex-buffer-data (sprite-batch-position-buffer batch)))
               (texcoords (vertex-buffer-data (sprite-batch-texture-buffer batch)))
               (local-x1 0)
               (local-y1 0)
               (local-x2 (rect-width dimensions))
               (local-y2 (rect-height dimensions))
               (s1 (rect-left texture-rect))
               (t1 (rect-bottom texture-rect))
               (s2 (rect-right texture-rect))
               (t2 (rect-top texture-rect)))
          (matrix4-identity! matrix)
          (when rotation
            (matrix4-rotate-z! tmp-matrix rotation)
            (matrix4-mult! matrix matrix tmp-matrix))
          (when scale
            (matrix4-scale! tmp-matrix scale)
            (matrix4-mult! matrix matrix tmp-matrix))
          (matrix4-translate! tmp-matrix (rect-x dimensions) (rect-y dimensions))
          (matrix4-mult! matrix matrix tmp-matrix)
          (let-values (((world-x1 world-y1)
                        (transform matrix local-x1 local-y1))
                       ((world-x2 world-y2)
                        (transform matrix local-x2 local-y2)))
            ;; Add indices.
            (u32vector-set! indices index-offset index-vertex-offset)
            (u32vector-set! indices (+ index-offset 1) (+ index-vertex-offset 3))
            (u32vector-set! indices (+ index-offset 2) (+ index-vertex-offset 2))
            (u32vector-set! indices (+ index-offset 3) index-vertex-offset)
            (u32vector-set! indices (+ index-offset 4) (+ index-vertex-offset 2))
            (u32vector-set! indices (+ index-offset 5) (+ index-vertex-offset 1))
            ;; Add vertices.
            ;; Bottom-left
            (f32vector-set! vertices vertex-offset world-x1)
            (f32vector-set! vertices (+ vertex-offset 1) world-y1)
            ;; Bottom-right
            (f32vector-set! vertices (+ vertex-offset 2) world-x2)
            (f32vector-set! vertices (+ vertex-offset 3) world-y1)
            ;; Top-right
            (f32vector-set! vertices (+ vertex-offset 4) world-x2)
            (f32vector-set! vertices (+ vertex-offset 5) world-y2)
            ;; Top-left
            (f32vector-set! vertices (+ vertex-offset 6) world-x1)
            (f32vector-set! vertices (+ vertex-offset 7) world-y2)
            ;; Add texture coordinates.
            ;; Bottom-left
            (f32vector-set! texcoords texture-offset s1)
            (f32vector-set! texcoords (+ texture-offset 1) t1)
            ;; Bottom-right
            (f32vector-set! texcoords (+ texture-offset 2) s2)
            (f32vector-set! texcoords (+ texture-offset 3) t1)
            ;; Top-right
            (f32vector-set! texcoords (+ texture-offset 4) s2)
            (f32vector-set! texcoords (+ texture-offset 5) t2)
            ;; Top-left
            (f32vector-set! texcoords (+ texture-offset 6) s1)
            (f32vector-set! texcoords (+ texture-offset 7) t2)
            (set-sprite-batch-size! batch (1+ size))))))))

(define *batch?* #f)
(define %batch (delay (make-sprite-batch 256)))

(define (draw-sprite-batched texture dimensions
                             scale rotation blend-mode shader
                             texture-rect)
  (sprite-batch-add! (force %batch) texture dimensions
                     scale rotation blend-mode shader
                     texture-rect))

(define-syntax-rule (with-batched-sprites body ...)
  (dynamic-wind
    (lambda ()
      (set! *batch?* #t))
    (lambda ()
      (sprite-batch-reset! (force %batch))
      body ...
      (sprite-batch-flush! (force %batch)))
    (lambda ()
      (set! *batch?* #f))))

(define draw-sprite
  (let ((rect (make-rect 0.0 0.0 0.0 0.0))
        (default-texture-rect (make-rect 0.0 0.0 1.0 1.0)))
    (lambda* (texture dimensions #:key
                      scale rotation (blend-mode 'alpha)
                      texture-rect
                      (shader (force default-shader)))
      (let ((dimensions (if (vec2? dimensions)
                            (begin
                              (rect-move-vec2! rect dimensions)
                              (set-rect-width! rect (texture-width texture))
                              (set-rect-height! rect (texture-height texture))
                              rect)
                            dimensions))
            (texture-rect (or texture-rect default-texture-rect)))
        (if *batch?*
            (draw-sprite-batched texture dimensions
                                 scale rotation blend-mode shader
                                 texture-rect)
            (draw-sprite-unbatched texture dimensions
                                   scale rotation blend-mode shader
                                   texture-rect))))))