dungeon-master/geom/voronoi.scm

   1 (define-module (dungeon-master geom voronoi)
   2   #:use-module (ice-9 receive)
   3   #:use-module (srfi srfi-1)
   4   #:use-module (srfi srfi-9)
   5   #:use-module (dungeon-master geom point)
   6   #:use-module (dungeon-master geom triangle)
   7   #:use-module (dungeon-master geom bowyer-watson)
   8   #:export (make-voronoi-mesh
   9             voronoi-mesh?
  10             voronoi-mesh-triangles
  11             voronoi-mesh-points
  12             voronoi-mesh-frame
  13             voronoi-mesh-regions
  14             voronoi-mesh-relax))
  15
  16 "https://github.com/watabou/TownGeneratorOS/blob/master/Source/com/watabou/geom/Voronoi.hx"
  17
  18 ;;; Voronoi mesh region
  19
  20 (define-record-type <voronoi-region>
  21   (make-voronoi-region seed vertices)
  22   voronoi-region?
  23   (seed voronoi-region-seed)
  24   (vertices voronoi-region-vertices))
  25
  26
  27 ;;; Voronoi mesh
  28
  29 (define-record-type <voronoi-mesh>
  30   (make-raw-voronoi-mesh triangles points frame regions)
  31   voronoi-mesh?
  32   (triangles voronoi-mesh-triangles)
  33   (points voronoi-mesh-points)
  34   (frame voronoi-mesh-frame)
  35   (regions voronoi-mesh-regions))
  36
  37 (define* (make-voronoi-mesh vertices #:optional (relax-steps 3))
  38   ; Delaunay triangulation
  39   (receive (triangles points frame)
  40       (bowyer-watson vertices)
  41     (make-raw-voronoi-mesh
  42      triangles
  43      points
  44      frame
  45      (make-regions points triangles))))
  46
  47 (define* (voronoi-mesh-relax voronoi #:optional (to-relax '()))
  48   voronoi)
  49
  50 (define* (make-regions points triangles #:optional (regions '()))
  51   (cond ((null? points)
  52          regions)
  53         (else
  54          (let* ((p (car points))
  55                 (vertices (filter
  56                            (lambda (tr) (member p (triangle-points tr)))
  57                            triangles))
  58                 (region (make-voronoi-region p vertices)))
  59            (make-regions (cdr points)
  60                          triangles
  61                          (alist-cons p region regions))))))