basket/basket/poly.scm

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

(export
  make-regular-poly
  poly->path
  poly->cpath
  poly-center
  poly-add
  poly-sub
  poly-rotate-around
  poly-rotate-center
  poly-scale
  poly-bounds
  triangle-contains)

(define (make-regular-poly center radius sides)
  (map (lambda (x)
         (let ((angle (* tau (/ x sides))))
           (vec-add center (vec-mult (make-vec (sin angle) (cos angle)) radius))))
       (iota sides)))

(define (poly->path p)
  (append p (list (car p))))

(define (poly->cpath p)
  (cons 'cpath p))

(define (poly-center p)
  "Returns the center of a polygon."
  (if (null? p)
      '(0 . 0)
      (vec-div (apply vec-add p) (length p))))

(define (poly-add p . vs)
  "Adds any number of vectors to the points of a polygon."
  (map (lambda (v) (apply vec-add v vs)) p))

(define (poly-sub p . vs)
  "Subtracts any number of vectors to the points of a polygon."
  (map (lambda (v) (apply vec-sub v vs)) p))

(define (poly-rotate-around p v t)
  "Rotates a polygon around a point."
  (poly-add
    (map (lambda (x) (vec-rotate x t))
         (poly-sub p v))
    v))

(define (poly-rotate-center p t)
  "Rotates a polygon around its center."
  (poly-rotate-around p (poly-center p) t))

(define (poly-scale p x)
  "Scales a polygon (around its center)."
  (map (lambda (v) (vec-lerp (poly-center p) v x)) p))

(define (poly-bounds p)
  "Returns the bounding box of a polygon as a rectangle."
  (let ((xs (map vec-x p))
        (ys (map vec-y p)))
  (make-rect (make-vec (apply min xs) (apply min ys))
             (make-vec (apply max xs) (apply max ys)))))

(define (triangle-contains t v)
  "Tests for a point being contained in a triangle."
  ; this uses the Barycentric coordinate system, whatever that means.
  (let* ((b (vec-sub (cadr t) (car t)))
         (c (vec-sub (caddr t) (car t)))
         (v (vec-sub v (car t)))
         (bb (vec-dot b b))
         (bc (vec-dot b c))
         (bv (vec-dot b v))
         (cc (vec-dot c c))
         (cv (vec-dot c v))
         (id (/ (- (* bb cc) (* bc bc))))
         (u (* id (- (* bb cv) (* bc bv))))
         (v (* id (- (* cc bv) (* bc cv)))))
    (and (>= u 0) (>= v 0) (<= (+ u v) 1))))