basket/basket/rect.scm

(define-module (basket rect)
               #:use-module (basket vec)
               #:use-module (basket poly)
               #:use-module (basket)
               #:use-module (srfi srfi-1))

(export
  make-rect
  rect-ul rect-dr
  rect-l rect-u rect-r rect-d
  rect-width rect-height
  rect->poly
  rect->path rect->cpath
  rect-contains
  rect-intersects
  rect->vecss rect->rectss
  rect-lerp)

(define make-rect list)
(define rect-ul car)
(define rect-dr cadr)
(define rect-u cdar)
(define rect-l caar)
(define rect-d cdadr)
(define rect-r caadr)

(define (rect-width r)
  (- (rect-r r) (rect-l r)))

(define (rect-height r)
  (- (rect-d r) (rect-u r)))

(define (rect->poly r)
  (list
    (rect-ul r)
    (make-vec (rect-r r) (rect-u r))
    (rect-dr r)
    (make-vec (rect-l r) (rect-d r))))

(define (rect->path r)
  (poly->path (rect->poly r)))

(define (rect->cpath r)
  (poly->cpath (rect->poly r)))
(define (rect-contains r v)
  "Tests for a vector being inside the boundaries of a rectangle."
  (and
    (>= (vec-x v) (rect-l r))
    (<= (vec-x v) (rect-r r))
    (>= (vec-y v) (rect-u r))
    (<= (vec-y v) (rect-d r))))

(define (rect-intersects a b)
  "Tests for two rectangles intersecting."
  (and (<= (rect-l a) (rect-r b))
       (<= (rect-l b) (rect-r a))
       (<= (rect-u a) (rect-d b))
       (<= (rect-u b) (rect-d a))))

(define (rect->vecss r n)
  "Turns a rectangle boundary and an element count into a grid of vectors."
  (let ((ul (rect-ul r))
        (dr (rect-dr r))
        (width (if (pair? n) (car n) n))
        (height (if (pair? n) (cdr n) n)))
    (map (lambda (y)
           (map (lambda (x)
                  (make-vec (vec-x (vec-lerp ul dr (/ x (- width 1))))
                            (vec-y (vec-lerp ul dr (/ y (- height 1))))))
                (iota width)))
         (iota height))))

(define (rect->rectss r n)
  "Splits a rangle boundary and an element count into a grid of rangles."
  (let* ((ul (rect-ul r))
         (dr (rect-dr r))
         (width (if (pair? n) (car n) n))
         (height (if (pair? n) (cdr n) n))
         (rwidth (/ (rect-width r) width))
         (rheight (/ (rect-height r) height)))
    (map
      (lambda (y)
        (map
          (lambda (x)
            (let ((v (make-vec
                       (vec-x (vec-lerp ul dr (/ x width)))
                       (vec-y (vec-lerp ul dr (/ y height))))))
              (list v (vec-add v (make-vec rwidth rheight)))))
          (iota width)))
      (iota height))))

(define (rect-lerp r v)
  "Interpolate a vector over a rectangle."
  (make-vec (lerp (rect-l r) (rect-r r) (vec-x v))
            (lerp (rect-u r) (rect-d r) (vec-y v))))