From 695ecf94f5bb10ced4e66b0b4d036de9965c02ca Mon Sep 17 00:00:00 2001 From: Javier Sancho Date: Wed, 10 Jul 2019 18:50:32 +0200 Subject: [PATCH] Voronoi meshes (uncompleted) --- .../generators/town.scm | 21 ++--- .../geom/bowyer-watson.scm | 82 +++++++++---------- .../default => dungeon-master/geom}/point.scm | 3 +- dungeon-master/geom/triangle.scm | 60 ++++++++++++++ dungeon-master/geom/voronoi.scm | 26 ++++++ mods/default/triangle.scm | 53 ------------ 6 files changed, 135 insertions(+), 110 deletions(-) rename mods/default/main.scm => dungeon-master/generators/town.scm (70%) rename mods/default/voronoi.scm => dungeon-master/geom/bowyer-watson.scm (62%) rename {mods/default => dungeon-master/geom}/point.scm (89%) create mode 100644 dungeon-master/geom/triangle.scm create mode 100644 dungeon-master/geom/voronoi.scm delete mode 100644 mods/default/triangle.scm diff --git a/mods/default/main.scm b/dungeon-master/generators/town.scm similarity index 70% rename from mods/default/main.scm rename to dungeon-master/generators/town.scm index 9e518c2..745a642 100644 --- a/mods/default/main.scm +++ b/dungeon-master/generators/town.scm @@ -1,12 +1,14 @@ -(define-module (dungeon-master plugins default) - #:use-module ((dungeon-master) #:prefix dm:)) +(define-module (dungeon-master generators town) + #:use-module (dungeon-master geom voronoi) + #:use-module (dungeon-master geom point) + #:export (generate)) (define (random-bool) (= (random 2) 1)) (define pi 3.141592654) -(define (city-map-generator patches) +(define (generate patches) "City generator from https://github.com/watabou/TownGeneratorOS/blob/master/Source/com/watabou/towngenerator/building/Model.hx" (set! *random-state* (random-state-from-platform)) (when (= patches -1) (set! patches 15)) @@ -19,7 +21,7 @@ (r (if (= n 0) 0 (+ 10 (* n (+ 2 (random:exp)))))) - (point (list + (point (make-point (* (cos a) r) (* (sin a) r)))) (get-points (- n 1) seed (cons point l)))) @@ -27,11 +29,6 @@ l))) (let* ((sa (* (random:exp) 2 pi)) - (points (get-points (* 8 patches) sa))) - (display points) - (newline))) - -(dm:register-scene-generator - "Default city" - "city" - city-map-generator) + (points (get-points (* 8 patches) sa)) + (voronoi (make-voronoi-mesh points))) + voronoi)) diff --git a/mods/default/voronoi.scm b/dungeon-master/geom/bowyer-watson.scm similarity index 62% rename from mods/default/voronoi.scm rename to dungeon-master/geom/bowyer-watson.scm index 424f2d7..e8b9ea5 100644 --- a/mods/default/voronoi.scm +++ b/dungeon-master/geom/bowyer-watson.scm @@ -1,38 +1,30 @@ -(define-module (dungeon-master geom voronoi) +(define-module (dungeon-master geom bowyer-watson) #:use-module (ice-9 receive) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (dungeon-master geom point) #:use-module (dungeon-master geom triangle) - #:export (make-voronoi-mesh - voronoi-mesh? - voronoi-mesh-triangles - voronoi-mesh-points - voronoi-mesh-frame)) + #:export (bowyer-watson)) -"https://github.com/watabou/TownGeneratorOS/blob/master/Source/com/watabou/geom/Voronoi.hx" +"Compute the Delaunay triangulation using Bowyer–Watson algorithm" -(define-record-type - (make-raw-voronoi-mesh triangles points frame) - voronoi-mesh? - (triangles voronoi-mesh-triangles set-voronoi-mesh-triangles!) - (points voronoi-mesh-points set-voronoi-mesh-points!) - (frame voronoi-mesh-frame set-voronoi-mesh-frame!)) - -(define (make-voronoi-mesh vertices) +(define (bowyer-watson vertices) (receive (minx miny maxx maxy) - (calculate-mesh-limits vertices) + (calculate-limits vertices) (let ((c1 (make-point minx miny)) (c2 (make-point minx maxy)) (c3 (make-point maxx miny)) (c4 (make-point maxx maxy))) - (let ((frame (list c1 c2 c3 c4)) - (points (list c1 c2 c3 c4)) - (triangles (list (make-triangle c1 c2 c3) - (make-triangle c2 c3 c4)))) - '())))) + (let ((frame (list c1 c2 c3 c4))) + (receive (points triangles) + (calculate-triangulation + (list c1 c2 c3 c4) + (list (make-triangle c1 c2 c3) + (make-triangle c2 c3 c4)) + vertices) + (values triangles points frame)))))) -(define (calculate-mesh-limits vertices) +(define (calculate-limits vertices) (let ((xs (map (lambda (p) (point-x p)) vertices)) (ys (map (lambda (p) (point-y p)) vertices))) (let ((minx (apply min (cons (expt 10 10) xs))) @@ -46,7 +38,7 @@ (+ maxx (/ dx 2)) (+ maxy (/ dy 2))))))) -(define (calculate-mesh points triangles vertices) +(define (calculate-triangulation points triangles vertices) (cond ((null? vertices) (values points triangles)) (else @@ -54,31 +46,33 @@ (receive (to-split to-keep) (triangles-contains-point triangles vertice) (cond ((null? to-split) - (calculate-mesh points triangles (cdr vertices))) + (calculate-triangulation points triangles (cdr vertices))) (else - (calculate-mesh (cons vertice points) - (concatenate (calculate-new-triangles to-split vertice) - to-keep) - (cdr vertices))))))))) + (calculate-triangulation + (cons vertice points) + (concatenate + (list (calculate-new-triangles to-split vertice) + to-keep)) + (cdr vertices))))))))) (define (calculate-new-triangles to-split p1) - (let ((vertices (calculate-new-vertices to-split))) - (let* ((a (car vertices)) - (b (cadr vertices)) - (len (length a))) - (let loop ((sublist-a a) - (triangles '())) - (cond (sublist-a - (let ((p2 (car sublist-a)) - (p3 (list-ref b (- len (length sublist-a))))) - (loop (member p3 a) - (cons (make-triangle p1 p2 p3) triangles)))) - (else - triangles)))))) + (receive (a b) + (calculate-new-edges to-split) + (let loop ((p2-list a) + (p3-list b) + (triangles '())) + (cond ((null? p2-list) + triangles) + (else + (let ((p2 (car p2-list)) + (p3 (car p3-list))) + (loop (cdr p2-list) + (cdr p3-list) + (cons (make-triangle p1 p2 p3) triangles)))))))) -(define* (calculate-new-vertices triangles #:optional (original-t triangles) (a '()) (b '())) +(define* (calculate-new-edges triangles #:optional (original-t triangles) (a '()) (b '())) (cond ((null? triangles) - (list a b)) + (values a b)) (else (let* ((triangle (car triangles)) (common-edge (triangles-has-common-edge triangle original-t))) @@ -98,7 +92,7 @@ (cond (e3 (set! a (cons p3 a)) (set! b (cons p1 b)))) - (calculate-new-vertices (cdr triangles) original-t a b))))))) + (calculate-new-edges (cdr triangles) original-t a b))))))) (define* (triangles-has-common-edge triangle triangles #:optional (e1 #t) (e2 #t) (e3 #t)) (cond ((not (or e1 e2 e3)) diff --git a/mods/default/point.scm b/dungeon-master/geom/point.scm similarity index 89% rename from mods/default/point.scm rename to dungeon-master/geom/point.scm index 6ce8d64..64faaac 100644 --- a/mods/default/point.scm +++ b/dungeon-master/geom/point.scm @@ -3,7 +3,8 @@ #:export (make-point point? point-x - point-y)) + point-y + points-distance)) (define-record-type (make-point x y) diff --git a/dungeon-master/geom/triangle.scm b/dungeon-master/geom/triangle.scm new file mode 100644 index 0000000..123dd05 --- /dev/null +++ b/dungeon-master/geom/triangle.scm @@ -0,0 +1,60 @@ +(define-module (dungeon-master geom triangle) + #:use-module (ice-9 receive) + #:use-module (srfi srfi-9) + #:use-module (dungeon-master geom point) + #:export (make-triangle + triangle? + triangle-points + triangle-center + triangle-radius + triangle-has-edge)) + +(define-record-type + (make-raw-triangle points center radius) + triangle? + (points triangle-points) + (center triangle-center) + (radius triangle-radius)) + +(define (make-triangle p1 p2 p3) + (let ((center (circumcenter p1 p2 p3))) + (make-raw-triangle + (list p1 p2 p3) + center + (points-distance center p1)))) + +(define (circumcenter p1 p2 p3) + (receive (a b c) + (perpendicular-line-from-points p1 p2) + (receive (e f g) + (perpendicular-line-from-points p2 p3) + (let ((determinant (- (* a f) (* e b)))) + (make-point + (/ (- (* f c) (* b g)) determinant) + (/ (- (* a g) (* e c)) determinant)))))) + +(define (perpendicular-line-from-points p1 p2) + (let ((x1 (point-x p1)) + (y1 (point-y p1)) + (x2 (point-x p2)) + (y2 (point-y p2))) + (let* ((a (- y2 y1)) + (b (- x1 x2)) + (c (+ (* a x1) (* b y2)))) + (let ((mid-x (/ (+ x1 x2) 2)) + (mid-y (/ (+ y1 y2) 2))) + (values (- b) + a + (+ (* (- b) mid-x) (* a mid-y))))))) + +(define (triangle-has-edge triangle a b) + (let ((points (triangle-points triangle))) + (let ((p1 (car points)) + (p2 (cadr points)) + (p3 (caddr points))) + (or (and (equal? p1 a) (equal? p2 b)) + (and (equal? p1 b) (equal? p2 a)) + (and (equal? p2 a) (equal? p3 b)) + (and (equal? p2 b) (equal? p3 a)) + (and (equal? p3 a) (equal? p1 b)) + (and (equal? p3 b) (equal? p1 a)))))) diff --git a/dungeon-master/geom/voronoi.scm b/dungeon-master/geom/voronoi.scm new file mode 100644 index 0000000..7a9c457 --- /dev/null +++ b/dungeon-master/geom/voronoi.scm @@ -0,0 +1,26 @@ +(define-module (dungeon-master geom voronoi) + #:use-module (ice-9 receive) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (dungeon-master geom point) + #:use-module (dungeon-master geom triangle) + #:use-module (dungeon-master geom bowyer-watson) + #:export (make-voronoi-mesh + voronoi-mesh? + voronoi-mesh-triangles + voronoi-mesh-points + voronoi-mesh-frame)) + +"https://github.com/watabou/TownGeneratorOS/blob/master/Source/com/watabou/geom/Voronoi.hx" + +(define-record-type + (make-raw-voronoi-mesh triangles points frame) + voronoi-mesh? + (triangles voronoi-mesh-triangles set-voronoi-mesh-triangles!) + (points voronoi-mesh-points set-voronoi-mesh-points!) + (frame voronoi-mesh-frame set-voronoi-mesh-frame!)) + +(define (make-voronoi-mesh vertices) + (receive (triangles points frame) + (bowyer-watson vertices) + (make-raw-voronoi-mesh triangles points frame))) diff --git a/mods/default/triangle.scm b/mods/default/triangle.scm deleted file mode 100644 index c11ee1a..0000000 --- a/mods/default/triangle.scm +++ /dev/null @@ -1,53 +0,0 @@ -(define-module (dungeon-master geom triangle) - #:use-module (srfi srfi-9) - #:use-module (dungeon-master geom point) - #:export (make-triangle - triangle? - triangle-points - triangle-center - triangle-radius - triangle-has-edge)) - -(define-record-type - (make-raw-triangle points center radius) - triangle? - (points triangle-points) - (center triangle-center) - (radius triangle-radius)) - -(define (make-triangle p1 p2 p3) - (let ((s (+ (* (- (point-x p2) (point-x p1)) - (+ (point-y p2) (point-y p1))) - (* (- (point-x p3) (point-x p2)) - (+ (point-y p3) (point-y p2))) - (* (- (point-x p1) (point-x p3)) - (+ (point-y p1) (point-y p3)))))) - (let ((tp1 p1) - (tp2 (if (> s 0) p2 p3)) - (tp3 (if (> s 0) p3 p2))) - (let ((x1 (/ (+ (point-x tp1) (point-x tp2)) 2)) - (y1 (/ (+ (point-y tp1) (point-y tp2)) 2)) - (x2 (/ (+ (point-x tp2) (point-x tp3)) 2)) - (y2 (/ (+ (point-y tp2) (point-y tp3)) 2)) - (dx1 (- (point-y tp1) (point-y tp2))) - (dy1 (- (point-x tp2) (point-x tp1))) - (dx2 (- (point-y tp2) (point-y tp3))) - (dy2 (- (point-x tp3) (point-x tp2)))) - (let* ((tg1 (/ dy1 dx1)) - (t2 (/ (- (- y1 y2) - (* (- (x1 x2)) tg1)) - (- dy2 (* dx2 tg1)))) - (center (make-point - (+ x2 (* dx2 t2)) - (+ y2 (* dy2 t2)))) - (radius (points-distance center tp1))) - (make-raw-triangle (list tp1 tp2 tp3) center radius)))))) - -(define (triangle-has-edge triangle a b) - (let ((points (triangle-points triangle))) - (let ((p1 (car points)) - (p2 (cadr points)) - (p3 (caddr points))) - (or (and (equal? p1 a) (equal? p2 b)) - (and (equal? p2 a) (equal? p3 b)) - (and (equal? p3 a) (equal? p1 b)))))) -- 2.39.2