dungeon-master/geom/voronoi.scm

   1 (define-module (dungeon-master geom voronoi)
   2   #:use-module (ice-9 receive)
   3   #:use-module (rnrs sorting)
   4   #:use-module (srfi srfi-1)
   5   #:use-module (srfi srfi-9)
   6   #:use-module (dungeon-master geom)
   7   #:use-module (dungeon-master geom point)
   8   #:use-module (dungeon-master geom triangle)
   9   #:use-module (dungeon-master geom bowyer-watson)
  10   #:export (make-voronoi-mesh
  11             voronoi-mesh?
  12             voronoi-mesh-triangles
  13             voronoi-mesh-points
  14             voronoi-mesh-frame
  15             voronoi-mesh-regions
  16             voronoi-mesh-relax))
  17
  18 "https://github.com/watabou/TownGeneratorOS/blob/master/Source/com/watabou/geom/Voronoi.hx"
  19
  20 ;;; Voronoi mesh region
  21
  22 (define-record-type <voronoi-region>
  23   (make-raw-voronoi-region seed vertices)
  24   voronoi-region?
  25   (seed voronoi-region-seed)
  26   (vertices voronoi-region-vertices))
  27
  28 (define (make-voronoi-region seed vertices)
  29   (define (compare-angles triangle1 triangle2)
  30     (let ((c1 (triangle-center triangle1))
  31           (c2 (triangle-center triangle2)))
  32       (> (angle-sign seed c1 c2) 0)))
  33   (make-raw-voronoi-region seed (list-sort compare-angles vertices)))
  34
  35 (define (voronoi-region-center region)
  36   (let* ((vertices (voronoi-region-vertices region))
  37          (centers (map (lambda (v) (triangle-center v)) vertices)))
  38     (scale-point
  39      (apply sum-points centers)
  40      (/ 1 (length vertices)))))
  41
  42
  43 ;;; Voronoi mesh
  44
  45 (define-record-type <voronoi-mesh>
  46   (make-raw-voronoi-mesh triangles points frame regions)
  47   voronoi-mesh?
  48   (triangles voronoi-mesh-triangles)
  49   (points voronoi-mesh-points)
  50   (frame voronoi-mesh-frame)
  51   (regions voronoi-mesh-regions))
  52
  53 (define (make-voronoi-mesh vertices)
  54   ;; Delaunay triangulation
  55   (receive (triangles points frame)
  56       (bowyer-watson vertices)
  57     (make-raw-voronoi-mesh
  58      triangles
  59      points
  60      frame
  61      (make-regions points triangles))))
  62
  63 (define (partitioning voronoi)
  64   (define (is-real-triangle triangle)
  65     ;; real triangle points cannot be frame points
  66     (let ((frame (voronoi-mesh-frame voronoi)))
  67       (let check-points ((points (triangle-points triangle)))
  68         (cond ((null? points)
  69                #t)  ; triangle is real
  70               (else
  71                (and (not (member (car points) frame))
  72                     (check-points (cdr points))))))))
  73
  74   (define (is-real-region region)
  75     ;; real region points cannot be frame points
  76     (let check-vertices ((vertices (voronoi-region-vertices region)))
  77       (cond ((null? vertices)
  78              #t)  ; region is real
  79             (else
  80              (and (is-real-triangle (car vertices))
  81                   (check-vertices (cdr vertices)))))))
  82
  83   (let* ((points (voronoi-mesh-points voronoi))
  84          (regions (voronoi-mesh-regions voronoi))
  85          ;; we need the regions in the same order as points are
  86          (ordered-regions
  87           (map-in-order
  88            (lambda (p)
  89              (assoc-ref regions p))
  90            points))
  91          ;; only real regions without frame points
  92          (filtered-regions
  93           (filter (lambda (r) (is-real-region r))
  94                   ordered-regions)))
  95     filtered-regions))
  96
  97 (define* (voronoi-mesh-relax voronoi #:optional (points-to-relax '()))
  98   (let ((regions
  99          (map
 100           (lambda (r) (cons (voronoi-region-seed r) (voronoi-region-center r)))
 101           (partitioning voronoi)))
 102         (points
 103          (filter
 104           (lambda (p) (not (member p (voronoi-mesh-frame voronoi))))
 105           (voronoi-mesh-points voronoi)))
 106         (to-relax
 107          (if (null? points-to-relax)
 108              (voronoi-mesh-points voronoi)
 109              points-to-relax)))
 110     (make-voronoi-mesh
 111      (map
 112       (lambda (point)
 113         (let ((center (assoc-ref regions point)))
 114           (if (and center (member point to-relax))
 115               center
 116               point)))
 117       points))))
 118
 119 (define (make-regions points triangles)
 120   (map-in-order
 121    (lambda (p)
 122      (let ((vertices
 123             (filter
 124              (lambda (tr) (member p (triangle-points tr)))
 125              triangles)))
 126        (cons p (make-voronoi-region p vertices))))
 127    points))