From 8209011c3c84780ed4652c7636e92b1a1d80d4ff Mon Sep 17 00:00:00 2001
From: David Thompson <dthompson2@worcester.edu>
Date: Sat, 27 Feb 2016 22:38:13 -0500
Subject: math: Rewrite rect to use packed f64 bytevectors.

---
 sly/math/rect.scm       | 80 ++++++++++++++++++++++---------------------------
 sly/render/viewport.scm | 11 ++++---
 2 files changed, 42 insertions(+), 49 deletions(-)

diff --git a/sly/math/rect.scm b/sly/math/rect.scm
index 362cf69..79cc957 100644
--- a/sly/math/rect.scm
+++ b/sly/math/rect.scm
@@ -27,8 +27,8 @@
   #:use-module (srfi srfi-9)
   #:use-module (sly math)
   #:use-module (sly math vector)
-  #:export (<rect>
-            make-rect
+  #:use-module (sly records)
+  #:export (make-rect
             null-rect
             rect?
             rect-x
@@ -64,15 +64,16 @@
 ;;;
 
 ;; The rect API is very similar to the Pygame rect API, but rects are
-;; immutable.
+;; immutable (to the public, anyway).
 
-(define-record-type <rect>
-  (%make-rect x y width height)
+(define-packed-f64-record-type <rect>
+  %make-rect
+  bytevector->rect rect->bytevector
   rect?
-  (x rect-x)
-  (y rect-y)
-  (width rect-width)
-  (height rect-height))
+  (x 0 rect-x set-rect-x!)
+  (y 1 rect-y set-rect-y!)
+  (width 2 rect-width set-rect-width!)
+  (height 3 rect-height set-rect-height!))
 
 (define make-rect
   (case-lambda
@@ -84,14 +85,16 @@
 
 (define null-rect (make-rect 0 0 0 0))
 
-(define (rect-right rect)
+(define-inlinable (rect-right rect)
   (+ (rect-x rect) (rect-width rect)))
 
-(define rect-left rect-x)
+(define-inlinable (rect-left rect)
+  (rect-x rect))
 
-(define rect-bottom rect-y)
+(define-inlinable (rect-bottom rect)
+  (rect-y rect))
 
-(define (rect-top rect)
+(define-inlinable (rect-top rect)
   (+ (rect-y rect) (rect-height rect)))
 
 (define (rect-position rect)
@@ -134,23 +137,13 @@
   (vector2 (rect-width rect)
            (rect-height rect)))
 
-(define (%rect-move rect x y)
-  "Move RECT by the offset X, Y."
-  (make-rect (+ (rect-x rect) x)
-             (+ (rect-y rect) y)
+(define (rect-move rect v)
+  "Move RECT by the offset given by the 2D vector V."
+  (make-rect (+ (rect-x rect) (vector2-x v))
+             (+ (rect-y rect) (vector2-y v))
              (rect-width rect)
              (rect-height rect)))
 
-(define rect-move
-  (case-lambda
-    "Create a new rectangle by moving RECT by the given
-offset. rect-move accepts a vector or x and y coordinates as separate
-arguments."
-    ((rect v)
-     (%rect-move rect (vx v) (vy v)))
-    ((rect x y)
-     (%rect-move rect x y))))
-
 (define (%rect-inflate rect width height)
   "Grows the rect by the given amount. The rect stays centered around
 its current center."
@@ -185,11 +178,13 @@ RECT2. If the rects do not overlap, a rect of size 0 is returned."
         (y2 (min (rect-top rect1) (rect-top rect2))))
     (make-rect x1 y1 (max (- x2 x1) 0) (max (- y2 y1) 0))))
 
-(define rect-clamp
-  (match-lambda*
-   ((($ <rect> rx ry width height) (? vector2? v))
-    (vector2 (clamp rx (+ rx width) (vector2-x v))
-             (clamp ry (+ ry height) (vector2-y v))))))
+(define (rect-clamp rect v)
+  (let ((x (rect-x rect))
+        (y (rect-y rect))
+        (width (rect-width rect))
+        (height (rect-height rect)))
+    (vector2 (clamp x (+ x width) (vector2-x v))
+             (clamp y (+ y height) (vector2-y v)))))
 
 (define (rect-within? rect1 rect2)
   "Return #t if RECT2 is completely within RECT1."
@@ -205,16 +200,11 @@ RECT2. If the rects do not overlap, a rect of size 0 is returned."
        (< (rect-bottom rect1) (rect-top rect2))
        (> (rect-top rect1) (rect-bottom rect2))))
 
-(define (%rect-contains? rect x y)
-  (and (>= x (rect-left rect))
-       (< x (rect-right rect))
-       (>= y (rect-bottom rect))
-       (< y (rect-top rect))))
-
-(define rect-contains?
-  (case-lambda
-    "Return #t if the 2D vector V (or the coordinates X and Y) is within RECT."
-    ((rect v)
-     (%rect-contains? rect (vx v) (vy v)))
-    ((rect x y)
-     (%rect-contains? rect x y))))
+(define (rect-contains? rect v)
+  "Return #t if the 2D vector V is within RECT."
+  (let ((x (vector2-x v))
+        (y (vector2-y v)))
+    (and (>= x (rect-left rect))
+         (< x (rect-right rect))
+         (>= y (rect-bottom rect))
+         (< y (rect-top rect)))))
diff --git a/sly/render/viewport.scm b/sly/render/viewport.scm
index 054646e..eb02825 100644
--- a/sly/render/viewport.scm
+++ b/sly/render/viewport.scm
@@ -79,10 +79,13 @@ values for CLEAR-FLAGS are 'color-buffer', 'depth-buffer',
   "Set the OpenGL state for VIEWPORT.  Clip rendering to the viewport
 area, set the clear color, and clear necessary buffers."
   (gl-enable (enable-cap scissor-test))
-  (match (viewport-area viewport)
-    (($ <rect> x y width height)
-     (gl-viewport x y width height)
-     (gl-scissor x y width height)))
+  (let* ((rect (viewport-area viewport))
+         (x (inexact->exact (rect-x rect)))
+         (y (inexact->exact (rect-y rect)))
+         (width (inexact->exact (rect-width rect)))
+         (height (inexact->exact (rect-height rect))))
+    (gl-viewport x y width height)
+    (gl-scissor x y width height))
   (match (viewport-clear-color viewport)
     (($ <color> r g b a)
      (gl-clear-color r g b a))))
-- 
cgit v1.2.3