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))))))
         (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)
        (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)))
      (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))
         (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))
         (old-index-data (typed-buffer-data old-index))
         (old-verts-data (typed-buffer-data old-verts))
         (old-tex-data (typed-buffer-data old-tex)))
    (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! from 0
                          (typed-buffer-data to) 0
                          (bytevector-length from)))
      (copy old-index-data new-index)
      (copy old-verts-data new-verts)
      (copy old-tex-data 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 ((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-left texture-region))
               (t1 (rect-bottom texture-region))
               (s2 (rect-right texture-region))
               (t2 (rect-top texture-region)))
          (set-vec2-x! world1 local-x1)
          (set-vec2-y! world1 local-y1)
          (set-vec2-x! world2 local-x2)
          (set-vec2-y! world2 local-y1)
          (set-vec2-x! world3 local-x2)
          (set-vec2-y! world3 local-y2)
          (set-vec2-x! world4 local-x1)
          (set-vec2-y! world4 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 8)) ;; 4 vertices, 2 floats per vertex
          ;; Bottom-left
          (f32vector-set! vertices (offset) (vec2-x world1))
          (f32vector-set! vertices (+ (offset) 1) (vec2-y world1))
          ;; Bottom-right
          (f32vector-set! vertices (+ (offset) 2) (vec2-x world2))
          (f32vector-set! vertices (+ (offset) 3) (vec2-y world2))
          ;; Top-right
          (f32vector-set! vertices (+ (offset) 4) (vec2-x world3))
          (f32vector-set! vertices (+ (offset) 5) (vec2-y world3))
          ;; Top-left
          (f32vector-set! vertices (+ (offset) 6) (vec2-x world4))
          (f32vector-set! vertices (+ (offset) 7) (vec2-y world4))
          ;; 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 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 texture-gl-size
  (@@ (chickadee render texture) texture-gl-size))
(define texture-region-gl-size
  (@@ (chickadee render texture) texture-region-gl-size))
(define texture-region-gl-rect
  (@@ (chickadee render texture) texture-region-gl-rect))

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

(define draw-sprite
  (let ((rect (make-rect 0.0 0.0 0.0 0.0))
        (tmp-matrix (make-null-matrix4))
        (%matrix (make-null-matrix4)))
    (lambda* (texture
              region
              #:key
              (scale 1.0)
              (rotation 0)
              matrix
              (offset %default-offset)
              (blend-mode 'alpha)
              (texcoords
               (if (texture-region? texture)
                   (texture-region-gl-rect texture)
                   %default-texcoords))
              (shader (force default-shader)))
      "Draw TEXTURE over the area defined by the rect REGION.  Instead
of a rect, REGION may be a vec2 representing the position of the
sprite, in which case the width and height of the sprite corresponds
to the size of the texture.  TEXTURE may be a texture or a texture
region.

ROTATION specifies the angle to rotate the sprite, in radians.  SCALE
specifies the scaling factor.  No scaling or rotation is applied by
default.  Alternatively, MATRIX may be specified, in which case
ROTATION and SCALE are ignored and the given transformation matrix is
used instead.  All transformations are applied relative to the lower
left corner of the sprite by default.  This can be changed by
specifying an OFFSET vector.

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* ((size (if (texture-region? texture)
                       (texture-region-gl-size texture)
                       (texture-gl-size texture)))
             (texture (if (texture-region? texture)
                          (texture-region-texture texture)
                          texture))
             (matrix (cond
                      (matrix matrix) ; user-specified matrix
                      ((or rotation scale) ; compute matrix on-the-fly
                       (matrix4-identity! %matrix)
                       (unless (zero? rotation)
                         (matrix4-rotate-z! tmp-matrix rotation)
                         (matrix4-mult! %matrix %matrix tmp-matrix))
                       (unless (= scale 1.0)
                         (matrix4-scale! tmp-matrix scale)
                         (matrix4-mult! %matrix %matrix tmp-matrix))
                       (matrix4-translate! tmp-matrix region)
                       (matrix4-mult! %matrix %matrix tmp-matrix)
                       %matrix)
                      ;; No transformation needed, in which case we
                      ;; use no matrix at all in order to save cycles
                      ;; and not waste time multiplying against the
                      ;; identity matrix.
                      (else #f))))
        (cond
         ((and (rect? region)
               (not matrix)
               (zero? rotation) ; no rotation
               (= scale 1.0)) ; no scale
          ;; We won't be using a transformation matrix.
          ;; Just apply the offset.
          (set-rect-x! rect (- (rect-x region) (vec2-x offset)))
          (set-rect-y! rect (- (rect-y region) (vec2-y offset)))
          (set-rect-width! rect (rect-width region))
          (set-rect-height! rect (rect-height region)))
         ((rect? region)
          ;; We will be using a transformation matrix, so
          ;; ignore the region's X and Y coordinates as
          ;; those will be accounted for in the
          ;; translation matrix.
          (set-rect-x! rect (- (vec2-x offset)))
          (set-rect-y! rect (- (vec2-y offset)))
          (set-rect-width! rect (rect-width region))
          (set-rect-height! rect (rect-height region)))
         ((and (not matrix)
               (zero? rotation)
               (= scale 1.0))
          ;; No region specified and no transformation
          ;; matrix. Use texture width/height for the
          ;; dimensions of the region.
          (set-rect-x! rect (- (vec2-x region) (vec2-x offset)))
          (set-rect-y! rect (- (vec2-y region) (vec2-y offset)))
          (set-rect-width! rect (f32vector-ref size 0))
          (set-rect-height! rect (f32vector-ref size 1)))
         (else
          ;; No region specified but we will be using a
          ;; transformation matrix.
          (set-rect-x! rect (- (vec2-x offset)))
          (set-rect-y! rect (- (vec2-y offset)))
          (set-rect-width! rect (f32vector-ref size 0))
          (set-rect-height! rect (f32vector-ref size 1))))
        (if *batch?*
            (draw-sprite-batched texture rect matrix blend-mode
                                 shader texcoords)
            (draw-sprite-unbatched texture rect matrix blend-mode
                                   shader texcoords))))))


;;;
;;; 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)
                      (offset %default-offset)
                      (rotation 0)
                      (scale 1.0)
                      matrix
                      (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* ((texcoords (if (texture-region? texture)
                            (texture-region-gl-rect texture)
                            %default-texcoords))
             (texsize (if (texture-region? texture)
                          (texture-region-gl-size texture)
                          (texture-gl-size texture)))
             (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 (f32vector-ref texsize 0))
             (th (f32vector-ref texsize 1))
             (border-s1 (rect-left texcoords))
             (border-t1 (rect-bottom texcoords))
             (border-s2 (rect-right texcoords))
             (border-t2 (rect-top texcoords))
             (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
                       #:texcoords trect
                       #:offset offset
                       #:scale scale
                       #:rotation rotation
                       #:matrix matrix
                       #: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))))))