render: Refactor sprite rendering.
[chickadee.git] / chickadee / render / texture.scm
index 34be3fe..5c8ea7b 100644 (file)
   #: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
 ;; 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,
 
 \f
 ;;;
-;;; 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))))
-
-\f
-;;;
 ;;; 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))