1 (define-module (dungeon-master geom voronoi)
2 #:use-module (ice-9 receive)
3 #:use-module (rnrs sorting)
4 #:use-module (srfi srfi-1)
5 #:use-module (srfi srfi-9)
6 #:use-module (dungeon-master geom)
7 #:use-module (dungeon-master geom point)
8 #:use-module (dungeon-master geom triangle)
9 #:use-module (dungeon-master geom bowyer-watson)
10 #:export (make-voronoi-mesh
12 voronoi-mesh-triangles
18 "https://github.com/watabou/TownGeneratorOS/blob/master/Source/com/watabou/geom/Voronoi.hx"
20 ;;; Voronoi mesh region
22 (define-record-type <voronoi-region>
23 (make-raw-voronoi-region seed vertices)
25 (seed voronoi-region-seed)
26 (vertices voronoi-region-vertices))
28 (define (make-voronoi-region seed vertices)
29 (define (compare-angles triangle1 triangle2)
30 (let ((c1 (triangle-center triangle1))
31 (c2 (triangle-center triangle2)))
32 (> (angle-sign seed c1 c2) 0)))
33 (make-raw-voronoi-region seed (list-sort compare-angles vertices)))
35 (define (voronoi-region-center region)
36 (let* ((vertices (voronoi-region-vertices region))
37 (centers (map (lambda (v) (triangle-center v)) vertices)))
39 (apply sum-points centers)
40 (/ 1 (length vertices)))))
45 (define-record-type <voronoi-mesh>
46 (make-raw-voronoi-mesh triangles points frame regions)
48 (triangles voronoi-mesh-triangles)
49 (points voronoi-mesh-points)
50 (frame voronoi-mesh-frame)
51 (regions voronoi-mesh-regions))
53 (define (make-voronoi-mesh vertices)
54 ;; Delaunay triangulation
55 (receive (triangles points frame)
56 (bowyer-watson vertices)
57 (make-raw-voronoi-mesh
61 (make-regions points triangles))))
63 (define (partitioning voronoi)
64 (define (is-real-triangle triangle)
65 ;; real triangle points cannot be frame points
66 (let ((frame (voronoi-mesh-frame voronoi)))
67 (let check-points ((points (triangle-points triangle)))
69 #t) ; triangle is real
71 (and (not (member (car points) frame))
72 (check-points (cdr points))))))))
74 (define (is-real-region region)
75 ;; real region points cannot be frame points
76 (let check-vertices ((vertices (voronoi-region-vertices region)))
77 (cond ((null? vertices)
80 (and (is-real-triangle (car vertices))
81 (check-vertices (cdr vertices)))))))
83 (let* ((points (voronoi-mesh-points voronoi))
84 (regions (voronoi-mesh-regions voronoi))
85 ;; we need the regions in the same order as points are
89 (assoc-ref regions p))
91 ;; only real regions without frame points
93 (filter (lambda (r) (is-real-region r))
97 (define* (voronoi-mesh-relax voronoi #:optional (points-to-relax '()))
100 (lambda (r) (cons (voronoi-region-seed r) (voronoi-region-center r)))
101 (partitioning voronoi)))
104 (lambda (p) (not (member p (voronoi-mesh-frame voronoi))))
105 (voronoi-mesh-points voronoi)))
107 (if (null? points-to-relax)
108 (voronoi-mesh-points voronoi)
113 (let ((center (assoc-ref regions point)))
114 (if (and center (member point to-relax))
119 (define (make-regions points triangles)
124 (lambda (tr) (member p (triangle-points tr)))
126 (cons p (make-voronoi-region p vertices))))