Add support for sprites that use texture regions and automatic drawing to a batch.

1 files changed, 104 insertions, 32 deletions

diff --git a/2d/sprite.scm b/2d/sprite.scm
index b8c1472..64a0240 100644
--- a/2d/sprite.scm
+++ b/2d/sprite.scm
@@ -23,6 +23,7 @@
 ;;; Code:
 
 (define-module (2d sprite)
+  #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-42)
   #:use-module (figl gl)
@@ -49,7 +50,7 @@
             split-texture
             make-sprite
             sprite?
-            sprite-texture
+            sprite-drawable
             sprite-position
             set-sprite-position!
             sprite-scale
@@ -220,12 +221,13 @@ size."
   (s float)
   (t float))
 
-;; The <sprite> object represents a texture with a given position, scale,
+;; The <sprite> object represents a drawable object (texture,
+;; texture-region, animation, etc.) with a given position, scale,
 ;; rotation, and color.
 (define-record-type <sprite>
-  (%make-sprite texture position scale rotation color anchor vertices)
+  (%make-sprite drawable position scale rotation color anchor vertices)
   sprite?
-  (texture sprite-texture)
+  (drawable sprite-drawable)
   (position sprite-position set-sprite-position!)
   (scale sprite-scale set-sprite-scale!)
   (rotation sprite-rotation set-sprite-rotation!)
@@ -233,11 +235,11 @@ size."
   (anchor sprite-anchor set-sprite-anchor!)
   (vertices sprite-vertices set-sprite-vertices!))
 
