mods/default/triangle.scm

   1 (define-module (dungeon-master geom triangle)
   2   #:use-module (srfi srfi-9)
   3   #:use-module (dungeon-master geom point)
   4   #:export (make-triangle
   5             triangle?
   6             triangle-points
   7             triangle-center
   8             triangle-radius))
   9
  10 (define-record-type <triangle>
  11   (make-raw-triangle points center radius)
  12   triangle?
  13   (points triangle-points)
  14   (center triangle-center)
  15   (radius triangle-radius))
  16
  17 (define (make-triangle p1 p2 p3)
  18   (let ((s (+ (* (- (point-x p2) (point-x p1))
  19                  (+ (point-y p2) (point-y p1)))
  20               (* (- (point-x p3) (point-x p2))
  21                  (+ (point-y p3) (point-y p2)))
  22               (* (- (point-x p1) (point-x p3))
  23                  (+ (point-y p1) (point-y p3))))))
  24     (let ((tp1 p1)
  25           (tp2 (if (> s 0) p2 p3))
  26           (tp3 (if (> s 0) p3 p2)))
  27       (let ((x1 (/ (+ (point-x tp1) (point-x tp2)) 2))
  28             (y1 (/ (+ (point-y tp1) (point-y tp2)) 2))
  29             (x2 (/ (+ (point-x tp2) (point-x tp3)) 2))
  30             (y2 (/ (+ (point-y tp2) (point-y tp3)) 2))
  31             (dx1 (- (point-y tp1) (point-y tp2)))
  32             (dy1 (- (point-x tp2) (point-x tp1)))
  33             (dx2 (- (point-y tp2) (point-y tp3)))
  34             (dy2 (- (point-x tp3) (point-x tp2))))
  35         (let* ((tg1 (/ dy1 dx1))
  36                (t2 (/ (- (- y1 y2)
  37                          (* (- (x1 x2)) tg1))
  38                       (- dy2 (* dx2 tg1))))
  39                (center (make-point
  40                         (+ x2 (* dx2 t2))
  41                         (+ y2 (* dy2 t2))))
  42                (radius (points-distance center tp1)))
  43           (make-raw-triangle (list tp1 tp2 tp3) center radius))))))