From: Javier Sancho Date: Fri, 2 Aug 2019 16:59:23 +0000 (+0200) Subject: Make regions from the Delaunay triangulation X-Git-Url: https://git.jsancho.org/?a=commitdiff_plain;h=09c4aef3b2dde4e8fdf0a4b673b36c1ddbc84b6e;p=dungeon-master.git Make regions from the Delaunay triangulation --- diff --git a/dungeon-master/generators/town.scm b/dungeon-master/generators/town.scm index e8e6d95..cefa138 100644 --- a/dungeon-master/generators/town.scm +++ b/dungeon-master/generators/town.scm @@ -17,7 +17,7 @@ (define (build-patches n-patches) (define* (get-points n seed #:optional (l '())) - (cond ((> n 0) + (cond ((>= n 0) (let* ((a (+ seed (* (sqrt n) 5))) (r (if (= n 0) 0 diff --git a/dungeon-master/geom.scm b/dungeon-master/geom.scm new file mode 100644 index 0000000..96cc378 --- /dev/null +++ b/dungeon-master/geom.scm @@ -0,0 +1,20 @@ +(define-module (dungeon-master geom) + #:use-module (dungeon-master geom point) + #:export (angle-sign)) + + +(define (angle-sign center a b) + "Return the sign of (- (atan (- a center)) + (atan (- b center)))" + (let ((x1 (- (point-x a) (point-x center))) + (y1 (- (point-y a) (point-y center))) + (x2 (- (point-x b) (point-x center))) + (y2 (- (point-y b) (point-y center)))) + (cond ((and (>= x1 0) (< x2 0)) + 1) + ((and (>= x2 0) (< x1 0)) + -1) + ((and (= x1 0) (= x2 0)) + (if (> y2 y1) 1 -1)) + (else + (if (> (- (* x2 y1) (* x1 y2)) 0) 1 -1))))) diff --git a/dungeon-master/geom/voronoi.scm b/dungeon-master/geom/voronoi.scm index 3f55946..9217285 100644 --- a/dungeon-master/geom/voronoi.scm +++ b/dungeon-master/geom/voronoi.scm @@ -1,7 +1,9 @@ (define-module (dungeon-master geom voronoi) #:use-module (ice-9 receive) + #:use-module (rnrs sorting) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (dungeon-master geom) #:use-module (dungeon-master geom point) #:use-module (dungeon-master geom triangle) #:use-module (dungeon-master geom bowyer-watson) @@ -18,11 +20,17 @@ ;;; Voronoi mesh region (define-record-type - (make-voronoi-region seed vertices) + (make-raw-voronoi-region seed vertices) voronoi-region? (seed voronoi-region-seed) (vertices voronoi-region-vertices)) +(define (make-voronoi-region seed vertices) + (define (compare-angles triangle1 triangle2) + (let ((c1 (triangle-center triangle1)) + (c2 (triangle-center triangle2))) + (> (angle-sign seed c1 c2) 0))) + (make-raw-voronoi-region seed (list-sort compare-angles vertices))) ;;; Voronoi mesh @@ -35,7 +43,7 @@ (regions voronoi-mesh-regions)) (define* (make-voronoi-mesh vertices #:optional (relax-steps 3)) - ; Delaunay triangulation + ;; Delaunay triangulation (receive (triangles points frame) (bowyer-watson vertices) (make-raw-voronoi-mesh @@ -44,18 +52,50 @@ frame (make-regions points triangles)))) +(define (partitioning voronoi) + (define (is-real-triangle triangle) + ;; real triangle points cannot be frame points + (let ((frame (voronoi-mesh-frame voronoi))) + (let check-points ((points (triangle-points triangle))) + (cond ((null? points) + #t) ; triangle is real + (else + (and (not (member (car points) frame)) + (check-points (cdr points)))))))) + + (define (is-real-region region) + ;; real region points cannot be frame points + (let check-vertices ((vertices (voronoi-region-vertices region))) + (cond ((null? vertices) + #t) ; region is real + (else + (and (is-real-triangle (car vertices)) + (check-vertices (cdr vertices))))))) + + (let* ((points (voronoi-mesh-points voronoi)) + (regions (voronoi-mesh-regions voronoi)) + ;; we need the regions in the same order as points are + (ordered-regions + (map-in-order + (lambda (p) + (assoc-ref regions p)) + points)) + ;; only real regions without frame points + (filtered-regions + (filter (lambda (r) (is-real-region r)) + ordered-regions))) + filtered-regions)) + (define* (voronoi-mesh-relax voronoi #:optional (to-relax '())) - voronoi) - -(define* (make-regions points triangles #:optional (regions '())) - (cond ((null? points) - regions) - (else - (let* ((p (car points)) - (vertices (filter - (lambda (tr) (member p (triangle-points tr))) - triangles)) - (region (make-voronoi-region p vertices))) - (make-regions (cdr points) - triangles - (alist-cons p region regions)))))) + (let ((regions (partitioning voronoi))) + voronoi)) + +(define (make-regions points triangles) + (map-in-order + (lambda (p) + (let ((vertices + (filter + (lambda (tr) (member p (triangle-points tr))) + triangles))) + (cons p (make-voronoi-region p vertices)))) + points))