Refactor <texture-region> into <texture>.

1 files changed, 73 insertions, 71 deletions

diff --git a/2d/texture.scm b/2d/texture.scm
index 4259bda..28b6482 100644
--- a/2d/texture.scm
+++ b/2d/texture.scm
@@ -27,7 +27,23 @@
   #:use-module (srfi srfi-42)
   #:use-module ((sdl sdl) #:prefix SDL:)
   #:use-module (figl gl)
-  #:use-module (2d gl))
+  #:use-module (2d gl)
+  #:use-module (2d helpers)
+  #:export (make-texture
+            make-texture-region
+            load-texture
+            texture?
+            texture-region?
+            texture-id
+            texture-width
+            texture-height
+            texture-s1
+            texture-t1
+            texture-s2
+            texture-t2
+            surface->texture
+            draw-texture
+            split-texture))
 
 ;;;
 ;;; Textures
@@ -36,11 +52,32 @@
 ;; The <texture> object is a simple wrapper around an OpenGL texture
 ;; id.
 (define-record-type <texture>
-  (make-texture id width height)
+  (make-texture id parent width height s1 t1 s2 t2)
   texture?
   (id texture-id)
+  (parent texture-parent)
   (width texture-width)
-  (height texture-height))
+  (height texture-height)
+  (s1 texture-s1)
+  (t1 texture-t1)
+  (s2 texture-s2)
+  (t2 texture-t2))
+
+(define (texture-region? texture)
+  (texture? (texture-parent texture)))
+
+(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)))
+    (make-texture (texture-id texture)
+                  texture
+                  width
+                  height
+                  (/ x w)
+                  (/ y h)
+                  (/ (+ x width) w)
+                  (/ (+ y height) h))))
 
 ;; Use a guardian and an after GC hook that ensures that OpenGL
 ;; textures are deleted when texture objects are GC'd.
@@ -49,12 +86,14 @@
 (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))
+      ;; Do not reap texture regions
+      (unless (texture-region? 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)
@@ -89,8 +128,10 @@ Currently only works with RGBA format surfaces."
                            (color-pointer-type unsigned-byte)
                            (SDL:surface-pixels surface)))
     (let ((texture (make-texture texture-id
+                                 #f
                                  (SDL:surface:w surface)
-                                 (SDL:surface:h surface))))
+                                 (SDL:surface:h surface)
+                                 0 0 1 1)))
       (texture-guardian texture)
       texture)))
 
@@ -98,61 +139,33 @@ Currently only works with RGBA format surfaces."
   "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)))
+(define* (draw-texture texture x y #:optional (color #xffffffff))
+  "Renders a textured quad in GL immediate mode."
+  (let* ((x2 (+ x (texture-width texture)))
+        (y2 (+ y (texture-height texture)))
+        (color (rgba->gl-color color))
+        (r (vector-ref color 0))
+        (g (vector-ref color 1))
+        (b (vector-ref color 2))
+        (a (vector-ref color 3))
+        (s1 (texture-s1 texture))
+        (t1 (texture-t1 texture))
+        (s2 (texture-s2 texture))
+        (t2 (texture-t2 texture)))
     (with-gl-bind-texture (texture-target texture-2d) (texture-id texture)
       (gl-begin (begin-mode quads)
-        (apply gl-color color)
-        (gl-texture-coordinates u v)
+        (gl-color r g b a)
+        (gl-texture-coordinates s1 t1)
         (gl-vertex x y)
-        (gl-texture-coordinates u2 v)
-        (gl-vertex x2 y)
-        (gl-texture-coordinates u2 v2)
+        (gl-texture-coordinates s1 t2)
+        (gl-vertex x y2)
+        (gl-texture-coordinates s2 t2)
         (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)))
+        (gl-texture-coordinates s2 t1)
+        (gl-vertex x2 y)))))
 
-(define* (split-texture texture width height
-                        #:optional #:key (margin 0) (spacing 0))
+(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)
@@ -165,14 +178,3 @@ size."
          (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)