X-Git-Url: https://git.jsancho.org/?p=dungeon-master.git;a=blobdiff_plain;f=mods%2Fdefault%2Ftriangle.scm;fp=mods%2Fdefault%2Ftriangle.scm;h=343bef3c0e837b1c36626404eba8f5431993e9e7;hp=0000000000000000000000000000000000000000;hb=38c209feff157e50f85acf162b5d47419b5b4631;hpb=fbd191437dc6e137521891bcddf0e75731f026fe

diff --git a/mods/default/triangle.scm b/mods/default/triangle.scm
new file mode 100644
index 0000000..343bef3
--- /dev/null
+++ b/mods/default/triangle.scm
@@ -0,0 +1,43 @@
+(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))
+
+(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))))))