-(define* (make-sprite texture #:optional #:key (position #(0 0)) (scale #(1 1))
+(define* (make-sprite drawable #:optional #:key (position #(0 0)) (scale #(1 1))
                       (rotation 0) (color '(1 1 1)) (anchor 'center))
   "Makes a new sprite object."
   (let ((vertices (make-packed-array sprite-vertex 4)))
-    (%make-sprite texture position scale rotation color anchor vertices)))
+    (%make-sprite drawable position scale rotation color anchor vertices)))
 
 (define* (load-sprite filename #:optional #:key (position #(0 0)) (scale #(1 1))
                       (rotation 0) (color '(1 1 1)) (anchor 'center))
@@ -245,49 +247,119 @@ size."
   (make-sprite (load-texture filename) #:position position #:scale scale
                #:rotation rotation #:color color #:anchor anchor))
 
+(define (sprite-texture sprite)
+  "Returns the texture for the sprite's drawable object."
+  (let ((drawable (sprite-drawable sprite)))
+    (cond ((texture? drawable)
+           drawable)
+          ((texture-region? drawable)
+           (texture-region-texture drawable)))))
+
+(define (sprite-texture-coords sprite)
+  "Returns the texture coordinates for the drawable object."
+  (let ((drawable (sprite-drawable sprite)))
+    (cond ((texture? drawable)
+           '(0 0 1 1))
+          ((texture-region? drawable)
+           (list (texture-region-u drawable)
+                 (texture-region-v drawable)
+                 (texture-region-u2 drawable)
+                 (texture-region-v2 drawable))))))
+
+(define (sprite-drawable-size sprite)
+  "Returns the size of the sprite drawable as a vector"
+  (let ((drawable (sprite-drawable sprite)))
+    (cond ((texture? drawable)
+           (vector (texture-width drawable)
+                   (texture-height drawable)))
+          ((texture-region? drawable)
+           (vector (texture-region-width drawable)
+                   (texture-region-height drawable))))))
+
 (define (sprite-anchor-vector sprite)
+  "Returns a vector of the coordinates for the center point of a
+sprite."
   (let ((anchor (sprite-anchor sprite)))
     (cond
      ((eq? anchor 'center)
-      (let ((texture (sprite-texture sprite)))
-        (vector (/ (texture-width texture) 2)
-                (/ (texture-height texture) 2))))
+      (let ((size (sprite-drawable-size sprite)))
+        (vector (/ (vx size) 2)
+                (/ (vy size) 2))))
      (else anchor))))
 
 (define (update-sprite-vertices sprite)
+  "Rebuilds the internal vertex array."
   (let* ((vertices (sprite-vertices sprite))
          (texture (sprite-texture sprite))
+         (size (sprite-drawable-size sprite))
          (anchor (sprite-anchor-vector sprite))
+         (tex-coords (sprite-texture-coords sprite))
          (x (- (vx anchor)))
          (y (- (vy anchor)))
-         (x2 (+ x (texture-width texture)))
-         (y2 (+ y (texture-width texture))))
+         (x2 (+ x (vx size)))
+         (y2 (+ y (vy size)))
+         (u (first tex-coords))
+         (v (second tex-coords))
+         (u2 (third tex-coords))
+         (v2 (fourth tex-coords)))
     (pack vertices 0 sprite-vertex
           x y
           1 1 1 1
-          0 0)
+          u v)
     (pack vertices 1 sprite-vertex
           x2 y
           1 1 1 1
-          1 0)
+          u2 v)
     (pack vertices 2 sprite-vertex
           x2 y2
           1 1 1 1
-          1 1)
+          u2 v2)
     (pack vertices 3 sprite-vertex
           x y2
           1 1 1 1
-          0 1)))
+          u v2)))
 
 (define (draw-sprite sprite)
-  "Renders a sprite."
+  "Renders a sprite. A sprite batch will be used if one is currently
+bound."
+  (if *sprite-batch*
+      (draw-sprite-batched sprite)
+      (draw-sprite-vertex-array sprite)))
+
+(define (draw-sprite-batched sprite)
+  "Adds a sprite to the batch."
+  (let ((texture (sprite-texture sprite))
+        (pos (sprite-position sprite))
+        (size (sprite-drawable-size sprite))
+        (scale (sprite-scale sprite))
+        (anchor (sprite-anchor-vector sprite))
+        (tex-coords (sprite-texture-coords sprite)))
+    (%sprite-batch-draw *sprite-batch*
+                        texture
+                        (- (vx pos) (vx anchor))
+                        (- (vy pos) (vy anchor))
+                        (vx size)
+                        (vy size)
+                        #:rotation (sprite-rotation sprite)
+                        #:scale-x (vx scale)
+                        #:scale-y (vy scale)
+                        #:u (first tex-coords)
+                        #:v (second tex-coords)
+                        #:u2 (third tex-coords)
+                        #:v2 (fourth tex-coords))))
+
+(define (draw-sprite-vertex-array sprite)
+  "Renders a sprite using its internal vertex array."
   (update-sprite-vertices sprite)
   (let* ((texture (sprite-texture sprite))
-         (width (texture-width texture))
-         (height (texture-height texture))
          (pos (sprite-position sprite))
          (scale (sprite-scale sprite))
-         (vertices (sprite-vertices sprite)))
+         (vertices (sprite-vertices sprite))
+         (struct-size (packed-struct-size sprite-vertex))
+         (x-offset (packed-struct-offset sprite-vertex x))
+         (r-offset (packed-struct-offset sprite-vertex r))
+         (s-offset (packed-struct-offset sprite-vertex s))
+         (pointer-type (tex-coord-pointer-type float)))
     (with-gl-push-matrix
       (gl-translate (vx pos) (vy pos) 0)
       (gl-rotate (sprite-rotation sprite) 0 0 1)
@@ -297,21 +369,23 @@ size."
       (gl-enable-client-state (enable-cap color-array))
       (gl-enable-client-state (enable-cap texture-coord-array))
       (with-gl-bind-texture (texture-target texture-2d) (texture-id texture)
-        (set-gl-vertex-array (vertex-pointer-type float)
+        (set-gl-vertex-array pointer-type
                              vertices
                              2
-                             #:stride (packed-struct-size sprite-vertex)
-                             #:offset (packed-struct-offset sprite-vertex x))
-        (set-gl-color-array (color-pointer-type float)
+                             #:stride struct-size
+                             #:offset x-offset)
+        (set-gl-color-array pointer-type
                             vertices
                             4
-                            #:stride (packed-struct-size sprite-vertex)
-                            #:offset (packed-struct-offset sprite-vertex r))
-        (set-gl-texture-coordinates-array (tex-coord-pointer-type float)
+                            #:stride struct-size
+                            #:offset r-offset)
+        (set-gl-texture-coordinates-array pointer-type
                                           vertices
-                                          #:stride (packed-struct-size sprite-vertex)
-                                          #:offset (packed-struct-offset sprite-vertex s))
-        (gl-draw-arrays (begin-mode quads) 0 (packed-array-length vertices sprite-vertex)))
+                                          #:stride struct-size
+                                          #:offset s-offset)
+        (gl-draw-arrays (begin-mode quads)
+                        0
+                        (packed-array-length vertices sprite-vertex)))
       (gl-disable-client-state (enable-cap texture-coord-array))
       (gl-disable-client-state (enable-cap color-array))
       (gl-disable-client-state (enable-cap vertex-array)))))
@@ -344,7 +418,7 @@ size."
   (apply %sprite-batch-draw *sprite-batch* args))
 
 (define* (%sprite-batch-draw batch texture x y width height
-                            #:optional #:key (center-x 0) (center-y 0)
+                            #:optional #:key
                             (scale-x 1) (scale-y 1) (rotation 0)
                             (u 0) (v 0) (u2 1) (v2 1))
   "Adds a textured quad to the sprite batch."
@@ -356,8 +430,6 @@ size."
   ;; Add 4 new vertices.
   (let ((base (* 4 (sprite-batch-size batch)))
         (vertices (sprite-batch-vertices batch))
-        (x (- x center-x))
-        (y (- y center-y))
         (x2 (+ x width))
         (y2 (+ y height)))
     (pack vertices base sprite-vertex