1 (define-module (dungeon-master geom bowyer-watson)
2 #:use-module (ice-9 receive)
3 #:use-module (srfi srfi-1)
4 #:use-module (srfi srfi-9)
5 #:use-module (dungeon-master geom point)
6 #:use-module (dungeon-master geom triangle)
7 #:export (bowyer-watson))
10 Compute the Delaunay triangulation using Bowyer–Watson algorithm
11 https://en.wikipedia.org/wiki/Bowyer-Watson_algorithm
14 (define (bowyer-watson vertices)
15 (receive (minx miny maxx maxy)
16 (calculate-limits vertices)
17 (let ((c1 (make-point minx miny))
18 (c2 (make-point minx maxy))
19 (c3 (make-point maxx miny))
20 (c4 (make-point maxx maxy)))
21 (let ((frame (list c1 c2 c3 c4)))
22 (receive (points triangles)
23 (calculate-triangulation
25 (list (make-triangle c1 c2 c3)
26 (make-triangle c2 c3 c4))
28 (values triangles points frame))))))
30 (define (calculate-limits vertices)
31 (let ((xs (map (lambda (p) (point-x p)) vertices))
32 (ys (map (lambda (p) (point-y p)) vertices)))
33 (let ((minx (apply min (cons (expt 10 10) xs)))
34 (miny (apply min (cons (expt 10 10) ys)))
35 (maxx (apply max (cons (- (expt 10 9)) xs)))
36 (maxy (apply max (cons (- (expt 10 9)) ys))))
37 (let ((dx (* (- maxx minx) 0.5))
38 (dy (* (- maxy miny) 0.5)))
39 (values (- minx (/ dx 2))
42 (+ maxy (/ dy 2)))))))
44 (define (calculate-triangulation points triangles vertices)
45 (cond ((null? vertices)
46 (values points triangles))
48 (let ((vertice (car vertices)))
49 (receive (to-split to-keep)
50 (triangles-contains-point triangles vertice)
51 (cond ((null? to-split)
52 (calculate-triangulation points triangles (cdr vertices)))
54 (calculate-triangulation
57 (list (calculate-new-triangles to-split vertice)
59 (cdr vertices)))))))))
61 (define (calculate-new-triangles to-split p1)
63 (calculate-new-edges to-split)
64 (let loop ((p2-list a)
67 (cond ((null? p2-list)
70 (let ((p2 (car p2-list))
74 (cons (make-triangle p1 p2 p3) triangles))))))))
76 (define* (calculate-new-edges triangles #:optional (original-t triangles) (a '()) (b '()))
77 (cond ((null? triangles)
80 (let* ((triangle (car triangles))
81 (common-edge (triangles-has-common-edge triangle original-t)))
82 (let ((points (triangle-points triangle)))
83 (let ((p1 (car points))
86 (e1 (car common-edge))
87 (e2 (cadr common-edge))
88 (e3 (caddr common-edge)))
91 (set! b (cons p2 b))))
94 (set! b (cons p3 b))))
97 (set! b (cons p1 b))))
98 (calculate-new-edges (cdr triangles) original-t a b)))))))
100 (define* (triangles-has-common-edge triangle triangles #:optional (e1 #t) (e2 #t) (e3 #t))
101 (cond ((not (or e1 e2 e3))
106 (let ((t (car triangles)))
107 (cond ((equal? t triangle)
108 (triangles-has-common-edge triangle (cdr triangles) e1 e2 e3))
110 (let ((points (triangle-points triangle)))
111 (let ((p1 (car points))
114 (when (and e1 (triangle-has-edge t p2 p1))
116 (when (and e2 (triangle-has-edge t p3 p2))
118 (when (and e3 (triangle-has-edge t p1 p3))
120 (triangles-has-common-edge triangle (cdr triangles) e1 e2 e3)))))))
122 (define (triangles-contains-point triangles point)
125 (< (points-distance point (triangle-center triangle))
126 (triangle-radius triangle)))