diff options
Diffstat (limited to '2d')
| -rw-r--r-- | 2d/animation.scm | 111 | ||||
| -rw-r--r-- | 2d/sprite.scm | 289 | ||||
| -rw-r--r-- | 2d/texture.scm | 178 |
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) |