Split sprite module into 3 modules.

3 files changed, 327 insertions, 251 deletions

diff --git a/2d/animation.scm b/2d/animation.scm
new file mode 100644
index 0000000..fad4828
--- /dev/null
+++ b/2d/animation.scm
@@ -0,0 +1,111 @@
+;;; guile-2d
+;;; Copyright (C) 2013 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; Guile-2d is free software: you can redistribute it and/or modify it
+;;; under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; Guile-2d 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
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Animations represent a sequence of textures and/or texture regions.
+;;
+;;; Code:
+
+(define-module (2d animation)
+  #:use-module (srfi srfi-9)
+  #:use-module (2d texture))
+
+;;;
+;;; Animations
+;;;
+
+;; The <animation> type represents a vector of textures or texture
+;; regions that are to be played in sequence and possibly looped.
+(define-record-type <animation>
+  (make-animation frames duration loop)
+  animation?
+  (frames animation-frames)
+  (duration animation-duration)
+  (loop animation-loop?))
+
+(define (animation-frame animation index)
+  "Returns the frame for the given index."
+  (vector-ref (animation-frames animation) index))
+
+(define (animation-length animation)
+  "Returns the number of frames in the animation"
+  (vector-length (animation-frames animation)))
+
+(export make-animation
+        animation?
+        animation-frames
+        animation-duration
+        animation-loop?
+        animation-frame
+        animation-length)
+
+;; The <animation-state> type encapsulates the state for playing an
+;; animation.
+(define-record-type <animation-state>
+  (%make-animation-state animation frame-index frame-time playing)
+  animation-state?
+  (animation animation-state-animation)
+  (frame-index animation-state-frame-index)
+  (frame-time animation-state-frame-time)
+  (playing animation-state-playing?))
+
+(define (make-animation-state animation)
+  "Creates a new animation state object."
+  (%make-animation-state animation 0 0 #t))
+
+(define (tick-animation-state state)
+  "Increments the frame time for the animation state and determines
+which frame to show. Returns a new animation state object when the
+animation is playing. Otherwise the state passed in is returned."
+  (let ((frame-time (1+ (animation-state-frame-time state)))
+        (frame-index (animation-state-frame-index state))
+        (playing (animation-state-playing? state))
+        (animation (animation-state-animation state)))
+
+    ;; Return the same state object if the animation is not playing.
+    (cond ((not playing)
+           state)
+          ;; Return a new state object with a reset frame-index and
+          ;; frame-time if we've reached the end of the animation.
+          ;; Stops playing the animation if the animation does not
+          ;; loop.
+          ((and playing (= frame-time (animation-duration animation)))
+           (let* ((frame-index (modulo (1+ frame-index)
+                                       (animation-length animation)))
+                  (frame-time 0)
+                  (playing (or (not (= frame-index 0))
+                               (animation-loop? animation))))
+             (%make-animation-state animation frame-index frame-time playing)))
+          ;; Return a new state object with an incremented frame index.
+          (else
+           (%make-animation-state animation frame-index frame-time playing)))))
+
+(define (animation-state-frame state)
+  "Returns the texture or texture region for the state's animation at
+the current frame index."
+  (animation-frame (animation-state-animation state)
+                   (animation-state-frame-index state)))
+
+(export make-animation-state
+        animation-state?
+        animation-state-animation
+        animation-state-frame-index
+        animation-state-frame-time
+        animation-state-playing?
+        animation-state-frame
+        tick-animation-state)
diff --git a/2d/sprite.scm b/2d/sprite.scm
index 53fc961..a4a0719 100644
--- a/2d/sprite.scm
+++ b/2d/sprite.scm
@@ -25,258 +25,14 @@
 (define-module (2d sprite)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-42)
   #:use-module (figl gl)
   #:use-module (figl contrib packed-struct)
   #:use-module ((sdl sdl) #:prefix SDL:)
-  #:use-module (2d vector)
-  #:use-module (2d gl)
+  #:use-module (2d animation)
   #:use-module (2d helpers)
-  #:export (make-texture
-            texture?
-            texture-id
-            texture-width
-            texture-height
-            surface->texture
-            load-texture
-            texture-quad
-            make-texture-region
-            texture-region?
-            texture-region-texture
-            texture-region-width
-            texture-region-height
-            texture-region-u
-            texture-region-v
-            texture-region-u2
-            texture-region-v2
-            split-texture
-            make-animation
-            animation?
-            animation-frames
-            animation-duration
-            animation-loop?
-            animation-frame
-            animation-length
-            make-sprite
-            sprite?
-            sprite-drawable
-            set-sprite-drawable!
-            sprite-position
-            set-sprite-position!
-            sprite-scale
-            set-sprite-scale!
-            sprite-rotation
-            set-sprite-rotation!
-            sprite-color
-            set-sprite-color!
-            sprite-anchor
-            set-sprite-anchor!
-            sprite-vertices
-            set-sprite-vertices!
-            load-sprite
-            draw-sprite
-            make-sprite-batch
-            sprite-batch?
-            sprite-batch-max-size
-            sprite-batch-size
-            set-sprite-batch-size!
-            sprite-batch-texture
-            set-sprite-batch-texture!
-            sprite-batch-vertices
-            sprite-batch-draw
-            with-sprite-batch))
-
-;;;
-;;; Textures
-;;;
-
-;; The <texture> object is a simple wrapper around an OpenGL texture
-;; id.
-(define-record-type <texture>
-  (make-texture id width height)
-  texture?
-  (id texture-id)
-  (width texture-width)
-  (height texture-height))
-
-;; Use a guardian and an after GC hook that ensures that OpenGL
-;; textures are deleted when texture objects are GC'd.
-(define texture-guardian (make-guardian))
-
-(define (reap-textures)
-  (let loop ((texture (texture-guardian)))
-    (when texture
-      ;; When attempting to reap structures upon guile exit, the
-      ;; dynamic pointer to gl-delete-textures becomes invalid. So, we
-      ;; ignore the error and move on.
-      (catch 'misc-error
-        (lambda () (gl-delete-texture (texture-id texture)))
-        (lambda (key . args) #f))
-      (loop (texture-guardian)))))
-
-(add-hook! after-gc-hook reap-textures)
-
-(define (surface-pixel-format surface)
-  "Returns the OpenGL pixel format for a surface. RGB and RGBA formats
-are supported."
-  (case (SDL:surface:depth surface)
-    ((24) (pixel-format* rgb))
-    ((32) (pixel-format* rgba))
-    (else (throw 'unsupported-pixel-format (SDL:surface:depth surface)))))
-
-(define (surface->texture surface)
-  "Translates an SDL surface into an OpenGL texture.
-Currently only works with RGBA format surfaces."
-  (let ((texture-id (gl-generate-texture))
-        (pixel-format (surface-pixel-format surface)))
-    (with-gl-bind-texture (texture-target texture-2d) texture-id
-      (gl-texture-parameter (texture-target texture-2d)
-                            (texture-parameter-name texture-min-filter)
-                            (texture-min-filter linear))
-      (gl-texture-parameter (texture-target texture-2d)
-                            (texture-parameter-name texture-mag-filter)
-                            (texture-mag-filter linear))
-      (gl-texture-image-2d (texture-target texture-2d)
-                           0
-                           pixel-format
-                           (SDL:surface:w surface)
-                           (SDL:surface:h surface)
-                           0
-                           pixel-format
-                           (color-pointer-type unsigned-byte)
-                           (SDL:surface-pixels surface)))
-    (let ((texture (make-texture texture-id
-                                 (SDL:surface:w surface)
-                                 (SDL:surface:h surface))))
-      (texture-guardian texture)
-      texture)))
-
-(define (load-texture filename)
-  "Loads a texture from a file."
-  (surface->texture (SDL:load-image filename)))
-
-(define* (texture-quad texture x y w h #:optional (color '(1 1 1))
-                       (u 0) (v 0) (u2 1) (v2 1))
-  "Renders a textured quad."
-  (let ((x2 (+ x w))
-        (y2 (+ y h)))
-    (with-gl-bind-texture (texture-target texture-2d) (texture-id texture)
-      (gl-begin (primitive-type quads)
-        (apply gl-color color)
-        (gl-texture-coordinates u v)
-        (gl-vertex x y)
-        (gl-texture-coordinates u2 v)
-        (gl-vertex x2 y)
-        (gl-texture-coordinates u2 v2)
-        (gl-vertex x2 y2)
-        (gl-texture-coordinates u v2)
-        (gl-vertex x y2)))))
-
-;;;
-;;; Texture Regions
-;;;
-
-;; Texture regions represent a segment of a texture.
-
-(define-record-type <texture-region>
-  (%make-texture-region texture width height u v u2 v2)
-  texture-region?
-  (texture texture-region-texture)
-  (width texture-region-width)
-  (height texture-region-height)
-  (u texture-region-u)
-  (v texture-region-v)
-  (u2 texture-region-u2)
-  (v2 texture-region-v2))
-
-(define (make-texture-region texture x y width height)
-  "Creates a new texture region given a texture and a pixel region."
-  (let* ((w (texture-width texture))
-         (h (texture-height texture))
-         (u (/ x w))
-         (v (/ y h))
-         (u2 (/ (+ x width) w))
-         (v2 (/ (+ y height) h)))
-    (%make-texture-region texture width height u v u2 v2)))
-
-(define* (split-texture texture width height
-                        #:optional #:key (margin 0) (spacing 0))
-  "Splits a texture into a vector of texture regions of width x height
-size."
-  (define (build-tile tx ty)
-    (let* ((x (+ (* tx (+ width spacing)) margin))
-           (y (+ (* ty (+ height spacing)) margin)))
-      (make-texture-region texture x y width height)))
-
-  (let* ((tw (texture-width texture))
-         (th (texture-height texture))
-         (rows (/ (- tw margin) (+ width spacing)))
-         (columns (/ (- tw margin) (+ height spacing))))
-    (vector-ec (: y rows) (: x columns) (build-tile x y))))
-
-;;;
-;;; Animations
-;;;
-
-;; The <animation> type represents a vector of textures or texture
-;; regions that are to be played in sequence and possibly looped.
-(define-record-type <animation>
-  (make-animation frames duration loop)
-  animation?
-  (frames animation-frames)
-  (duration animation-duration)
-  (loop animation-loop?))
-
-(define (animation-frame animation index)
-  "Returns the frame for the given index."
-  (vector-ref (animation-frames animation) index))
-
-(define (animation-length animation)
-  "Returns the number of frames in the animation"
-  (vector-length (animation-frames animation)))
-
-;; The <animation-state> type encapsulates the state for playing an
-;; animation.
-(define-record-type <animation-state>
-  (%make-animation-state animation frame-index frame-time playing)
-  animation-state?
-  (animation animation-state-animation)
-  (frame-index animation-state-frame-index)
-  (frame-time animation-state-frame-time)
-  (playing animation-state-playing?))
-
-(define (make-animation-state animation)
-  (%make-animation-state animation 0 0 #t))
-
-(define (update-animation-state state)
-  "Increments the frame time for the animation state and determines
-which frame to show. Returns a new animation-state object."
-  (let ((frame-time (1+ (animation-state-frame-time state)))
-        (frame-index (animation-state-frame-index state))
-        (playing (animation-state-playing? state))
-        (animation (animation-state-animation state)))
-
-    ;; Return the same state object if the animation is not playing.
-    (cond ((not playing)
-           state)
-          ;; Return a new state object with a reset frame-index and
-          ;; frame-time if we've reached the end of the animation.
-          ;; Stops playing the animation if the animation does not
-          ;; loop.
-          ((and playing (= frame-time (animation-duration animation)))
-           (let* ((frame-index (modulo (1+ frame-index)
-                                       (animation-length animation)))
-                  (frame-time 0)
-                  (playing (or (not (= frame-index 0))
-                               (animation-loop? animation))))
-             (%make-animation-state animation frame-index frame-time playing)))
-          ;; Return a new state object with an incremented frame index.
-          (else
-           (%make-animation-state animation frame-index frame-time playing)))))
-
-(define (animation-state-frame state)
-  (animation-frame (animation-state-animation state)
-                   (animation-state-frame-index state)))
+  #:use-module (2d texture)
+  #:use-module (2d gl)
+  #:use-module (2d vector))
 
 ;;;
 ;;; Sprites
@@ -284,14 +40,15 @@ which frame to show. Returns a new animation-state object."
 
 ;; Used to build OpenGL vertex array for a sprite.
 (define-packed-struct sprite-vertex
+  ;; Position
   (x float)
   (y float)
-
+  ;; Color
   (r float)
   (g float)
   (b float)
   (a float)
-
+  ;; Texture Coordinates
   (s float)
   (t float))
 
@@ -430,7 +187,7 @@ sprite."
   "Renders a sprite. A sprite batch will be used if one is currently
 bound."
   (when (animation? (sprite-drawable sprite))
-    (let ((state (update-animation-state (sprite-animation-state sprite))))
+    (let ((state (tick-animation-state (sprite-animation-state sprite))))
       (set-sprite-animation-state! sprite state)))
 
   (if *sprite-batch*
@@ -502,6 +259,25 @@ bound."
       (gl-disable-client-state (enable-cap color-array))
       (gl-disable-client-state (enable-cap vertex-array)))))
 
+(export make-sprite
+        sprite?
+        sprite-drawable
+        set-sprite-drawable!
+        sprite-position
+        set-sprite-position!
+        sprite-scale
+        set-sprite-scale!
+        sprite-rotation
+        set-sprite-rotation!
+        sprite-color
+        set-sprite-color!
+        sprite-anchor
+        set-sprite-anchor!
+        sprite-vertices
+        set-sprite-vertices!
+        load-sprite
+        draw-sprite)
+
 ;;;
 ;;; Sprite batches
 ;;;
@@ -619,3 +395,14 @@ batched texture vertices first."
     ...
     (sprite-batch-render batch)
     (set! *sprite-batch* #f)))
+
+(export make-sprite-batch
+        sprite-batch?
+        sprite-batch-max-size
+        sprite-batch-size
+        set-sprite-batch-size!
+        sprite-batch-texture
+        set-sprite-batch-texture!
+        sprite-batch-vertices
+        sprite-batch-draw
+        with-sprite-batch)
diff --git a/2d/texture.scm b/2d/texture.scm
new file mode 100644
index 0000000..b4b28a6
--- /dev/null
+++ b/2d/texture.scm
@@ -0,0 +1,178 @@
+;;; guile-2d
+;;; Copyright (C) 2013 David Thompson <dthompson2@worcester.edu>
+;;;
+;;; Guile-2d is free software: you can redistribute it and/or modify it
+;;; under the terms of the GNU Lesser General Public License as
+;;; published by the Free Software Foundation, either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; Guile-2d 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
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; Textures and texture regions are high level wrappers over OpenGL
+;; textures.
+;;
+;;; Code:
+
+(define-module (2d texture)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-42)
+  #:use-module ((sdl sdl) #:prefix SDL:)
+  #:use-module (figl gl)
+  #:use-module (2d gl))
+
+;;;
+;;; Textures
+;;;
+
+;; The <texture> object is a simple wrapper around an OpenGL texture
+;; id.
+(define-record-type <texture>
+  (make-texture id width height)
+  texture?
+  (id texture-id)
+  (width texture-width)
+  (height texture-height))
+
+;; Use a guardian and an after GC hook that ensures that OpenGL
+;; textures are deleted when texture objects are GC'd.
+(define texture-guardian (make-guardian))
+
+(define (reap-textures)
+  (let loop ((texture (texture-guardian)))
+    (when texture
+      ;; When attempting to reap structures upon guile exit, the
+      ;; dynamic pointer to gl-delete-textures becomes invalid. So, we
+      ;; ignore the error and move on.
+      (catch 'misc-error
+        (lambda () (gl-delete-texture (texture-id texture)))
+        (lambda (key . args) #f))
+      (loop (texture-guardian)))))
+
+(add-hook! after-gc-hook reap-textures)
+
+(define (surface-pixel-format surface)
+  "Returns the OpenGL pixel format for a surface. RGB and RGBA formats
+are supported."
+  (case (SDL:surface:depth surface)
+    ((24) (pixel-format* rgb))
+    ((32) (pixel-format* rgba))
+    (else (throw 'unsupported-pixel-format (SDL:surface:depth surface)))))
+
+(define (surface->texture surface)
+  "Translates an SDL surface into an OpenGL texture.
+Currently only works with RGBA format surfaces."
+  (let ((texture-id (gl-generate-texture))
+        (pixel-format (surface-pixel-format surface)))
+    (with-gl-bind-texture (texture-target texture-2d) texture-id
+      (gl-texture-parameter (texture-target texture-2d)
+                            (texture-parameter-name texture-min-filter)
+                            (texture-min-filter linear))
+      (gl-texture-parameter (texture-target texture-2d)
+                            (texture-parameter-name texture-mag-filter)
+                            (texture-mag-filter linear))
+      (gl-texture-image-2d (texture-target texture-2d)
+                           0
+                           pixel-format
+                           (SDL:surface:w surface)
+                           (SDL:surface:h surface)
+                           0
+                           pixel-format
+                           (color-pointer-type unsigned-byte)
+                           (SDL:surface-pixels surface)))
+    (let ((texture (make-texture texture-id
+                                 (SDL:surface:w surface)
+                                 (SDL:surface:h surface))))
+      (texture-guardian texture)
+      texture)))
+
+(define (load-texture filename)
+  "Loads a texture from a file."
+  (surface->texture (SDL:load-image filename)))
+
+(define* (texture-quad texture x y w h #:optional (color '(1 1 1))
+                       (u 0) (v 0) (u2 1) (v2 1))
+  "Renders a textured quad."
+  (let ((x2 (+ x w))
+        (y2 (+ y h)))
+    (with-gl-bind-texture (texture-target texture-2d) (texture-id texture)
+      (gl-begin (primitive-type quads)
+        (apply gl-color color)
+        (gl-texture-coordinates u v)
+        (gl-vertex x y)
+        (gl-texture-coordinates u2 v)
+        (gl-vertex x2 y)
+        (gl-texture-coordinates u2 v2)
+        (gl-vertex x2 y2)
+        (gl-texture-coordinates u v2)
+        (gl-vertex x y2)))))
+
+(export make-texture
+        load-texture
+        texture?
+        texture-id
+        texture-width
+        texture-height
+        surface->texture
+        texture-quad)
+
+;;;
+;;; Texture Regions
+;;;
+
+;; Texture regions represent a segment of a texture.
+
+(define-record-type <texture-region>
+  (%make-texture-region texture width height u v u2 v2)
+  texture-region?
+  (texture texture-region-texture)
+  (width texture-region-width)
+  (height texture-region-height)
+  (u texture-region-u)
+  (v texture-region-v)
+  (u2 texture-region-u2)
+  (v2 texture-region-v2))
+
+(define (make-texture-region texture x y width height)
+  "Creates a new texture region given a texture and a pixel region."
+  (let* ((w (texture-width texture))
+         (h (texture-height texture))
+         (u (/ x w))
+         (v (/ y h))
+         (u2 (/ (+ x width) w))
+         (v2 (/ (+ y height) h)))
+    (%make-texture-region texture width height u v u2 v2)))
+
+(define* (split-texture texture width height
+                        #:optional #:key (margin 0) (spacing 0))
+  "Splits a texture into a vector of texture regions of width x height
+size."
+  (define (build-tile tx ty)
+    (let* ((x (+ (* tx (+ width spacing)) margin))
+           (y (+ (* ty (+ height spacing)) margin)))
+      (make-texture-region texture x y width height)))
+
+  (let* ((tw (texture-width texture))
+         (th (texture-height texture))
+         (rows (/ (- tw margin) (+ width spacing)))
+         (columns (/ (- tw margin) (+ height spacing))))
+    (vector-ec (: y rows) (: x columns) (build-tile x y))))
+
+(export make-texture-region
+        texture-region?
+        texture-region-texture
+        texture-region-width
+        texture-region-height
+        texture-region-u
+        texture-region-v
+        texture-region-u2
+        texture-region-v2
+        split-texture)