math: Add rect module.

2 files changed, 358 insertions, 0 deletions

diff --git a/Makefile.am b/Makefile.am
index 780a085..84d882a 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -44,6 +44,7 @@ SOURCES = 					\
   chickadee/math.scm				\
   chickadee/math/vector.scm			\
   chickadee/math/matrix.scm			\
+  chickadee/math/rect.scm			\
   chickadee/color.scm				\
   chickadee/render/gl.scm			\
   chickadee/render/gpu.scm			\
diff --git a/chickadee/math/rect.scm b/chickadee/math/rect.scm
new file mode 100644
index 0000000..08534a5
--- /dev/null
+++ b/chickadee/math/rect.scm
@@ -0,0 +1,357 @@
+;;; Chickadee Game Toolkit
+;;; Copyright © 2016 David Thompson <davet@gnu.org>
+;;;
+;;; Chickadee is free software: you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published
+;;; by the Free Software Foundation, either version 3 of the License,
+;;; or (at your option) any later version.
+;;;
+;;; Chickadee is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program.  If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (chickadee math rect)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-4)
+  #:use-module (srfi srfi-9)
+  #:use-module (chickadee math)
+  #:use-module (chickadee math vector)
+  #:export (make-rect
+            rect?
+            rect-copy!
+            rect-copy
+            rect-x
+            rect-y
+            rect-width
+            rect-height
+            rect-area
+            rect-left
+            rect-right
+            rect-top
+            rect-bottom
+            rect-center-x
+            rect-center-y
+            rect-clamp-x
+            rect-clamp-y
+            vec2-clamp-to-rect
+            rect-clamp
+            rect-move
+            rect-move-vec2
+            rect-move-by
+            rect-move-by-vec2
+            rect-inflate
+            rect-union
+            rect-clip
+            set-rect-x!
+            set-rect-y!
+            set-rect-width!
+            set-rect-height!
+            rect-move!
+            rect-move-vec2!
+            rect-move-by!
+            rect-move-by-vec2!
+            rect-inflate!
+            rect-union!
+            rect-clip!
+            vec2-clamp-to-rect!
+            rect-clamp!
+            rect-within?
+            rect-intersects?
+            rect-contains?
+            rect-contains-vec2?))
+
+;; This record type just wraps a 4 element f32vector as a workaround
+;; for Guile not being able to unbox struct fields.  Since floating
+;; point numbers are heap-allocated in Guile, the name of this game is
+;; to help the compiler unbox as much floating point math as possible.
+;; Doing so greatly reduces allocation and thus improves the user
+;; experience because there are less GC pauses.  By using bytevectors
+;; and inlining nearly everything, the compiler is able to optimize
+;; away a lot of scm->f64 and f64->scm instructions.
+
+(define-record-type <rect>
+  (wrap-rect bv)
+  rect?
+  (bv unwrap-rect))
+
+(define (make-null-rect)
+  (wrap-rect (make-f32vector 4)))
+
+(define-syntax-rule (with-new-rect name body ...)
+  (let ((name (make-null-rect))) body ... name))
+
+(define-inlinable (rect-get rect i)
+  (f32vector-ref (unwrap-rect rect) i))
+
+(define-inlinable (rect-set! rect i x)
+  (f32vector-set! (unwrap-rect rect) i x))
+
+(define-inlinable (make-rect x y width height)
+  "Create a new rectangle WIDTH x HEIGHT in size whose bottom left
+corner is located at (X, Y)."
+  (with-new-rect rect
+    (rect-set! rect 0 x)
+    (rect-set! rect 1 y)
+    (rect-set! rect 2 width)
+    (rect-set! rect 3 height)))
+
+(define (rect-copy! source-rect target-rect)
+  "Copy TARGET-RECT to SOURCE-RECT."
+  (bytevector-copy! (unwrap-rect source-rect)
+                    0
+                    (unwrap-rect target-rect)
+                    0
+                    16))
+
+(define (rect-copy rect)
+  "Return a new rect that is a copy of RECT."
+  (with-new-rect new
+    (rect-copy! rect new)))
+
+
+;;;
+;;; Functional operations
+;;;
+
+(define-inlinable (rect-x rect)
+  "Return the x coordinate of the lower left corner of RECT."
+  (rect-get rect 0))
+
+(define-inlinable (rect-left rect)
+  "Return the x coordinate of the lower left corner of RECT."
+  (rect-get rect 0))
+
+(define-inlinable (rect-y rect)
+  "Return the y coordinate of the lower left corner of RECT."
+  (rect-get rect 1))
+
+(define-inlinable (rect-bottom rect)
+  "Return the y coordinate of the lower left corner of RECT."
+  (rect-get rect 1))
+
+(define-inlinable (rect-right rect)
+  "Return the x coordinate of the upper right corner of RECT."
+  (+ (rect-x rect) (rect-width rect)))
+
+(define-inlinable (rect-top rect)
+  "Return the y coordinate of the upper right corner of RECT."
+  (+ (rect-y rect) (rect-height rect)))
+
+(define-inlinable (rect-center-x rect)
+  "Return the x coordinate of the center of RECT."
+  (+ (rect-x rect) (/ (rect-width rect) 2.0)))
+
+(define-inlinable (rect-center-y rect)
+  "Return the y coordinate of the center of RECT."
+  (+ (rect-y rect) (/ (rect-height rect) 2.0)))
+
+(define-inlinable (rect-width rect)
+  "Return the width of RECT."
+  (rect-get rect 2))
+
+(define-inlinable (rect-height rect)
+  "Return the height of RECT."
+  (rect-get rect 3))
+
+(define-inlinable (rect-area rect)
+  "Return the area of RECT."
+  (* (rect-width rect) (rect-height rect)))
+
+(define-inlinable (rect-clamp-x rect x)
+  "Restrict X to the portion of the x axis covered by RECT."
+  (clamp (rect-left rect) (rect-right rect) x))
+
+(define-inlinable (rect-clamp-y rect y)
+  "Restrict Y to the portion of the y axis covered by RECT."
+  (clamp (rect-bottom rect) (rect-top rect) y))
+
+(define (vec2-clamp-to-rect v rect)
+  "Return a new vec2 with the x and y coordinates of the vec2 V
+restricted so that they are within the bounds of RECT."
+  (vec2-clamp-to-rect! (copy-vec2 v) rect))
+
+(define (rect-clamp rect1 rect2)
+  "Return a new rect that adjusts the location of RECT1 so that it is
+completely within RECT2.  An exception is thrown in the case that
+RECT1 cannot fit completely within RECT2."
+  (with-new-rect new
+    (rect-copy! rect1 new)
+    (rect-clamp! new rect2)))
+
+(define-inlinable (rect-move rect x y)
+  "Return a new rect based on RECT but moved to location (X, Y)."
+  (make-rect x y (rect-width rect) (rect-height rect)))
+
+(define-inlinable (rect-move-vec2 rect v)
+  "Return a new rect based on RECT but moved to the vec2 V."
+  (make-rect (vec2-x v) (vec2-y v) (rect-width rect) (rect-height rect)))
+
+(define-inlinable (rect-move-by rect x y)
+  "Return a new rect based on RECT but moved by (X, Y) units relative
+to its current location."
+  (with-new-rect new
+    (rect-copy! rect new)
+    (rect-move-by! new x y)))
+
+(define-inlinable (rect-move-by-vec2 rect v)
+  "Return a new rect based on RECT but moved by the vec2 V relative to
+its current location."
+  (with-new-rect new
+    (rect-copy! rect new)
+    (rect-move-by-vec2! new v)))
+
+(define-inlinable (rect-inflate rect width height)
+  "Return a new rect based on RECT but grown by WIDTH on the x axis
+and HEIGHT on the y axis while keeping the rect centered around the
+same point."
+  (with-new-rect rect
+    (rect-inflate! rect width height)))
+
+(define (rect-union rect1 rect2)
+  "Return a new rect that completely covers the area of RECT1 and
+RECT2."
+  (with-new-rect rect
+    (rect-copy! rect2 rect1)
+    (rect-union! rect1 rect2)))
+
+(define (rect-clip rect1 rect2)
+  "Return a new rectangle that is the overlapping region of RECT1 and
+RECT2.  If the rects do not overlap, a rect of size 0 is returned."
+  (with-new-rect rect
+    (rect-copy! rect2 rect1)
+    (rect-clip! rect1 rect2)))
+
+
+;;;
+;;; In-place operations
+;;;
+
+(define-inlinable (set-rect-x! rect x)
+  "Set the left x coordinate of RECT to X."
+  (rect-set! rect 0 x))
+
+(define-inlinable (set-rect-y! rect y)
+  "Set the bottom y coordinate of RECT to Y."
+  (rect-set! rect 1 y))
+
+(define-inlinable (set-rect-width! rect width)
+  "Set the width of RECT to WIDTH."
+  (rect-set! rect 2 width))
+
+(define-inlinable (set-rect-height! rect height)
+  "Set the height of RECT to HEIGHT."
+  (rect-set! rect 3 height))
+
+(define-inlinable (rect-move! rect x y)
+  "Move RECT to location (X, Y) in-place."
+  (set-rect-x! rect x)
+  (set-rect-y! rect y))
+
+(define-inlinable (rect-move-vec2! rect v)
+  "Move RECT to the vec2 V in-place."
+  (set-rect-x! rect (vec2-x v))
+  (set-rect-y! rect (vec2-y v)))
+
+(define-inlinable (rect-move-by! rect x y)
+  "Move RECT in-place by (X, Y) units relative to its current
+location."
+  (set-rect-x! rect (+ (rect-x rect) x))
+  (set-rect-y! rect (+ (rect-y rect) y)))
+
+(define (rect-move-by-vec2! rect v)
+  "Move RECT in-place by the vec2 V relative to its current location."
+  (set-rect-x! rect (+ (rect-x rect) (vec2-x v)))
+  (set-rect-y! rect (+ (rect-y rect) (vec2-y v))))
+
+(define-inlinable (rect-inflate! rect width height)
+  "Grow RECT in-place by WIDTH on the x axis and HEIGHT on the y axis
+while keeping the rect centered around the same point."
+  (set-rect-x! rect (- (rect-x rect) (/ width 2.0)))
+  (set-rect-y! rect (- (rect-y rect) (/ height 2.0)))
+  (set-rect-width! rect (+ (rect-width rect) width))
+  (set-rect-height! rect (+ (rect-height rect) height)))
+
+(define-inlinable (rect-union! rect1 rect2)
+  "Update RECT1 in-place to completely cover the area of RECT1 and
+RECT2."
+  (let ((x1 (min (rect-left rect1) (rect-left rect2)))
+        (x2 (max (rect-right rect1) (rect-right rect2)))
+        (y1 (min (rect-bottom rect1) (rect-bottom rect2)))
+        (y2 (max (rect-top rect1) (rect-top rect2))))
+    (set-rect-x! rect1 x1)
+    (set-rect-y! rect1 y1)
+    (set-rect-width! rect1 (- x2 x1))
+    (set-rect-height! rect1 (- y2 y1))))
+
+(define-inlinable (rect-clip! rect1 rect2)
+  "Update RECT1 in-place to be the overlapping region of RECT1 and RECT2.
+If the rects do not overlap, RECT1 will have an area of 0."
+  (let ((x1 (max (rect-left rect1) (rect-left rect2)))
+        (x2 (min (rect-right rect1) (rect-right rect2)))
+        (y1 (max (rect-bottom rect1) (rect-bottom rect2)))
+        (y2 (min (rect-top rect1) (rect-top rect2))))
+    (set-rect-x! rect1 x1)
+    (set-rect-y! rect1 y1)
+    (set-rect-width! rect1 (max (- x2 x1) 0.0))
+    (set-rect-height! rect1 (max (- y2 y1) 0.0))))
+
+(define-inlinable (vec2-clamp-to-rect! v rect)
+  "Restrict the x and y coordinates of the vec2 V so that they are
+within the bounds of RECT.  V is modified in-place."
+  (set-vec2-x! v (clamp (rect-left rect) (rect-right rect) (vec2-x v)))
+  (set-vec2-y! v (clamp (rect-bottom rect) (rect-top rect) (vec2-y v))))
+
+(define (rect-clamp! rect1 rect2)
+  "Adjust the location of RECT1 in-place so that it is completely
+within RECT2.  An exception is thrown in the case that RECT1 cannot
+fit completely within RECT2."
+  (if (or (> (rect-width rect1) (rect-width rect2))
+          (> (rect-height rect1) (rect-height rect2)))
+      (error "cannot clamp a rect to a smaller rect" rect1 rect2)
+      (begin
+        (set-rect-x! rect1
+                     (clamp (rect-left rect2)
+                            (- (rect-right rect2) (rect-width rect1))
+                            (rect-x rect1)))
+        (set-rect-y! rect1
+                     (clamp (rect-bottom rect2)
+                            (- (rect-top rect2) (rect-height rect1))
+                            (rect-y rect1))))))
+
+
+;;;
+;;; Queries
+;;;
+
+(define (rect-within? rect1 rect2)
+  "Return #t if RECT2 is completely within RECT1."
+  (and (>= (rect-left rect2) (rect-left rect1))
+       (<= (rect-right rect2) (rect-right rect1))
+       (>= (rect-bottom rect2) (rect-bottom rect1))
+       (<= (rect-top rect2) (rect-top rect1))))
+
+(define (rect-intersects? rect1 rect2)
+  "Return #t if RECT2 overlaps RECT1."
+  (and (< (rect-left rect1) (rect-right rect2))
+       (> (rect-right rect1) (rect-left rect2))
+       (< (rect-bottom rect1) (rect-top rect2))
+       (> (rect-top rect1) (rect-bottom rect2))))
+
+(define-inlinable (rect-contains? rect x y)
+  "Return #t if the coordinates (X, Y) are within RECT."
+  (and (>= x (rect-left rect))
+       (< x (rect-right rect))
+       (>= y (rect-bottom rect))
+       (< y (rect-top rect))))
+
+(define-inlinable (rect-contains-vec2? rect v)
+  "Return #t if the vec2 V is within RECT."
+  (and (>= (vec2-x v) (rect-left rect))
+       (< (vec2-x v) (rect-right rect))
+       (>= (vec2-y v) (rect-bottom rect))
+       (< (vec2-y v) (rect-top rect))))