--- /dev/null
+(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 (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))
+ (build-patches patches))
+
+(define (build-patches patches)
+ (define* (get-points n seed #:optional (l '()))
+ (cond ((> n 0)
+ (let* ((a (+ seed (* (sqrt n) 5)))
+ (r (if (= n 0)
+ 0
+ (+ 10 (* n (+ 2 (random:exp))))))
+ (point (make-point
+ (* (cos a) r)
+ (* (sin a) r))))
+ (get-points (- n 1) seed (cons point l))))
+ (else
+ l)))
+
+ (let* ((sa (* (random:exp) 2 pi))
+ (points (get-points (* 8 patches) sa))
+ (voronoi (make-voronoi-mesh points)))
+ voronoi))
--- /dev/null
+(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 (bowyer-watson))
+
+"Compute the Delaunay triangulation using Bowyer–Watson algorithm"
+
+(define (bowyer-watson vertices)
+ (receive (minx miny maxx maxy)
+ (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)))
+ (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-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)))
+ (values (- minx (/ dx 2))
+ (- miny (/ dy 2))
+ (+ maxx (/ dx 2))
+ (+ maxy (/ dy 2)))))))
+
+(define (calculate-triangulation 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-triangulation points triangles (cdr vertices)))
+ (else
+ (calculate-triangulation
+ (cons vertice points)
+ (concatenate
+ (list (calculate-new-triangles to-split vertice)
+ to-keep))
+ (cdr vertices)))))))))
+
+(define (calculate-new-triangles to-split p1)
+ (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-edges triangles #:optional (original-t triangles) (a '()) (b '()))
+ (cond ((null? triangles)
+ (values 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-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))
+ (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))
--- /dev/null
+(define-module (dungeon-master geom point)
+ #:use-module (srfi srfi-9)
+ #:export (make-point
+ point?
+ point-x
+ point-y
+ points-distance))
+
+(define-record-type <point>
+ (make-point x y)
+ point?
+ (x point-x)
+ (y point-y))
+
+(define (points-distance p1 p2)
+ (abs
+ (sqrt (+ (expt (- (point-x p1) (point-x p2)) 2)
+ (expt (- (point-y p1) (point-y p2)) 2)))))
--- /dev/null
+(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 <triangle>
+ (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))))))
--- /dev/null
+(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 <voronoi-mesh>
+ (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)))
+++ /dev/null
-(define-module (dungeon-master plugins default)
- #:use-module ((dungeon-master) #:prefix dm:))
-
-(define (random-bool)
- (= (random 2) 1))
-
-(define pi 3.141592654)
-
-(define (city-map-generator 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))
- (build-patches patches))
-
-(define (build-patches patches)
- (define* (get-points n seed #:optional (l '()))
- (cond ((> n 0)
- (let* ((a (+ seed (* (sqrt n) 5)))
- (r (if (= n 0)
- 0
- (+ 10 (* n (+ 2 (random:exp))))))
- (point (list
- (* (cos a) r)
- (* (sin a) r))))
- (get-points (- n 1) seed (cons point l))))
- (else
- 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)
+++ /dev/null
-(define-module (dungeon-master geom point)
- #:use-module (srfi srfi-9)
- #:export (make-point
- point?
- point-x
- point-y))
-
-(define-record-type <point>
- (make-point x y)
- point?
- (x point-x)
- (y point-y))
-
-(define (points-distance p1 p2)
- (abs
- (sqrt (+ (expt (- (point-x p1) (point-x p2)) 2)
- (expt (- (point-y p1) (point-y p2)) 2)))))
+++ /dev/null
-(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 <triangle>
- (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))))))
+++ /dev/null
-(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)
- #: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 <voronoi-mesh>
- (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 (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)))
- (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))
projects / dungeon-master.git / commitdiff