1 (define-module (dungeon-master geom voronoi)
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 (make-voronoi-mesh
13 "https://github.com/watabou/TownGeneratorOS/blob/master/Source/com/watabou/geom/Voronoi.hx"
15 (define-record-type <voronoi-mesh>
16 (make-raw-voronoi-mesh triangles points frame)
18 (triangles voronoi-mesh-triangles set-voronoi-mesh-triangles!)
19 (points voronoi-mesh-points set-voronoi-mesh-points!)
20 (frame voronoi-mesh-frame set-voronoi-mesh-frame!))
22 (define (make-voronoi-mesh vertices)
23 (receive (minx miny maxx maxy)
24 (calculate-mesh-limits vertices)
25 (let ((c1 (make-point minx miny))
26 (c2 (make-point minx maxy))
27 (c3 (make-point maxx miny))
28 (c4 (make-point maxx maxy)))
29 (let ((frame (list c1 c2 c3 c4))
30 (points (list c1 c2 c3 c4))
31 (triangles (list (make-triangle c1 c2 c3)
32 (make-triangle c2 c3 c4))))
35 (define (calculate-mesh-limits vertices)
36 (let ((xs (map (lambda (p) (point-x p)) vertices))
37 (ys (map (lambda (p) (point-y p)) vertices)))
38 (let ((minx (apply min (cons (expt 10 10) xs)))
39 (miny (apply min (cons (expt 10 10) ys)))
40 (maxx (apply max (cons (- (expt 10 9)) xs)))
41 (maxy (apply max (cons (- (expt 10 9)) ys))))
42 (let ((dx (* (- maxx minx) 0.5))
43 (dy (* (- maxy miny) 0.5)))
44 (values (- minx (/ dx 2))
47 (+ maxy (/ dy 2)))))))
49 (define (calculate-mesh points triangles vertices)
50 (cond ((null? vertices)
51 (values points triangles))
53 (let ((vertice (car vertices)))
54 (receive (to-split to-keep)
55 (triangles-contains-point triangles vertice)
56 (cond ((null? to-split)
57 (calculate-mesh points triangles (cdr vertices)))
59 (calculate-mesh (cons vertice points)
60 (concatenate (calculate-new-triangles to-split vertice)
62 (cdr vertices)))))))))
64 (define (calculate-new-triangles to-split p1)
65 (let ((vertices (calculate-new-vertices to-split)))
66 (let* ((a (car vertices))
69 (let loop ((sublist-a a)
72 (let ((p2 (car sublist-a))
73 (p3 (list-ref b (- len (length sublist-a)))))
75 (cons (make-triangle p1 p2 p3) triangles))))
79 (define* (calculate-new-vertices triangles #:optional (original-t triangles) (a '()) (b '()))
80 (cond ((null? triangles)
83 (let* ((triangle (car triangles))
84 (common-edge (triangles-has-common-edge triangle original-t)))
85 (let ((points (triangle-points triangle)))
86 (let ((p1 (car points))
89 (e1 (car common-edge))
90 (e2 (cadr common-edge))
91 (e3 (caddr common-edge)))
94 (set! b (cons p2 b))))
97 (set! b (cons p3 b))))
100 (set! b (cons p1 b))))
101 (calculate-new-vertices (cdr triangles) original-t a b)))))))
103 (define* (triangles-has-common-edge triangle triangles #:optional (e1 #t) (e2 #t) (e3 #t))
104 (cond ((not (or e1 e2 e3))
109 (let ((t (car triangles)))
110 (cond ((equal? t triangle)
111 (triangles-has-common-edge triangle (cdr triangles) e1 e2 e3))
113 (let ((points (triangle-points triangle)))
114 (let ((p1 (car points))
117 (when (and e1 (triangle-has-edge t p2 p1))
119 (when (and e2 (triangle-has-edge t p3 p2))
121 (when (and e3 (triangle-has-edge t p1 p3))
123 (triangles-has-common-edge triangle (cdr triangles) e1 e2 e3)))))))
125 (define (triangles-contains-point triangles point)
128 (< (points-distance point (triangle-center triangle))
129 (triangle-radius triangle)))