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
            with-batched-sprites
            draw-nine-patch))

(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* ((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))))))
         (tmp-matrix (make-null-matrix4))
         (mvp (make-null-matrix4))
         (position (vec2 0 0)))
    (lambda (texture region scale rotation blend-mode shader texture-region)
      (with-mapped-typed-buffer (force position-buffer)
        (let* ((x1 0)
               (y1 0)
               (x2 (rect-width region))
               (y2 (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)
        (let ((s1 (rect-left texture-region))
              (t1 (rect-bottom texture-region))
              (s2 (rect-right texture-region))
              (t2 (rect-top texture-region))
              (bv (typed-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))
      (set-vec2-x! position (rect-x region))
      (set-vec2-y! position (rect-y region))
      (matrix4-translate! tmp-matrix position)
      (matrix4-mult! mvp mvp tmp-matrix)
      (matrix4-mult! mvp mvp (current-projection))
      (with-blend-mode blend-mode
        (with-texture 0 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 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))
         (pos (make-streaming-typed-buffer 'vec2 'float (* capacity 4)
                                           #:name "batched-sprite-vertices"))
         (tex (make-streaming-typed-buffer 'vec2 'float (* capacity 4)
                                           #:name "batched-sprite-vertices"))
         (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-tex (sprite-batch-texture-buffer batch)))
    (unmap-typed-buffer! old-index)
    (unmap-typed-buffer! old-verts)
    (unmap-typed-buffer! old-tex)
    (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))
          (new-tex (sprite-batch-texture-buffer batch)))
      (define (copy from to)
        (bytevector-copy! (typed-buffer-data from) 0
                          (typed-buffer-data to) 0
                          (bytevector-length (typed-buffer-data from))))
      (copy old-index new-index)
      (copy old-verts new-verts)
      (copy old-tex new-tex))))

(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))
  (map-typed-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 0 (sprite-batch-texture batch)
        (unmap-typed-buffer! (sprite-batch-index-buffer batch))
        (unmap-typed-buffer! (sprite-batch-position-buffer batch))
        (unmap-typed-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))
        (position (vec2 0.0 0.0))
        (world1 (vec2 0.0 0.0))
        (world2 (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 scale rotation 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)))
               (rx (rect-x region))
               (ry (rect-y region))
               (local-x1 0.0)
               (local-y1 0.0)
               (local-x2 (rect-width region))
               (local-y2 (rect-height region))
               (s1 (rect-left texture-region))
               (t1 (rect-bottom texture-region))
               (s2 (rect-right texture-region))
               (t2 (rect-top texture-region)))
          (if (or rotation scale)
              (begin
                (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))
                (set-vec2-x! position rx)
                (set-vec2-y! position ry)
                (matrix4-translate! tmp-matrix position)
                (matrix4-mult! matrix matrix tmp-matrix)
                (set-vec2-x! world1 local-x1)
                (set-vec2-y! world1 local-y1)
                (set-vec2-x! world2 local-x2)
                (set-vec2-y! world2 local-y2)
                (transform! matrix world1)
                (transform! matrix world2))
              (begin
                (set-vec2-x! world1 (+ local-x1 rx))
                (set-vec2-y! world1 (+ local-y1 ry))
                (set-vec2-x! world2 (+ local-x2 rx))
                (set-vec2-y! world2 (+ local-y2 ry))))
          (let ((world-x1 (vec2-x world1))
                (world-y1 (vec2-y world1))
                (world-x2 (vec2-x world2))
                (world-y2 (vec2-y world2)))
            ;; 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 8)) ;; 4 vertices, 2 floats per vertex
            ;; Bottom-left
            (f32vector-set! vertices (offset) world-x1)
            (f32vector-set! vertices (+ (offset) 1) world-y1)
            ;; Bottom-right
            (f32vector-set! vertices (+ (offset) 2) world-x2)
            (f32vector-set! vertices (+ (offset) 3) world-y1)
            ;; Top-right
            (f32vector-set! vertices (+ (offset) 4) world-x2)
            (f32vector-set! vertices (+ (offset) 5) world-y2)
            ;; Top-left
            (f32vector-set! vertices (+ (offset) 6) world-x1)
            (f32vector-set! vertices (+ (offset) 7) world-y2)
            ;; Add texture coordinates.
            (set-offset (* size 8))
            ;; Bottom-left
            (f32vector-set! texcoords (offset) s1)
            (f32vector-set! texcoords (+ (offset) 1) t1)
            ;; Bottom-right
            (f32vector-set! texcoords (+ (offset) 2) s2)
            (f32vector-set! texcoords (+ (offset) 3) t1)
            ;; Top-right
            (f32vector-set! texcoords (+ (offset) 4) s2)
            (f32vector-set! texcoords (+ (offset) 5) t2)
            ;; Top-left
            (f32vector-set! texcoords (+ (offset) 6) s1)
            (f32vector-set! texcoords (+ (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 region
                             scale rotation blend-mode shader
                             texture-region)
  (sprite-batch-add! (force %batch) texture region
                     scale rotation 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 %default-texture-region (make-rect 0.0 0.0 1.0 1.0))

(define draw-sprite
  (let ((rect (make-rect 0.0 0.0 0.0 0.0)))
    (lambda* (texture region #:key
                      scale rotation (blend-mode 'alpha)
                      texture-region
                      (shader (force default-shader)))
      "Draw TEXTURE over the area defined by the rect REGION.  If
TEXTURE-REGION is specified, the subset of the texture defined by it
will be drawn rather than the entire texture.  ROTATION specifies by
how many radians the sprite will be rotated.  SCALE specifies the
scaling factor.  By default, alpha blending is used but can be changed
by setting BLEND-MODE.  Finally, advanced users may pass SHADER to
change the way the sprite is rendered entirely."
      (let ((region (if (vec2? region)
                        (begin
                          (rect-move-vec2! rect region)
                          (set-rect-width! rect (texture-width texture))
                          (set-rect-height! rect (texture-height texture))
                          rect)
                        region))
            (texture-region (or texture-region %default-texture-region)))
        (if *batch?*
            (draw-sprite-batched texture region
                                 scale rotation blend-mode shader
                                 texture-region)
            (draw-sprite-unbatched texture region
                                   scale rotation blend-mode shader
                                   texture-region))))))


;;;
;;; Nine Patches
;;;

(define draw-nine-patch
  (let ((rect (make-rect 0.0 0.0 0.0 0.0))
        (trect (make-rect 0.0 0.0 0.0 0.0)))
    (lambda* (texture region #:key (margin 0)
                      (top-margin margin) (bottom-margin margin)
                      (left-margin margin) (right-margin margin)
                      (texture-region %default-texture-region)
                      scale rotation (blend-mode 'alpha)
                      (shader (force default-shader)))
      "Draw a \"nine patch\" sprite.  A nine patch sprite renders
TEXTURE as a WIDTH x HEIGHT rectangle 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."
      (let* ((w (rect-width region))
             (h (rect-height region))
             (border-x1 (rect-left region))
             (border-y1 (rect-bottom region))
             (border-x2 (rect-right region))
             (border-y2 (rect-top region))
             (fill-x1 (+ border-x1 left-margin))
             (fill-y1 (+ border-y1 bottom-margin))
             (fill-x2 (- border-x2 right-margin))
             (fill-y2 (- border-y2 top-margin))
             (tw (texture-width texture))
             (th (texture-width texture))
             (border-s1 (rect-left texture-region))
             (border-t1 (rect-bottom texture-region))
             (border-s2 (rect-right texture-region))
             (border-t2 (rect-top texture-region))
             (fill-s1 (+ border-s1 (/ left-margin tw)))
             (fill-t1 (+ border-t1 (/ bottom-margin th)))
             (fill-s2 (- border-s2 (/ right-margin tw)))
             (fill-t2 (- border-t2 (/ top-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! trect s1)
          (set-rect-y! trect t1)
          (set-rect-width! trect (- s2 s1))
          (set-rect-height! trect (- t2 t1))
          (draw-sprite texture rect
                       #:texture-region trect
                       #:scale scale
                       #:rotation rotation
                       #:blend-mode blend-mode
                       #:shader shader))
        (with-batched-sprites
         ;; bottom-left
         (draw-piece border-x1 border-y1 fill-x1 fill-y1
                     border-s1 border-t1 fill-s1 fill-t1)
         ;; bottom-center
         (draw-piece fill-x1 border-y1 fill-x2 fill-y1
                     fill-s1 border-t1 fill-s2 fill-t1)
         ;; dbottom-right
         (draw-piece fill-x2 border-y1 border-x2 fill-y1
                     fill-s2 border-t1 border-s2 fill-t1)
         ;; center-left
         (draw-piece border-x1 fill-y1 fill-x1 fill-y2
                     border-s1 fill-t1 fill-s1 fill-t2)
         ;; center
         (draw-piece fill-x1 fill-y1 fill-x2 fill-y2
                     fill-s1 fill-t1 fill-s2 fill-t2)
         ;; center-right
         (draw-piece fill-x2 fill-y1 border-x2 fill-y2
                     fill-s2 fill-t1 border-s2 fill-t2)
         ;; top-left
         (draw-piece border-x1 fill-y2 fill-x1 border-y2
                     border-s1 fill-t2 fill-s1 border-t2)
         ;; top-center
         (draw-piece fill-x1 fill-y2 fill-x2 border-y2
                     fill-s1 fill-t2 fill-s2 border-t2)
         ;; top-right
         (draw-piece fill-x2 fill-y2 border-x2 border-y2
                     fill-s2 fill-t2 border-s2 border-t2))))))