Create tileset module.

1 files changed, 87 insertions, 0 deletions

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))