render: texture: Add texture atlas record type.

1 files changed, 72 insertions, 1 deletions

diff --git a/chickadee/render/texture.scm b/chickadee/render/texture.scm
index ef55dca..086caab 100644
--- a/chickadee/render/texture.scm
+++ b/chickadee/render/texture.scm
@@ -28,6 +28,7 @@
   #:use-module ((sdl2 image) #:prefix sdl-image:)
   #:use-module (sdl2 surface)
   #:use-module (oop goops)
+  #:use-module (chickadee math rect)
   #:use-module (chickadee render gl)
   #:use-module (chickadee render gpu)
   #:export (make-texture
@@ -43,8 +44,15 @@
             texture-wrap-s
             texture-wrap-t
             null-texture
-            *texture-state*))
+            *texture-state*
 
+            texture-atlas
+            list->texture-atlas
+            split-texture
+            texture-atlas?
+            texture-atlas-ref))
+
+
 ;;;
 ;;; Textures
 ;;;
@@ -189,3 +197,66 @@ magnification.  Valid values are 'nearest and 'linear.  By default,
   (call-with-surface (sdl-image:load-image file)
     (lambda (surface)
       (surface->texture surface min-filter mag-filter wrap-s wrap-t))))
+
+
+;;;
+;;; Texture Atlas
+;;;
+
+(define-record-type <texture-atlas>
+  (%make-texture-atlas texture vector)
+  texture-atlas?
+  (texture texture-atlas-texture)
+  (vector texture-atlas-vector))
+
+(define (list->texture-atlas texture rects)
+  "Return a new atlas for TEXTURE containing RECTS, a list of texture
+coordinate rects denoting the various tiles within."
+  (let ((v (make-vector (length rects))))
+    (let loop ((i 0)
+               (rects rects))
+      (match rects
+        (() (%make-texture-atlas texture v))
+        ((r . rest)
+         (vector-set! v i r)
+         (loop (1+ i) rest))))))
+
+(define (texture-atlas texture . rects)
+  "Return a new atlas for TEXTURE containing RECTS, a series of
+texture coordinate rect arguments denoting the various tiles within."
+  (list->texture-atlas texture rects))
+
+(define (texture-atlas-ref atlas index)
+  "Return the texture coordinate rect associated with INDEX in
+ATLAS."
+  (vector-ref (texture-atlas-vector atlas) index))
+
+(define* (split-texture texture tile-width tile-height #:key
+                        (margin 0) (spacing 0))
+  "Return a new texture atlas that splits TEXTURE into a grid of
+TILE-WIDTH by TILE-HEIGHT rectangles.  Optionally, each tile may have
+SPACING pixels of horizontal and vertical space between surrounding
+tiles and the entire image may have MARGIN pixels of empty space
+around its border.
+
+This type of texture atlas layout is very common for tile map
+terrain."
+  (let* ((w (texture-width texture))
+         (h (texture-height texture))
+         (sw (/ tile-width w))
+         (th (/ tile-height h))
+         (rows (/ (- h margin) (+ tile-height spacing)))
+         (columns (/ (- w margin) (+ tile-width spacing)))
+         (v (make-vector (* rows columns))))
+    (define (make-tile tx ty)
+      (let* ((x (+ (* tx (+ tile-width spacing)) margin))
+             (y (+ (* ty (+ tile-height spacing)) margin)))
+        (make-rect (/ x w) (/ y h) sw th)))
+    (let y-loop ((y 0))
+      (when (< y rows)
+        (let x-loop ((x 0))
+          (when (< x columns)
+            (vector-set! v (+ x (* y columns)) (make-tile x y))
+            (x-loop (1+ x))))
+        (y-loop (1+ y))))
+    (%make-texture-atlas texture v)))