From 4e1254800a1c453aba76b8ccd5b632f38a71aed7 Mon Sep 17 00:00:00 2001 From: Javier Sancho Date: Fri, 21 Jun 2019 17:59:48 +0200 Subject: [PATCH] Voronoi meshes (uncompleted) --- mods/default/triangle.scm | 12 +++- mods/default/voronoi.scm | 130 ++++++++++++++++++++++++++++++++------ 2 files changed, 122 insertions(+), 20 deletions(-) diff --git a/mods/default/triangle.scm b/mods/default/triangle.scm index 343bef3..c11ee1a 100644 --- a/mods/default/triangle.scm +++ b/mods/default/triangle.scm @@ -5,7 +5,8 @@ triangle? triangle-points triangle-center - triangle-radius)) + triangle-radius + triangle-has-edge)) (define-record-type (make-raw-triangle points center radius) @@ -41,3 +42,12 @@ (+ 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)))))) diff --git a/mods/default/voronoi.scm b/mods/default/voronoi.scm index f985daa..424f2d7 100644 --- a/mods/default/voronoi.scm +++ b/mods/default/voronoi.scm @@ -1,7 +1,14 @@ (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 triangle) + #: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" @@ -12,27 +19,112 @@ (points voronoi-mesh-points set-voronoi-mesh-points!) (frame voronoi-mesh-frame set-voronoi-mesh-frame!)) -(define (new-voronoi minx miny maxx maxy) - (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)))) - '()))) - -(define (make-voronoi-mesh points) - (let ((xs (map (lambda (p) (point-x p)) points)) - (ys (map (lambda (p) (point-y p)) points))) +(define (make-voronoi-mesh vertices) + (receive (minx miny maxx maxy) + (calculate-mesh-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)))) + '())))) + +(define (calculate-mesh-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))) (miny (apply min (cons (expt 10 10) ys))) (maxx (apply max (cons (- (expt 10 9)) xs))) (maxy (apply max (cons (- (expt 10 9)) ys)))) (let ((dx (* (- maxx minx) 0.5)) (dy (* (- maxy miny) 0.5))) - (new-voronoi (- minx (/ dx 2)) - (- miny (/ dy 2)) - (+ maxx (/ dx 2)) - (+ maxy (/ dy 2))))))) + (values (- minx (/ dx 2)) + (- miny (/ dy 2)) + (+ maxx (/ dx 2)) + (+ maxy (/ dy 2))))))) + +(define (calculate-mesh points triangles vertices) + (cond ((null? vertices) + (values points triangles)) + (else + (let ((vertice (car vertices))) + (receive (to-split to-keep) + (triangles-contains-point triangles vertice) + (cond ((null? to-split) + (calculate-mesh points triangles (cdr vertices))) + (else + (calculate-mesh (cons vertice points) + (concatenate (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)))))) + +(define* (calculate-new-vertices triangles #:optional (original-t triangles) (a '()) (b '())) + (cond ((null? triangles) + (list a b)) + (else + (let* ((triangle (car triangles)) + (common-edge (triangles-has-common-edge triangle original-t))) + (let ((points (triangle-points triangle))) + (let ((p1 (car points)) + (p2 (cadr points)) + (p3 (caddr points)) + (e1 (car common-edge)) + (e2 (cadr common-edge)) + (e3 (caddr common-edge))) + (cond (e1 + (set! a (cons p1 a)) + (set! b (cons p2 b)))) + (cond (e2 + (set! a (cons p2 a)) + (set! b (cons p3 b)))) + (cond (e3 + (set! a (cons p3 a)) + (set! b (cons p1 b)))) + (calculate-new-vertices (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)) + (list e1 e2 e3)) + ((null? triangles) + (list e1 e2 e3)) + (else + (let ((t (car triangles))) + (cond ((equal? t triangle) + (triangles-has-common-edge triangle (cdr triangles) e1 e2 e3)) + (else + (let ((points (triangle-points triangle))) + (let ((p1 (car points)) + (p2 (cadr points)) + (p3 (caddr points))) + (when (and e1 (triangle-has-edge t p2 p1)) + (set! e1 #f)) + (when (and e2 (triangle-has-edge t p3 p2)) + (set! e2 #f)) + (when (and e3 (triangle-has-edge t p1 p3)) + (set! e3 #f)))) + (triangles-has-common-edge triangle (cdr triangles) e1 e2 e3))))))) + +(define (triangles-contains-point triangles point) + (partition + (lambda (triangle) + (< (points-distance point (triangle-center triangle)) + (triangle-radius triangle))) + triangles)) -- 2.39.2