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))
9 "Compute the Delaunay triangulation using Bowyer–Watson algorithm"
11 (define (bowyer-watson vertices)
12 (receive (minx miny maxx maxy)
13 (calculate-limits vertices)
14 (let ((c1 (make-point minx miny))
15 (c2 (make-point minx maxy))
16 (c3 (make-point maxx miny))
17 (c4 (make-point maxx maxy)))
18 (let ((frame (list c1 c2 c3 c4)))
19 (receive (points triangles)
20 (calculate-triangulation
22 (list (make-triangle c1 c2 c3)
23 (make-triangle c2 c3 c4))
25 (values triangles points frame))))))
27 (define (calculate-limits vertices)
28 (let ((xs (map (lambda (p) (point-x p)) vertices))
29 (ys (map (lambda (p) (point-y p)) vertices)))
30 (let ((minx (apply min (cons (expt 10 10) xs)))
31 (miny (apply min (cons (expt 10 10) ys)))
32 (maxx (apply max (cons (- (expt 10 9)) xs)))
33 (maxy (apply max (cons (- (expt 10 9)) ys))))
34 (let ((dx (* (- maxx minx) 0.5))
35 (dy (* (- maxy miny) 0.5)))
36 (values (- minx (/ dx 2))
39 (+ maxy (/ dy 2)))))))
41 (define (calculate-triangulation points triangles vertices)
42 (cond ((null? vertices)
43 (values points triangles))
45 (let ((vertice (car vertices)))
46 (receive (to-split to-keep)
47 (triangles-contains-point triangles vertice)
48 (cond ((null? to-split)
49 (calculate-triangulation points triangles (cdr vertices)))
51 (calculate-triangulation
54 (list (calculate-new-triangles to-split vertice)
56 (cdr vertices)))))))))
58 (define (calculate-new-triangles to-split p1)
60 (calculate-new-edges to-split)
61 (let loop ((p2-list a)
64 (cond ((null? p2-list)
67 (let ((p2 (car p2-list))
71 (cons (make-triangle p1 p2 p3) triangles))))))))
73 (define* (calculate-new-edges triangles #:optional (original-t triangles) (a '()) (b '()))
74 (cond ((null? triangles)
77 (let* ((triangle (car triangles))
78 (common-edge (triangles-has-common-edge triangle original-t)))
79 (let ((points (triangle-points triangle)))
80 (let ((p1 (car points))
83 (e1 (car common-edge))
84 (e2 (cadr common-edge))
85 (e3 (caddr common-edge)))
88 (set! b (cons p2 b))))
91 (set! b (cons p3 b))))
94 (set! b (cons p1 b))))
95 (calculate-new-edges (cdr triangles) original-t a b)))))))
97 (define* (triangles-has-common-edge triangle triangles #:optional (e1 #t) (e2 #t) (e3 #t))
98 (cond ((not (or e1 e2 e3))
103 (let ((t (car triangles)))
104 (cond ((equal? t triangle)
105 (triangles-has-common-edge triangle (cdr triangles) e1 e2 e3))
107 (let ((points (triangle-points triangle)))
108 (let ((p1 (car points))
111 (when (and e1 (triangle-has-edge t p2 p1))
113 (when (and e2 (triangle-has-edge t p3 p2))
115 (when (and e3 (triangle-has-edge t p1 p3))
117 (triangles-has-common-edge triangle (cdr triangles) e1 e2 e3)))))))
119 (define (triangles-contains-point triangles point)
122 (< (points-distance point (triangle-center triangle))
123 (triangle-radius triangle)))