Deleted texture module and moved contents into sprite module.

2d/sprite.scm

@@ -17,17 +17,37 @@
 
 ;;; Commentary:
 ;;
-;; 2D sprite procedures.
+;; Sprites are typically the most important part of a 2D game. This
+;; module provides sprites as an abstraction around OpenGL textures.
 ;;
 ;;; Code:
 
 (define-module (2d sprite)
   #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-42)
   #:use-module (figl gl)
   #:use-module (figl contrib packed-struct)
-  #:use-module (2d texture)
+  #:use-module ((sdl sdl) #:prefix SDL:)
   #:use-module (2d vector)
-  #:export (make-sprite
+  #:export (make-texture
+            texture?
+            texture-id
+            texture-width
+            texture-height
+            surface->texture
+            load-texture
+            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
+            split-texture
+            make-sprite
             sprite?
             sprite-texture
             sprite-position
@@ -55,6 +75,138 @@
             sprite-batch-draw
             with-sprite-batch))
 
+;;;
+;;; Textures
+;;;
+
+;; The <texture> object is a simple wrapper around an OpenGL texture
+;; id.
+(define-record-type <texture>
+  (make-texture id width height)
+  texture?
+  (id texture-id)
+  (width texture-width)
+  (height texture-height))
+
+;; Use a guardian and an after GC hook that ensures that OpenGL
+;; textures are deleted when texture objects are GC'd.
+(define texture-guardian (make-guardian))
+
+(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-textures (list (texture-id texture))))
+        (lambda (key . args) #f))
+      (loop (texture-guardian)))))
+
+(add-hook! after-gc-hook reap-textures)
+
+(define (surface-pixel-format surface)
+  "Returns the OpenGL pixel format for a surface. RGB and RGBA formats
+are supported."
+  (case (SDL:surface:depth surface)
+    ((24) (pixel-format rgb))
+    ((32) (pixel-format rgba))
+    (else (throw 'unsupported-pixel-format))))
+
+(define (surface->texture surface)
+  "Translates an SDL surface into an OpenGL texture.
+Currently only works with RGBA format surfaces."
+  (let ((texture-id (gl-generate-texture))
+        (pixel-format (surface-pixel-format surface)))
+    (with-gl-bind-texture (texture-target texture-2d) texture-id
+      (gl-texture-parameter (texture-target texture-2d)
+                            (texture-parameter-name texture-min-filter)
+                            (texture-min-filter linear))
+      (gl-texture-parameter (texture-target texture-2d)
+                            (texture-parameter-name texture-mag-filter)
+                            (texture-mag-filter linear))
+      (gl-texture-image-2d (texture-target texture-2d)
+                           0
+                           pixel-format
+                           (SDL:surface:w surface)
+                           (SDL:surface:h surface)
+                           0
+                           pixel-format
+                           (color-pointer-type unsigned-byte)
+                           (SDL:surface-pixels surface)))
+    (let ((texture (make-texture texture-id
+                                 (SDL:surface:w surface)
+                                 (SDL:surface:h surface))))
+      (texture-guardian texture)
+      texture)))
+
+(define (load-texture filename)
+  "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)))
+    (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-vertex x y)
+        (gl-texture-coordinates u2 v)
+        (gl-vertex x2 y)
+        (gl-texture-coordinates u2 v2)
+        (gl-vertex x2 y2)
+        (gl-texture-coordinates u v2)
+        (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)))
+
+(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))))
+
+;;;
+;;; Sprites
+;;;
+
 ;; Used to build OpenGL vertex array for a sprite.
 (define-packed-struct sprite-vertex
   (x float)
@@ -165,13 +317,13 @@
       (gl-disable-client-state (enable-cap vertex-array)))))
 
 ;;;
-;;; Sprite Batch
+;;; Sprite batches
 ;;;
 
 ;; Sprite batches allow for efficient texture rendering. Sprites drawn
-;; with the same texture are drawn with the same draw call, rather
-;; than binding the texture for each individual draw call.
-
+;; with the same texture are drawn in the same draw call using a
+;; vertex array, rather than re-binding the texture for each
+;; individual draw call.
 (define-record-type <sprite-batch>
   (%make-sprite-batch max-size size texture vertices)
   sprite-batch?