summaryrefslogtreecommitdiff
path: root/2d
diff options
context:
space:
mode:
Diffstat (limited to '2d')
-rw-r--r--2d/texture.scm144
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)