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             triangle-has-edge))
  10
  11 (define-record-type <triangle>
  12   (make-raw-triangle points center radius)
  13   triangle?
  14   (points triangle-points)
  15   (center triangle-center)
  16   (radius triangle-radius))
  17
  18 (define (make-triangle p1 p2 p3)
  19   (let ((s (+ (* (- (point-x p2) (point-x p1))
  20                  (+ (point-y p2) (point-y p1)))
  21               (* (- (point-x p3) (point-x p2))
  22                  (+ (point-y p3) (point-y p2)))
  23               (* (- (point-x p1) (point-x p3))
  24                  (+ (point-y p1) (point-y p3))))))
  25     (let ((tp1 p1)
  26           (tp2 (if (> s 0) p2 p3))
  27           (tp3 (if (> s 0) p3 p2)))
  28       (let ((x1 (/ (+ (point-x tp1) (point-x tp2)) 2))
  29             (y1 (/ (+ (point-y tp1) (point-y tp2)) 2))
  30             (x2 (/ (+ (point-x tp2) (point-x tp3)) 2))
  31             (y2 (/ (+ (point-y tp2) (point-y tp3)) 2))
  32             (dx1 (- (point-y tp1) (point-y tp2)))
  33             (dy1 (- (point-x tp2) (point-x tp1)))
  34             (dx2 (- (point-y tp2) (point-y tp3)))
  35             (dy2 (- (point-x tp3) (point-x tp2))))
  36         (let* ((tg1 (/ dy1 dx1))
  37                (t2 (/ (- (- y1 y2)
  38                          (* (- (x1 x2)) tg1))
  39                       (- dy2 (* dx2 tg1))))
  40                (center (make-point
  41                         (+ x2 (* dx2 t2))
  42                         (+ y2 (* dy2 t2))))
  43                (radius (points-distance center tp1)))
  44           (make-raw-triangle (list tp1 tp2 tp3) center radius))))))
  45
  46 (define (triangle-has-edge triangle a b)
  47   (let ((points (triangle-points triangle)))
  48     (let ((p1 (car points))
  49           (p2 (cadr points))
  50           (p3 (caddr points)))
  51       (or (and (equal? p1 a) (equal? p2 b))
  52           (and (equal? p2 a) (equal? p3 b))
  53           (and (equal? p3 a) (equal? p1 b))))))