+++ /dev/null
-(define-module (dungeon-master geom triangle)
- #:use-module (srfi srfi-9)
- #:use-module (dungeon-master geom point)
- #:export (make-triangle
- triangle?
- triangle-points
- triangle-center
- triangle-radius
- triangle-has-edge))
-
-(define-record-type <triangle>
- (make-raw-triangle points center radius)
- triangle?
- (points triangle-points)
- (center triangle-center)
- (radius triangle-radius))
-
-(define (make-triangle p1 p2 p3)
- (let ((s (+ (* (- (point-x p2) (point-x p1))
- (+ (point-y p2) (point-y p1)))
- (* (- (point-x p3) (point-x p2))
- (+ (point-y p3) (point-y p2)))
- (* (- (point-x p1) (point-x p3))
- (+ (point-y p1) (point-y p3))))))
- (let ((tp1 p1)
- (tp2 (if (> s 0) p2 p3))
- (tp3 (if (> s 0) p3 p2)))
- (let ((x1 (/ (+ (point-x tp1) (point-x tp2)) 2))
- (y1 (/ (+ (point-y tp1) (point-y tp2)) 2))
- (x2 (/ (+ (point-x tp2) (point-x tp3)) 2))
- (y2 (/ (+ (point-y tp2) (point-y tp3)) 2))
- (dx1 (- (point-y tp1) (point-y tp2)))
- (dy1 (- (point-x tp2) (point-x tp1)))
- (dx2 (- (point-y tp2) (point-y tp3)))
- (dy2 (- (point-x tp3) (point-x tp2))))
- (let* ((tg1 (/ dy1 dx1))
- (t2 (/ (- (- y1 y2)
- (* (- (x1 x2)) tg1))
- (- dy2 (* dx2 tg1))))
- (center (make-point
- (+ x2 (* dx2 t2))
- (+ y2 (* dy2 t2))))
- (radius (points-distance center tp1)))
- (make-raw-triangle (list tp1 tp2 tp3) center radius))))))
-
-(define (triangle-has-edge triangle a b)
- (let ((points (triangle-points triangle)))
- (let ((p1 (car points))
- (p2 (cadr points))
- (p3 (caddr points)))
- (or (and (equal? p1 a) (equal? p2 b))
- (and (equal? p2 a) (equal? p3 b))
- (and (equal? p3 a) (equal? p1 b))))))