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 ;;; Voronoi mesh
  36
  37 (define-record-type <voronoi-mesh>
  38   (make-raw-voronoi-mesh triangles points frame regions)
  39   voronoi-mesh?
  40   (triangles voronoi-mesh-triangles)
  41   (points voronoi-mesh-points)
  42   (frame voronoi-mesh-frame)
  43   (regions voronoi-mesh-regions))
  44
  45 (define* (make-voronoi-mesh vertices #:optional (relax-steps 3))
  46   ;; Delaunay triangulation
  47   (receive (triangles points frame)
  48       (bowyer-watson vertices)
  49     (make-raw-voronoi-mesh
  50      triangles
  51      points
  52      frame
  53      (make-regions points triangles))))
  54
  55 (define (partitioning voronoi)
  56   (define (is-real-triangle triangle)
  57     ;; real triangle points cannot be frame points
  58     (let ((frame (voronoi-mesh-frame voronoi)))
  59       (let check-points ((points (triangle-points triangle)))
  60         (cond ((null? points)
  61                #t)  ; triangle is real
  62               (else
  63                (and (not (member (car points) frame))
  64                     (check-points (cdr points))))))))
  65
  66   (define (is-real-region region)
  67     ;; real region points cannot be frame points
  68     (let check-vertices ((vertices (voronoi-region-vertices region)))
  69       (cond ((null? vertices)
  70              #t)  ; region is real
  71             (else
  72              (and (is-real-triangle (car vertices))
  73                   (check-vertices (cdr vertices)))))))
  74
  75   (let* ((points (voronoi-mesh-points voronoi))
  76          (regions (voronoi-mesh-regions voronoi))
  77          ;; we need the regions in the same order as points are
  78          (ordered-regions
  79           (map-in-order
  80            (lambda (p)
  81              (assoc-ref regions p))
  82            points))
  83          ;; only real regions without frame points
  84          (filtered-regions
  85           (filter (lambda (r) (is-real-region r))
  86                   ordered-regions)))
  87     filtered-regions))
  88
  89 (define* (voronoi-mesh-relax voronoi #:optional (to-relax '()))
  90   (let ((regions (partitioning voronoi)))
  91     voronoi))
  92
  93 (define (make-regions points triangles)
  94   (map-in-order
  95    (lambda (p)
  96      (let ((vertices
  97             (filter
  98              (lambda (tr) (member p (triangle-points tr)))
  99              triangles)))
 100        (cons p (make-voronoi-region p vertices))))
 101    points))