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

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

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

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

in vec2 fragTex;
uniform sampler2D colorTexture;

void main (void) {
    gl_FragColor = texture2D(colorTexture, fragTex);
}
")))

(define draw-sprite-unbatched
  (let* ((position-buffer
          (delay
            (make-streaming-typed-buffer 'vec2 'float 4
                                         #:name "unbatched-sprite-vertices")))
         (texcoord-buffer
          (delay
            (make-streaming-typed-buffer 'vec2 'float 4
                                         #:name "unbatched-sprite-texcoords")))
         (index-buffer
          (delay
            (make-typed-buffer #:name "unbatched-sprite-indices"
                               #:type 'scalar
                               #:component-type 'unsigned-int
                               #:buffer (make-buffer (u32vector 0 3 2 0 2 1)
                                                     #:target 'index))))
         (vertex-array
          (delay
            (make-vertex-array #:indices (force index-buffer)
                               #:attributes
                               `((0 . ,(force position-buffer))
                                 (1 . ,(force texcoord-buffer))))))
         (mvp (make-null-matrix4)))
    (lambda (texture region world-matrix blend-mode shader texture-region)
      (with-mapped-typed-buffer (force position-buffer)
        (let* ((x1 (rect-x region))
               (y1 (rect-y region))
               (x2 (+ x1 (rect-width region)))
               (y2 (+ y1 (rect-height region)))
               (bv (typed-buffer-data (force position-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-typed-buffer (force texcoord-buffer)
        ;; Texture origin is at the top-left, so we need to flip the Y
        ;; coordinate relative to the vertices.
        (let ((s1 (rect-x texture-region))
              (t1 (rect-y texture-region))
              (s2 (+ (rect-x texture-region) (rect-width texture-region)))
              (t2 (+ (rect-y texture-region) (rect-height texture-region)))
              (bv (typed-buffer-data (force texcoord-buffer))))
          (f32vector-set! bv 0 s1)
          (f32vector-set! bv 1 t2)
          (f32vector-set! bv 2 s2)
          (f32vector-set! bv 3 t2)
          (f32vector-set! bv 4 s2)
          (f32vector-set! bv 5 t1)
          (f32vector-set! bv 6 s1)
          (f32vector-set! bv 7 t1)))
      (with-blend-mode blend-mode
        (with-texture 0 texture
          (gpu-apply shader (force vertex-array)
                     #:mvp (if world-matrix
                               (begin
                                 (matrix4-mult! mvp world-matrix
                                                (current-projection))
                                 mvp)
                               (current-projection))))))))


;;;
;;; 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 set-sprite-batch-capacity!)
  (index-buffer sprite-batch-index-buffer set-sprite-batch-index-buffer!)
  (position-buffer sprite-batch-position-buffer set-sprite-batch-position-buffer!)
  (texture-buffer sprite-batch-texture-buffer set-sprite-batch-texture-buffer!)
  (vertex-array sprite-batch-vertex-array set-sprite-batch-vertex-array!))

(define (init-sprite-batch batch capacity)
  (let* ((index (make-streaming-typed-buffer 'scalar
                                             'unsigned-int
                                             (* capacity 6)
                                             #:target 'index))
         (stride 16) ; 4 f32s, 2 for vertex, 2 for texcoord
         (buffer (make-buffer #f
                              #:name "sprite batch buffer"
                              #:length (* capacity stride 4)
                              #:stride stride
                              #:usage 'stream))
         (pos (make-typed-buffer #:name "sprite batches vertices"
                                 #:buffer buffer
                                 #:type 'vec2
                                 #:component-type 'float
                                 #:length (* capacity 4)))
         (tex (make-typed-buffer #:name "batched-sprite-vertices"
                                 #:buffer buffer
                                 #:type 'vec2
                                 #:component-type 'float
                                 #:length (* capacity 4)
                                 #:offset (/ stride 2)))
         (va (make-vertex-array #:indices index
                                #:attributes `((0 . ,pos) (1 . ,tex)))))
    (set-sprite-batch-capacity! batch capacity)
    (set-sprite-batch-index-buffer! batch index)
    (set-sprite-batch-position-buffer! batch pos)
    (set-sprite-batch-texture-buffer! batch tex)
    (set-sprite-batch-vertex-array! batch va)))

(define (make-sprite-batch capacity)
  "Make a sprite batch that can hold CAPACITY sprites."
  (let ((batch (%make-sprite-batch #f #f #f 0 0 #f #f #f #f)))
    (init-sprite-batch batch capacity)
    batch))

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

(define (double-sprite-batch-size! batch)
  (let* ((old-index (sprite-batch-index-buffer batch))
         (old-verts (sprite-batch-position-buffer batch))
         (old-index-data (typed-buffer-data old-index))
         (old-vertex-data (typed-buffer-data old-verts)))
    (unmap-typed-buffer! old-index)
    (unmap-typed-buffer! old-verts)
    (init-sprite-batch batch (* (sprite-batch-capacity batch) 2))
    (sprite-batch-begin! batch)
    (let ((new-index (sprite-batch-index-buffer batch))
          (new-verts (sprite-batch-position-buffer batch)))
      (define (copy from to)
        (bytevector-copy! from 0
                          (typed-buffer-data to) 0
                          (bytevector-length from)))
      (copy old-index-data new-index)
      (copy old-vertex-data new-verts))))

(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-typed-buffer! (sprite-batch-index-buffer batch))
  (map-typed-buffer! (sprite-batch-position-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 0 (sprite-batch-texture batch)
        (unmap-typed-buffer! (sprite-batch-index-buffer batch))
        (unmap-typed-buffer! (sprite-batch-position-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 ((world1 (vec2 0.0 0.0))
        (world2 (vec2 0.0 0.0))
        (world3 (vec2 0.0 0.0))
        (world4 (vec2 0.0 0.0))
        (offset-bv (make-u32vector 1)))
    (define (set-offset offset)
      (u32vector-set! offset-bv 0 offset))
    (define (offset)
      (u32vector-ref offset-bv 0))
    (lambda (batch texture region world-matrix blend-mode
                   shader texture-region)
      ;; 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* ((indices (typed-buffer-data (sprite-batch-index-buffer batch)))
               (vertices (typed-buffer-data (sprite-batch-position-buffer batch)))
               (texcoords (typed-buffer-data (sprite-batch-texture-buffer batch)))
               (local-x1 (rect-x region))
               (local-y1 (rect-y region))
               (local-x2 (+ local-x1 (rect-width region)))
               (local-y2 (+ local-y1 (rect-height region)))
               (s1 (rect-x texture-region))
               (t1 (rect-y texture-region))
               (s2 (+ (rect-x texture-region) (rect-width texture-region)))
               (t2 (+ (rect-y texture-region) (rect-height texture-region))))
          (set-vec2! world1 local-x1 local-y1)
          (set-vec2! world2 local-x2 local-y1)
          (set-vec2! world3 local-x2 local-y2)
          (set-vec2! world4 local-x1 local-y2)
          (when world-matrix
            (transform! world-matrix world1)
            (transform! world-matrix world2)
            (transform! world-matrix world3)
            (transform! world-matrix world4))
          ;; Add indices.
          (set-offset (* size 4))
          (let ((index-vertex-offset (offset)))
            (set-offset (* size 6))
            (u32vector-set! indices (offset) index-vertex-offset)
            (u32vector-set! indices (+ (offset) 1) (+ index-vertex-offset 3))
            (u32vector-set! indices (+ (offset) 2) (+ index-vertex-offset 2))
            (u32vector-set! indices (+ (offset) 3) index-vertex-offset)
            (u32vector-set! indices (+ (offset) 4) (+ index-vertex-offset 2))
            (u32vector-set! indices (+ (offset) 5) (+ index-vertex-offset 1)))
          ;; Add vertices.
          (set-offset (* size 16))
          ;; Bottom-left
          (f32vector-set! vertices (offset) (vec2-x world1))
          (f32vector-set! vertices (+ (offset) 1) (vec2-y world1))
          ;; Bottom-right
          (f32vector-set! vertices (+ (offset) 4) (vec2-x world2))
          (f32vector-set! vertices (+ (offset) 5) (vec2-y world2))
          ;; Top-right
          (f32vector-set! vertices (+ (offset) 8) (vec2-x world3))
          (f32vector-set! vertices (+ (offset) 9) (vec2-y world3))
          ;; Top-left
          (f32vector-set! vertices (+ (offset) 12) (vec2-x world4))
          (f32vector-set! vertices (+ (offset) 13) (vec2-y world4))
          ;; Add texture coordinates.
          ;; Bottom-left
          (f32vector-set! texcoords (+ (offset) 2) s1)
          (f32vector-set! texcoords (+ (offset) 3) t2)
          ;; Bottom-right
          (f32vector-set! texcoords (+ (offset) 6) s2)
          (f32vector-set! texcoords (+ (offset) 7) t2)
          ;; Top-right
          (f32vector-set! texcoords (+ (offset) 10) s2)
          (f32vector-set! texcoords (+ (offset) 11) t1)
          ;; Top-left
          (f32vector-set! texcoords (+ (offset) 14) s1)
          (f32vector-set! texcoords (+ (offset) 15) t1)
          (set-sprite-batch-size! batch (1+ size)))))))

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

(define (draw-sprite-batched texture region world-matrix blend-mode shader
                             texture-region)
  (sprite-batch-add! (force %batch) texture region world-matrix blend-mode
                     shader texture-region))

(define-syntax-rule (with-batched-sprites body ...)
  "Use batched rendering for all draw-sprite calls within BODY."
  (if *batch?*
      (begin 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* texture rect matrix #:key
                       (blend-mode 'alpha)
                       (texcoords (texture-gl-tex-rect texture))
                       (shader (force default-shader)))
  (if *batch?*
      (draw-sprite-batched texture rect matrix blend-mode
                           shader texcoords)
      (draw-sprite-unbatched texture rect matrix blend-mode
                             shader texcoords)))

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

(define draw-sprite
  (let ((matrix (make-null-matrix4)))
    (lambda* (texture
              position
              #:key
              (origin %null-vec2)
              (scale %default-scale)
              (rotation 0.0)
              (blend-mode 'alpha)
              (rect (texture-gl-rect texture))
              (shader (force default-shader)))
      "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.

By default, alpha blending is used but can be changed by specifying
BLEND-MODE.

Advanced users may pass SHADER to change the way the sprite is
rendered entirely."
      (matrix4-2d-transform! matrix
                             #:origin origin
                             #:position position
                             #:rotation rotation
                             #:scale scale)
      (draw-sprite* texture rect matrix
                    #:blend-mode blend-mode
                    #:shader shader))))


;;;
;;; Nine Patches
;;;

(define draw-nine-patch*
  (let ((%rect (make-rect 0.0 0.0 0.0 0.0))
        (texcoords (make-rect 0.0 0.0 0.0 0.0)))
    (lambda* (texture
              rect
              matrix
              #:key
              (margin 0.0)
              (top-margin margin)
              (bottom-margin margin)
              (left-margin margin)
              (right-margin margin)
              (blend-mode 'alpha)
              (shader (force default-shader)))
      (let* ((x (rect-x rect))
             (y (rect-y rect))
             (w (rect-width rect))
             (h (rect-height rect))
             (border-x1 x)
             (border-y1 y)
             (border-x2 (+ x w))
             (border-y2 (+ y h))
             (fill-x1 (+ border-x1 left-margin))
             (fill-y1 (+ border-y1 bottom-margin))
             (fill-x2 (- border-x2 right-margin))
             (fill-y2 (- border-y2 top-margin))
             (prect (texture-gl-rect texture))
             (trect (texture-gl-tex-rect texture))
             (tw (rect-width prect))
             (th (rect-height prect))
             (border-s1 (rect-x trect))
             (border-t1 (rect-y trect))
             (border-s2 (+ (rect-x trect) (rect-width trect)))
             (border-t2 (+ (rect-y trect) (rect-height trect)))
             (fill-s1 (+ border-s1 (/ left-margin tw)))
             (fill-t1 (+ border-t1 (/ top-margin th)))
             (fill-s2 (- border-s2 (/ right-margin tw)))
             (fill-t2 (- border-t2 (/ bottom-margin th))))
        (define (draw-piece x1 y1 x2 y2 s1 t1 s2 t2)
          (set-rect-x! %rect x1)
          (set-rect-y! %rect y1)
          (set-rect-width! %rect (- x2 x1))
          (set-rect-height! %rect (- y2 y1))
          (set-rect-x! texcoords s1)
          (set-rect-y! texcoords t1)
          (set-rect-width! texcoords (- s2 s1))
          (set-rect-height! texcoords (- t2 t1))
          (draw-sprite* texture %rect matrix
                        #:texcoords texcoords
                        #:blend-mode blend-mode
                        #:shader shader))
        (with-batched-sprites
         ;; bottom-left
         (draw-piece border-x1 border-y1 fill-x1 fill-y1
                     border-s1 fill-t2 fill-s1 border-t2)
         ;; bottom-center
         (draw-piece fill-x1 border-y1 fill-x2 fill-y1
                     fill-s1 fill-t2 fill-s2 border-t2)
         ;; bottom-right
         (draw-piece fill-x2 border-y1 border-x2 fill-y1
                     fill-s2 fill-t2 border-s2 border-t2)
         ;; center-left
         (draw-piece border-x1 fill-y1 fill-x1 fill-y2
                     border-s1 fill-t2 fill-s1 fill-t1)
         ;; center
         (draw-piece fill-x1 fill-y1 fill-x2 fill-y2
                     fill-s1 fill-t2 fill-s2 fill-t1)
         ;; center-right
         (draw-piece fill-x2 fill-y1 border-x2 fill-y2
                     fill-s2 fill-t2 border-s2 fill-t1)
         ;; top-left
         (draw-piece border-x1 fill-y2 fill-x1 border-y2
                     border-s1 border-t1 fill-s1 fill-t1)
         ;; top-center
         (draw-piece fill-x1 fill-y2 fill-x2 border-y2
                     fill-s1 border-t1 fill-s2 fill-t1)
         ;; top-right
         (draw-piece fill-x2 fill-y2 border-x2 border-y2
                     fill-s2 border-t1 border-s2 fill-t1))))))

(define draw-nine-patch
  (let ((position (vec2 0.0 0.0))
        (%rect (make-rect 0.0 0.0 0.0 0.0))
        (matrix (make-null-matrix4)))
    (lambda* (texture
              rect
              #:key
              (margin 0.0)
              (top-margin margin) (bottom-margin margin)
              (left-margin margin) (right-margin margin)
              (origin %null-vec2)
              (rotation 0.0)
              (scale %default-scale)
              (blend-mode 'alpha)
              (shader (force default-shader)))
      "Draw a \"nine patch\" sprite.  A nine patch sprite renders
TEXTURE on the rectangular area RECT whose stretchable areas are
defined by the given margin measurements.  The corners are never
stretched, the left and right edges may be stretched vertically, the
top and bottom edges may be stretched horizontally, and the center may
be stretched in both directions.  This rendering technique is
particularly well suited for resizable windows and buttons in
graphical user interfaces.

MARGIN specifies the margin size for all sides of the nine patch.  To
make margins of differing sizes, the TOP-MARGIN, BOTTOM-MARGIN,
LEFT-MARGIN, and RIGHT-MARGIN arguments may be used."
      (set-rect-x! %rect 0.0)
      (set-rect-y! %rect 0.0)
      (set-rect-width! %rect (rect-width rect))
      (set-rect-height! %rect (rect-height rect))
      (set-vec2-x! position (rect-x rect))
      (set-vec2-y! position (rect-y rect))
      (matrix4-2d-transform! matrix
                             #:origin origin
                             #:position position
                             #:rotation rotation
                             #:scale scale)
      (draw-nine-patch* texture %rect matrix
                        #:top-margin top-margin
                        #:bottom-margin bottom-margin
                        #:left-margin left-margin
                        #:right-margin right-margin
                        #:blend-mode blend-mode
                        #:shader shader))))