From f5175c83cc994ae18667245c0374d50ef7fdbb77 Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson@member.fsf.org>
Date: Sat, 6 Jul 2013 12:14:28 -0400
Subject: Add texture regions.

---
 2d/texture.scm | 38 +++++++++++++++++++++++++++++++++++++-
 1 file changed, 37 insertions(+), 1 deletion(-)

diff --git a/2d/texture.scm b/2d/texture.scm
index 9f53966..0db72a2 100644
--- a/2d/texture.scm
+++ b/2d/texture.scm
@@ -32,7 +32,16 @@
             texture-height
             surface->texture
             load-texture
-            texture-quad))
+            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))
 
 ;; The <texture> object is a simple wrapper around an OpenGL texture
 ;; id.
@@ -114,3 +123,30 @@ Currently only works with RGBA format surfaces."
         (gl-vertex x2 y2)
         (gl-texture-coordinates 0 1)
         (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)))
-- 
cgit v1.2.3