summaryrefslogtreecommitdiff
path: root/2d
diff options
context:
space:
mode:
Diffstat (limited to '2d')
-rw-r--r--2d/animation.scm111
-rw-r--r--2d/sprite.scm289
-rw-r--r--2d/texture.scm178
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)