diff options
Diffstat (limited to 'chickadee/render/texture.scm')
| -rw-r--r-- | chickadee/render/texture.scm | 95 |
1 files changed, 44 insertions, 51 deletions
diff --git a/chickadee/render/texture.scm b/chickadee/render/texture.scm index 34be3fe..5c8ea7b 100644 --- a/chickadee/render/texture.scm +++ b/chickadee/render/texture.scm @@ -30,29 +30,23 @@ #:use-module (chickadee render gl) #:use-module (chickadee render gpu) #:export (make-texture + make-texture-region load-image texture? + texture-region? texture-null? texture-id texture-parent - texture-width - texture-height texture-min-filter texture-mag-filter texture-wrap-s texture-wrap-t + texture-rect + texture-gl-rect null-texture texture-set! texture-ref - make-texture-region - texture-region? - texture-region-texture - texture-region-x - texture-region-y - texture-region-width - texture-region-height - texture-atlas list->texture-atlas split-texture @@ -68,30 +62,31 @@ ;; The <texture> object is a simple wrapper around an OpenGL texture ;; id. (define-record-type <texture> - (%make-texture id width height min-filter mag-filter wrap-s wrap-t gl-size) + (%make-texture id parent min-filter mag-filter wrap-s wrap-t rect gl-rect) texture? (id texture-id) - (width texture-width) - (height texture-height) + (parent texture-parent) (min-filter texture-min-filter) (mag-filter texture-mag-filter) (wrap-s texture-wrap-s) (wrap-t texture-wrap-t) - (gl-size texture-gl-size)) + (rect texture-rect) + (gl-rect texture-gl-rect)) (set-record-type-printer! <texture> (lambda (texture port) (format port - "#<texture width: ~d height: ~d min-filter: ~a mag-filter: ~a wrap-s: ~a wrap-t: ~a>" - (texture-width texture) - (texture-height texture) + "#<texture region?: ~a rect: ~a min-filter: ~a mag-filter: ~a wrap-s: ~a wrap-t: ~a>" + (texture-region? texture) + (texture-rect texture) (texture-min-filter texture) (texture-mag-filter texture) (texture-wrap-s texture) (texture-wrap-t texture)))) (define null-texture - (%make-texture 0 0 0 'linear 'linear 'repeat 'repeat (f32vector 0.0 0.0))) + (%make-texture 0 #f 'linear 'linear 'repeat 'repeat + (make-rect 0.0 0.0 0.0 0.0) (make-rect 0.0 0.0 0.0 0.0))) (define <<texture>> (class-of null-texture)) @@ -99,6 +94,9 @@ "Return #t if TEXTURE is the null texture." (eq? texture null-texture)) +(define (texture-region? texture) + (texture? (texture-parent texture))) + (define (free-texture texture) (gl-delete-texture (texture-id texture))) @@ -150,9 +148,10 @@ clamp-to-edge. FORMAT specifies the pixel format. Currently only ('clamp-to-edge (texture-wrap-mode clamp-to-edge-sgis)))) (let ((texture (gpu-guard - (%make-texture (gl-generate-texture) width height + (%make-texture (gl-generate-texture) #f min-filter mag-filter wrap-s wrap-t - (f32vector width height))))) + (make-rect 0.0 0.0 width height) + (make-rect 0.0 0.0 1.0 1.0))))) (texture-set! 0 texture) (gl-texture-parameter (texture-target texture-2d) (texture-parameter-name texture-min-filter) @@ -178,6 +177,26 @@ clamp-to-edge. FORMAT specifies the pixel format. Currently only (or pixels %null-pointer)) texture)) +(define (make-texture-region texture rect) + "Create a new texture region covering a section of TEXTURE defined +by the bounding box RECT." + (let* ((parent-rect (texture-rect texture)) + (pw (rect-width parent-rect)) + (ph (rect-height parent-rect)) + (x (rect-x rect)) + (y (rect-y rect)) + (w (rect-width rect)) + (h (rect-height rect)) + (gl-rect (make-rect (/ x pw) (/ y ph) (/ w pw) (/ h ph)))) + (%make-texture (texture-id texture) + texture + (texture-min-filter texture) + (texture-mag-filter texture) + (texture-wrap-s texture) + (texture-wrap-t texture) + rect + gl-rect))) + (define (flip-pixels-vertically pixels width height) "Create a new bytevector that reverses the rows in PIXELS, a WIDTH x HEIGHT, 32 bit color bytevector." @@ -227,33 +246,6 @@ magnification. Valid values are 'nearest and 'linear. By default, ;;; -;;; Texture Regions -;;; - -(define-record-type <texture-region> - (%make-texture-region texture x y width height gl-rect gl-size) - texture-region? - (texture texture-region-texture) - (x texture-region-x) - (y texture-region-y) - (width texture-region-width) - (height texture-region-height) - (gl-rect texture-region-gl-rect) - (gl-size texture-region-gl-size)) - -(define (make-texture-region texture x y width height) - "Create a new texture region covering a section of TEXTURE defined -by the bounding box X, Y, WIDTH, and HEIGHT. All coordinates are -measured in pixels and must be integers." - (let* ((tw (texture-width texture)) - (th (texture-height texture)) - (gl-rect (make-rect (/ x tw) (/ y th) - (/ width tw) (/ height th)))) - (%make-texture-region texture x y width height gl-rect - (f32vector width height)))) - - -;;; ;;; Texture Atlas ;;; @@ -272,7 +264,7 @@ coordinate rects denoting the various tiles within." (match rects (() (%make-texture-atlas texture v)) (((x y width height) . rest) - (vector-set! v i (make-texture-region texture x y width height)) + (vector-set! v i (make-texture-region texture (make-rect x y width height))) (loop (1+ i) rest)))))) (define (texture-atlas texture . rects) @@ -296,8 +288,9 @@ around its border. This type of texture atlas layout is very common for tile map terrain." - (let* ((w (texture-width texture)) - (h (texture-height texture)) + (let* ((r (texture-rect texture)) + (w (rect-width r)) + (h (rect-height r)) (sw (/ tile-width w)) (th (/ tile-height h)) (rows (/ (- h margin) (+ tile-height spacing))) @@ -306,7 +299,7 @@ terrain." (define (make-tile tx ty) (let* ((x (+ (* tx (+ tile-width spacing)) margin)) (y (+ (* ty (+ tile-height spacing)) margin))) - (make-texture-region texture x y tile-width tile-height))) + (make-texture-region texture (make-rect x y tile-width tile-height)))) (let y-loop ((y 0)) (when (< y rows) (let x-loop ((x 0)) |