diff options
| -rw-r--r-- | 2d/texture.scm | 19 | ||||
| -rw-r--r-- | 2d/tileset.scm | 87 |
2 files changed, 88 insertions, 18 deletions
diff --git a/2d/texture.scm b/2d/texture.scm index 8df5e51..66d158b 100644 --- a/2d/texture.scm +++ b/2d/texture.scm @@ -24,7 +24,6 @@ (define-module (2d texture) #:use-module (srfi srfi-9) - #:use-module (srfi srfi-42) #:use-module (figl gl) #:use-module (2d wrappers gl) #:use-module (2d wrappers freeimage) @@ -42,8 +41,7 @@ texture-s2 texture-t2 surface->texture - draw-texture - split-texture)) + draw-texture)) ;;; ;;; Textures @@ -176,18 +174,3 @@ (gl-vertex x2 y2) (gl-texture-coordinates s2 t1) (gl-vertex x2 y))))) - -(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)))) diff --git a/2d/tileset.scm b/2d/tileset.scm new file mode 100644 index 0000000..e07336b --- /dev/null +++ b/2d/tileset.scm @@ -0,0 +1,87 @@ +;;; 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: +;; +;; Tilesets encapsulate a group of uniformly sized texture regions +;; that come from a single texture. +;; +;;; Code: + +(define-module (2d tileset) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-42) + #:use-module (2d texture) + #:export (<tileset> + make-tileset + load-tileset + tileset? + tileset-tiles + tileset-width + tileset-height + tileset-margin + tileset-spacing + tileset-ref)) + +(define-record-type <tileset> + (%make-tileset tiles width height margin spacing) + tileset? + (tiles tileset-tiles) + (width tileset-width) + (height tileset-height) + (margin tileset-margin) + (spacing tileset-spacing)) + +(define (split-texture texture width height margin spacing) + "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)))) + +(define* (make-tileset texture width height + #:optional #:key (margin 0) (spacing 0)) + "Returns a new tileset that is built by splitting the given texture +into tiles." + (let ((tiles (split-texture texture + width + height + margin + spacing))) + (%make-tileset tiles width height margin spacing))) + +(define* (load-tileset filename width height + #:optional #:key (margin 0) (spacing 0)) + "Returns a new tileset that is built by loading the given texture +file and splitting the texture into tiles." + (let* ((tiles (split-texture (load-texture filename) + width + height + margin + spacing))) + (%make-tileset tiles width height margin spacing))) + +(define (tileset-ref tileset i) + "Returns the tile at index i." + (vector-ref (tileset-tiles tileset) i)) |