diff options
Diffstat (limited to '2d')
| -rw-r--r-- | 2d/texture.scm | 144 |
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) |