summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Makefile.am1
-rw-r--r--chickadee/math/rect.scm357
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))))