path: root/chickadee/math/rect.scm

;;; Chickadee Game Toolkit
;;; Copyright © 2016 David Thompson <dthompson2@worcester.edu>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

(define-module (chickadee math rect)
  #:use-module (chickadee data bytestruct)
  #:use-module (chickadee math)
  #:use-module (chickadee math vector)
  #:use-module (ice-9 format)
  #:use-module (rnrs bytevectors)
  #:use-module (srfi srfi-4)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:export (<rect>
            make-rect
            make-null-rect
            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?))

(define-byterecord-type <rect>
  (make-rect x y width height)
  rect?
  (x f32 rect-x set-rect-x!)
  (y f32 rect-y set-rect-y!)
  (width f32 rect-width set-rect-width!)
  (height f32 rect-height set-rect-height!))

(define (make-null-rect)
  (bytestruct-alloc <rect>))

(define-syntax-rule (with-new-rect name body ...)
  (let ((name (make-null-rect))) body ... name))

(define-inlinable (rect x y width height)
  (make-rect x y width height))

(define (rect-copy! source-rect target-rect)
  "Copy TARGET-RECT to SOURCE-RECT."
  (bytestruct-copy! <rect> source-rect target-rect))

(define (rect-copy rect)
  "Return a new rect that is a copy of RECT."
  (bytestruct-copy <rect> rect))


;;;
;;; Functional operations
;;;

(define-inlinable (rect-left rect)
  "Return the x coordinate of the lower left corner of RECT."
  (rect-x rect))

(define-inlinable (rect-bottom rect)
  "Return the y coordinate of the lower left corner of RECT."
  (rect-y rect))

(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-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))


;;;
;;; In-place operations
;;;

(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."
  (cond
   ;; If rect1 has no area, just copy rect2.
   ((and (zero? (rect-width rect1))
         (zero? (rect-height rect1)))
    (rect-copy! rect2 rect1))
   ;; Ignore rects that have no area.
   ((and (zero? (rect-width rect2))
         (zero? (rect-height rect2)))
    *unspecified*)
   (else
    (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))))))


;;;
;;; Functional operations
;;;

(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."
  (let ((v* (vec2-copy v)))
    (vec2-clamp-to-rect! v* rect)
    v*))

(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 new
    (rect-copy! rect new)
    (rect-inflate! new 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! rect1 rect)
    (rect-union! rect 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! rect1 rect)
    (rect-clip! rect rect2)))


;;;
;;; 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))))