1075 lines
38 KiB
Racket
1075 lines
38 KiB
Racket
#lang racket/base
|
|
|
|
; Island generator
|
|
|
|
(require
|
|
racket/math
|
|
racket/list
|
|
racket/function
|
|
data/queue
|
|
"island/island.rkt"
|
|
"island/biome.rkt"
|
|
"../collection/2d-array.rkt"
|
|
"../base-generation/noise.rkt"
|
|
"../base-generation/random.rkt")
|
|
|
|
(provide
|
|
; Constructor
|
|
island-generate
|
|
)
|
|
|
|
; Island generation, step 1: generate altitude
|
|
(define (island-set-altitude! island)
|
|
(define cells (island-cells island))
|
|
(define size (min (2d-array-width cells) (2d-array-height cells)))
|
|
(define half-size (/ size 2))
|
|
(define noise-size (floor (/ size 12)))
|
|
(define ns (make-noise 2 noise-size))
|
|
(define (block i n) (* n (quotient i n)))
|
|
(2d-array-for-each/indexes
|
|
(island-cells island)
|
|
(lambda (cell i j)
|
|
(set-cell-altitude!
|
|
cell
|
|
(* 7
|
|
(+ -200
|
|
(* 400 (* (sin (/ (* pi i) size)) (sin (/ (* pi j) size))))
|
|
(* -100 (+ (expt (- i half-size) 2) (expt (- j half-size) 2)) (/ 2 (* size size)))
|
|
(* 200 (noise-gradient-value ns i j))
|
|
(* 25 (noise-value ns (block i 3) (block j 3)))
|
|
(* 25 (noise-value ns (block i 1) (block j 1)))
|
|
)))))
|
|
)
|
|
|
|
; Island generation, step 2: erosion pass
|
|
; The erosion pass redistributes the altitudes around the neighbour cells
|
|
(define (island-erode! island)
|
|
(define cells (island-cells island))
|
|
; 1st pass - sum the contribution from all neighbours
|
|
(define new-alt-1
|
|
(2d-array-map/indexes
|
|
cells
|
|
(lambda (cell i j)
|
|
(define alt (cell-altitude cell))
|
|
(foldl
|
|
(lambda (v res)
|
|
(define x (+ i (caar v)))
|
|
(define y (+ j (cdar v)))
|
|
(define factor (cdr v))
|
|
(cond
|
|
((2d-array-inside? cells x y)
|
|
(define alt-next (island-altitude island x y))
|
|
(+ res (* (- alt-next alt) factor)))
|
|
(#t res)))
|
|
alt
|
|
; each element of the neighbour array is [position . factor]
|
|
'([(0 . 1) . 1/8] [(0 . -1) . 1/8] [(1 . 0) . 1/8] [(-1 . 0) . 1/8] ; adjacent
|
|
[(1 . 1) . 1/12] [(-1 . 1) . 1/12] [(1 . -1) . 1/12] [(-1 . -1) . 1/12] ; corners
|
|
)))))
|
|
; 2nd pass - sum the contributions from the highest (+) and lowest (-) only
|
|
(define new-alt-2
|
|
(2d-array-map/indexes
|
|
new-alt-1
|
|
(lambda (alt i j)
|
|
(define add-remove
|
|
(foldl
|
|
(lambda (v res)
|
|
(define x (+ i (car v)))
|
|
(define y (+ j (cdr v)))
|
|
(cond
|
|
((2d-array-inside? new-alt-1 x y)
|
|
(define alt-next (2d-array-ref new-alt-1 x y))
|
|
(define diff-next (- alt-next alt))
|
|
(cons (max (car res) diff-next)
|
|
(min (cdr res) diff-next)))
|
|
(#t res)))
|
|
'(0 . 0)
|
|
; each element of the neighbour array is position
|
|
'((0 . 1) (0 . -1) (1 . 0) (-1 . 0)))) ; adjacent
|
|
(+ alt (/ (car add-remove) 3) (/ (cdr add-remove) 3))
|
|
)))
|
|
; Update the altitudes
|
|
(2d-array-for-each/indexes
|
|
cells
|
|
(lambda (cell i j)
|
|
(set-cell-altitude!
|
|
cell
|
|
(2d-array-ref new-alt-2 i j))))
|
|
)
|
|
|
|
; Island generation, step 3: Add the sea biome
|
|
(define (island-set-sea! island)
|
|
(2d-array-flood-map!
|
|
(island-cells island)
|
|
0 0
|
|
(lambda (cell)
|
|
(set-cell-biome! cell 'sea)
|
|
cell)
|
|
(lambda (init-cell visited-cell)
|
|
(and (not (cell-biome visited-cell))
|
|
(<= (cell-altitude visited-cell) 0)))
|
|
))
|
|
|
|
; Island generation, step 4: Temperatures
|
|
; Compute the temperature, depending on the altitude and latitude
|
|
(define (island-set-temperature! island)
|
|
(define lat (+ 20 (random 45))) ; latitude of the island
|
|
(2d-array-for-each
|
|
(island-cells island)
|
|
(lambda (cell)
|
|
; Altitude is 0 for the sea
|
|
(define alt
|
|
(or (and (eq? 'sea (cell-biome cell)) 0)
|
|
(cell-altitude cell)))
|
|
(set-cell-temperature!
|
|
cell
|
|
(+ ; Approximative model:
|
|
; 28°C at equator, 0°C at 70° lat
|
|
; the 1.8 parameters is here to get temperatures at around 20°C at 35° lat, 15°C at 45° lat, 10°C at 55° lat
|
|
(+ 28 (* -28 (expt (/ lat 70) 1.8)))
|
|
; Usual model for loss of temperature depending on the altitude
|
|
(* alt (/ -0.64 100))
|
|
; TODO: distance to sea ?
|
|
)))))
|
|
|
|
; Wind structure
|
|
; Used in rainfall
|
|
(struct wind
|
|
(direction
|
|
increment))
|
|
; Make a list of winds from a main direction and a set of booleans indicating which winds are added
|
|
(define (make-winds dir M? A? P? AO? O?)
|
|
(append
|
|
; main direction
|
|
(if M? (list (wind dir 1)) (list))
|
|
; adjacents
|
|
(if A?
|
|
(list
|
|
(wind
|
|
(cond
|
|
((eq? (car dir) 0) (cons -1 (cdr dir)))
|
|
((eq? (cdr dir) 0) (cons (car dir) -1))
|
|
(#t (cons (car dir) 0)))
|
|
4)
|
|
(wind
|
|
(cond
|
|
((eq? (car dir) 0) (cons 1 (cdr dir)))
|
|
((eq? (cdr dir) 0) (cons (car dir) 1))
|
|
(#t (cons 0 (cdr dir))))
|
|
4))
|
|
(list))
|
|
; perpendiculars
|
|
(if P?
|
|
(list
|
|
(wind
|
|
(cons (* -1 (cdr dir)) (car dir))
|
|
9)
|
|
(wind
|
|
(cons (cdr dir) (* -1 (car dir)))
|
|
9))
|
|
(list))
|
|
; Adjacents' opposites
|
|
(if AO?
|
|
(list
|
|
(wind
|
|
(cond
|
|
((eq? (car dir) 0) (cons 1 (* -1 (cdr dir))))
|
|
((eq? (cdr dir) 0) (cons (* -1 (car dir)) 1))
|
|
(#t (cons (* -1 (car dir)) 0)))
|
|
19)
|
|
(wind
|
|
(cond
|
|
((eq? (car dir) 0) (cons -1 (* -1 (cdr dir))))
|
|
((eq? (cdr dir) 0) (cons (* -1 (car dir)) -1))
|
|
(#t (cons 0 (* -1 (cdr dir)))))
|
|
19))
|
|
(list))
|
|
; Opposite
|
|
(if O?
|
|
(list
|
|
(wind
|
|
(cons (* -1 (car dir)) (* -1 (cdr dir)))
|
|
39))
|
|
(list))
|
|
))
|
|
|
|
; Winds + starting pos
|
|
(define (pos+winds dir width height M? A? P? AO? O?)
|
|
(case dir
|
|
; each element is '(start-pos wind ...)
|
|
; Wind from NW
|
|
((NW) (cons '(0 . 0) (make-winds '(1 . 1) M? A? P? AO? O?)))
|
|
; Wind from SW
|
|
((SW) (cons `(0 . ,(- height 1)) (make-winds '(1 . -1) M? A? P? AO? O?)))
|
|
; Wind from NE
|
|
((NE) (cons `(,(- width 1) . 0) (make-winds '(-1 . 1) M? A? P? AO? O?)))
|
|
; Wind from SE
|
|
((SE) (cons `(,(- width 1) . ,(- height 1)) (make-winds '(-1 . -1) M? A? P? AO? O?)))
|
|
; Wind from N
|
|
((N) (cons `(,(floor (/ width 2)) . 0) (make-winds '(0 . 1) M? A? P? AO? O?)))
|
|
; Wind from S
|
|
((S) (cons `(,(floor (/ width 2)) . ,(- height 1)) (make-winds '(0 . -1) M? A? P? AO? O?)))
|
|
; Wind from W
|
|
((W) (cons `(0 . ,(floor (/ height 2))) (make-winds '(1 . 0) M? A? P? AO? O?)))
|
|
; Wind from E
|
|
((E) (cons `(,(- width 1) . ,(floor (/ height 2))) (make-winds '(-1 . 0) M? A? P? AO? O?)))
|
|
))
|
|
|
|
; Island generation, step 5: Set rainfall
|
|
; This is done by computing a distance to sea from a dominant wind
|
|
(define (island-set-rainfall! island)
|
|
(define is-cells (island-cells island))
|
|
(define width (2d-array-width is-cells))
|
|
(define height (2d-array-height is-cells))
|
|
; Directional flood-map function
|
|
; Visit every node from a queue and apply the function
|
|
; The function should return a value passed to the next cell, or #f to stop
|
|
; If the function return non-#f, add the neighbours computed from dirs to the queue
|
|
; Repeat until there is no more
|
|
(define (directional-flood-map! arr fun pos-queue dirs)
|
|
(when (not (queue-empty? pos-queue))
|
|
(define val+pos (dequeue! pos-queue))
|
|
(define val (car val+pos))
|
|
(define pos (cdr val+pos))
|
|
(define i (car pos))
|
|
(define j (cdr pos))
|
|
(define cell (2d-array-ref arr i j))
|
|
(define current (fun cell val i j))
|
|
(when current
|
|
(2d-array-set! arr i j current)
|
|
(for-each
|
|
(lambda (x)
|
|
(define next-dir (wind-direction x))
|
|
(define next-i (+ (car next-dir) i))
|
|
(define next-j (+ (cdr next-dir) j))
|
|
(when (2d-array-inside? arr next-i next-j)
|
|
(enqueue! pos-queue
|
|
(cons
|
|
(+ current (wind-increment x))
|
|
(cons next-i next-j)))))
|
|
dirs))
|
|
(directional-flood-map! arr fun pos-queue dirs)))
|
|
; Function to set the distance to sea with a threshold
|
|
(define (make-dist-to-sea-func threshold)
|
|
(lambda (cell next i j)
|
|
(define icell (2d-array-ref is-cells i j))
|
|
(define alt (cell-altitude icell))
|
|
(define sea? (eq? 'sea (cell-biome icell)))
|
|
(define above-thres? (< threshold alt))
|
|
; Next value
|
|
(define new
|
|
(cond
|
|
(sea? 0)
|
|
(above-thres?
|
|
(min cell (+ 15 next)))
|
|
(#t (min cell next))))
|
|
(if (equal? cell new) #f new)))
|
|
; Choose a dominant wind: a starting position and winds
|
|
(define dominant-wind (random:from-list '(NW SW NE SE N S W E)))
|
|
; Distances to sea
|
|
(define distances-to-sea
|
|
(build-list 3 (lambda (_) (make-2d-array width height +inf.0))))
|
|
(for-each
|
|
(lambda (arr thres pos+wind)
|
|
(define pos-queue (make-queue))
|
|
(enqueue! pos-queue (cons 0 (car pos+wind)))
|
|
(directional-flood-map!
|
|
arr
|
|
(make-dist-to-sea-func thres)
|
|
pos-queue
|
|
(cdr pos+wind)))
|
|
distances-to-sea
|
|
'(888 1515 2121)
|
|
(list
|
|
(pos+winds dominant-wind width height #t #f #f #t #f) ; M + AO
|
|
(pos+winds dominant-wind width height #f #t #f #f #t) ; A + O
|
|
(pos+winds dominant-wind width height #f #t #t #f #f)) ; A + P
|
|
)
|
|
; Convert a distance to sea, altitude and temperature to a rainfall
|
|
; The rainfalls decrease with the distance to sea, but increase with altitude
|
|
(define (compute-rainfall dists alt temp)
|
|
(max
|
|
0
|
|
(+
|
|
(foldl
|
|
(lambda (dist weight max-dist ret)
|
|
(+ ret (* weight (max 0 (/ (- max-dist dist) max-dist)))))
|
|
0
|
|
dists
|
|
'(175 75 50)
|
|
'(75 125 250))
|
|
(* alt 1/60)
|
|
(* -50 temp 1/50)
|
|
)))
|
|
; Update island
|
|
(2d-array-for-each/indexes
|
|
is-cells
|
|
(lambda (cell i j)
|
|
(define alt (cell-altitude cell))
|
|
(define temp (cell-temperature cell))
|
|
(define dists (map (lambda (arr) (2d-array-ref arr i j)) distances-to-sea))
|
|
(set-cell-rainfall! cell (compute-rainfall dists (max alt 0) temp))))
|
|
)
|
|
|
|
; Island generation, step 6: Determine the river springs
|
|
; All places with a rainfall > 100 are candidates for river springs
|
|
; However, river springs cannot be placed on two adjacent cells
|
|
(define (add-river-springs! island)
|
|
; collect all the positions with rainfall > 100, with their rainfall (exclude sea)
|
|
(define candidates
|
|
(2d-array-fold/indexes
|
|
(island-cells island)
|
|
(list)
|
|
(lambda (cell i j res)
|
|
(if (and (> (cell-rainfall cell) 100)
|
|
(not (eq? 'sea (cell-biome cell))))
|
|
(cons
|
|
(list (cons i j) (cell-rainfall cell))
|
|
res)
|
|
res))))
|
|
; sort the candidates by decreasing rainfall,
|
|
; and set the springs
|
|
(for-each
|
|
(lambda (x)
|
|
(define i (caar x))
|
|
(define j (cdar x))
|
|
; check there is no spring on an adjacent tiles in a radius of 2
|
|
(when (null?
|
|
(filter
|
|
(lambda (pos)
|
|
(and
|
|
(island-is-inside? island (+ i (car pos)) (+ j (cdr pos)))
|
|
(island-river-spring? island (+ i (car pos)) (+ j (cdr pos)))
|
|
))
|
|
'(( 2 . 2) ( 2 . 1) ( 2 . 0) ( 2 . -1) ( 2 . -2)
|
|
( 1 . 2) ( 1 . 1) ( 1 . 0) ( 1 . -1) ( 1 . -2)
|
|
( 0 . 2) ( 0 . 1) ( 0 . -1) ( 0 . -2)
|
|
(-1 . 2) (-1 . 1) (-1 . 0) (-1 . -1) (-1 . -2)
|
|
(-2 . 2) (-2 . 1) (-2 . 0) (-2 . -1) (-2 . -2)
|
|
)))
|
|
; when a spring is found, add the info on the cell and add it to the list of springs of the island
|
|
(island-add-river-spring! island i j)))
|
|
(sort candidates (lambda (x y) (> (cadr x) (cadr y))))))
|
|
|
|
; Island generation, step 7: draw the rivers
|
|
; When drawing a river, we need to find the next point of the path
|
|
(define (draw-river-and-find-next-point island i j cell path river-count)
|
|
; Increase the river count of the cell
|
|
(set-cell-river-count! cell (+ river-count (cell-river-count cell)))
|
|
; find the next point: the surrounding cell with the lower altitude
|
|
(define next-position+altitude
|
|
(car
|
|
(sort
|
|
(map
|
|
(lambda (x)
|
|
(define ni (+ i (car x)))
|
|
(define nj (+ j (cdr x)))
|
|
(list (cons ni nj)
|
|
(cond
|
|
; Outside should be excluded
|
|
((not (island-is-inside? island ni nj))
|
|
+inf.0)
|
|
; if there is sea around, move to it in priority
|
|
((eq? 'sea (island-biome island ni nj))
|
|
(+ -10000 (island-altitude island ni nj)))
|
|
; if there is a river around at a lower altitude, but not yet in the path, move to it in priority
|
|
((and (< (island-altitude island ni nj) (cell-altitude cell))
|
|
(< 0 (island-river-count island ni nj))
|
|
(not (member (cons ni nj) path)))
|
|
(+ -1000 (island-altitude island ni nj)))
|
|
; Other cases
|
|
(#t
|
|
(island-altitude island ni nj))
|
|
)))
|
|
river-directions)
|
|
(lambda (x y) (< (cadr x) (cadr y))))))
|
|
; return the next position if it has lower altitude than the current position
|
|
; Also set the river count of the corresponding edge
|
|
; if there is no next position, return false
|
|
(if (< (cadr next-position+altitude) (cell-altitude cell))
|
|
(begin
|
|
(set-edge-river-count!
|
|
(island-edge-between island i j (caar next-position+altitude) (cdar next-position+altitude))
|
|
(cell-river-count cell))
|
|
(car next-position+altitude))
|
|
#f))
|
|
|
|
; From the river spring, draw the river up to the sea or to sinkholes
|
|
; The sinkhole will be used later to draw lakes
|
|
(define (draw-river-from-spring island spring river-count)
|
|
(let loop ((i (car spring))
|
|
(j (cdr spring))
|
|
(cell (island-get-cell island (car spring) (cdr spring)))
|
|
(path (list)))
|
|
(define next (draw-river-and-find-next-point island i j cell path river-count))
|
|
(define next-cell (and next (island-get-cell island (car next) (cdr next))))
|
|
(cond
|
|
((not next-cell)
|
|
; sinkhole reached, stop for now
|
|
(set-island-sinkholes! island (append (island-sinkholes island) (list (cons i j)))))
|
|
((eq? (cell-biome next-cell) 'sea)
|
|
; sea reached, stop
|
|
#t)
|
|
(#t
|
|
; continue to draw the river
|
|
(loop (car next) (cdr next) next-cell (cons next path))))))
|
|
|
|
; Draw a lakes from a sinkhole
|
|
(define (draw-lake-from-sinkhole island sinkhole)
|
|
(define i (car sinkhole))
|
|
(define j (cdr sinkhole))
|
|
; If the sinkhole is already inside a lake, skip completely
|
|
(when (not (eq? 'lake (island-biome island i j)))
|
|
(define river-count (island-river-count island i j))
|
|
(define nb-iter (expt (+ river-count 2) 2)) ; number of iterations for the lake. The larger the river-count, the larger the lake.
|
|
; the goal is to find a new "spring" position from where the lake overflows
|
|
(let loop ( (iter nb-iter)
|
|
(ni i)
|
|
(nj j)
|
|
(next-points+altitude (list)))
|
|
(when (< 0 iter)
|
|
; set the lake biome on the cell
|
|
(set-cell-biome! (island-get-cell island ni nj) 'lake)
|
|
; Reset the river count of the cell
|
|
(set-cell-river-count! (island-get-cell island ni nj) 0)
|
|
; find the next points to check
|
|
; add the neighbours of the current cell that are not lake to the list of next points
|
|
; and order it by the lowest altitude
|
|
(define next+alt
|
|
(sort
|
|
(append
|
|
next-points+altitude
|
|
(filter
|
|
(lambda (x)
|
|
(and
|
|
(island-is-inside? island (caar x) (cdar x))
|
|
(not (eq? 'lake (island-biome island (caar x) (cdar x))))))
|
|
(map
|
|
(lambda (x)
|
|
(define nni (+ ni (car x)))
|
|
(define nnj (+ nj (cdr x)))
|
|
(cons (point nni nnj)
|
|
(island-altitude island nni nnj)))
|
|
river-directions)))
|
|
(lambda (x y)
|
|
(< (cdr x) (cdr y)))))
|
|
(when (not (null? next+alt))
|
|
(define next (car next+alt))
|
|
; if the next point has an altitude lower than the current cell, we continue into a river
|
|
; else, we continue to fill the lake from the new position
|
|
(if (< (cdr next) (island-altitude island ni nj))
|
|
(begin
|
|
; Change the river count of the edge too
|
|
(set-edge-river-count!
|
|
(island-edge-between island ni nj (caar next) (cdar next))
|
|
river-count)
|
|
; Start a new river
|
|
(draw-river-from-spring island (car next) river-count))
|
|
(loop (- iter 1) (caar next) (cdar next) (cdr next+alt))))
|
|
))))
|
|
|
|
; Add rivers
|
|
(define (add-rivers! island)
|
|
; Step 1: draw the river from the springs
|
|
(for-each
|
|
(lambda (spring)
|
|
(draw-river-from-spring island spring 1))
|
|
(island-river-springs island))
|
|
; step 2: draw the lake and river from the sinkholes
|
|
(let loop ((lst-sinkholes (island-sinkholes island)))
|
|
(when (not (null? lst-sinkholes))
|
|
; remove the sinkhole from the list
|
|
(set-island-sinkholes! island (cdr lst-sinkholes))
|
|
; draw a lake from the sinkhole
|
|
; this may end into new sinkhole added at the end of the list of sinkholes
|
|
(draw-lake-from-sinkhole island (car lst-sinkholes))
|
|
; loop
|
|
(loop (island-sinkholes island)))))
|
|
|
|
; Island generation, step 8: add biomes
|
|
(define (island-set-biome! island)
|
|
(2d-array-for-each
|
|
(island-cells island)
|
|
(lambda (cell)
|
|
(set-cell-biome!
|
|
cell
|
|
(compute-biome
|
|
(cell-biome cell)
|
|
(cell-temperature cell)
|
|
(cell-rainfall cell))))))
|
|
|
|
; Island generation, step 9: generate voronoi cells for the island
|
|
; Distance between to points on the island
|
|
; Mean between the manhattan distance and the infinite norm
|
|
(define (distance-between pos1 pos2)
|
|
(define x (abs (- (car pos1) (car pos2))))
|
|
(define y (abs (- (cdr pos1) (cdr pos2))))
|
|
(/ (+ x y (max x y)) 2))
|
|
|
|
; Get the closest point of a list from another point
|
|
(define (closest-from pnt lst-points)
|
|
(car
|
|
(foldl
|
|
(lambda (x res)
|
|
(define dist (distance-between pnt x))
|
|
(if (< dist (cdr res))
|
|
(cons x dist)
|
|
res))
|
|
(cons #f +inf.0) ; Point + distance
|
|
lst-points)))
|
|
|
|
; Compute for each cell the closest voronoi center
|
|
(define (set-closest-voronoi-center! island)
|
|
(2d-array-for-each/indexes
|
|
(island-cells island)
|
|
(lambda (cell i j)
|
|
; reset the cell-voronoi-center of cell
|
|
(set-cell-voronoi-center! cell
|
|
(closest-from (point i j) (island-voronoi-centers island))))))
|
|
|
|
; compute the center of each voronoi cells defined on the island, and set it as the new centers
|
|
(define (relax-centers-of-voronoi-cells island)
|
|
(define cells (island-cells island))
|
|
(define h (make-hash))
|
|
; use a statistic version: pick a point on the island and use it to compute the new center
|
|
; Instead of using all the cells of the island, only use 10 * (nb of voronoi cells)
|
|
(let loop ((n (* 10 (length (island-voronoi-centers island)))))
|
|
(when (< 0 n)
|
|
(define i (random (2d-array-width cells)))
|
|
(define j (random (2d-array-height cells)))
|
|
(define vcell (closest-from (point i j) (island-voronoi-centers island)))
|
|
(if (hash-has-key? h vcell)
|
|
(let ((prev (hash-ref h vcell)))
|
|
(hash-set! h vcell
|
|
(cons (point-add (point i j) (car prev)) (+ 1 (cdr prev)))))
|
|
(hash-set! h vcell
|
|
(cons (point i j) 1)))
|
|
(loop (- n 1))))
|
|
; update the centers
|
|
(set-island-voronoi-centers! island
|
|
(hash-map
|
|
h
|
|
(lambda (k v)
|
|
(point
|
|
(floor (/ (caar v) (cdr v)))
|
|
(floor (/ (cdar v) (cdr v)))))))
|
|
)
|
|
|
|
; Add the voronoi cells on the island (a cell is represented by its center)
|
|
(define (add-voronoi-cells! island)
|
|
(define cells (island-cells island))
|
|
(define width (2d-array-width cells))
|
|
(define height (2d-array-height cells))
|
|
(time
|
|
(displayln "Computation of centers")
|
|
; random centers
|
|
(set-island-voronoi-centers! island
|
|
; Remove points located in sea and lakes
|
|
(filter
|
|
(lambda (x)
|
|
(define biome (island-biome island (car x) (cdr x)))
|
|
(and (not (eq? 'sea biome))
|
|
(not (eq? 'lake biome))))
|
|
; remove identical points
|
|
(remove-duplicates
|
|
; build the list: each point is randomly choosen
|
|
(build-list
|
|
(ceiling (* width height 1/25)) ; number of points: island-width/25 * island-height/25
|
|
(lambda (i)
|
|
(point (random width) (random height))))))))
|
|
; relax twice the points : recompute the voronoi centers from each voronoi cell
|
|
(time
|
|
(displayln "Relax centers")
|
|
(relax-centers-of-voronoi-cells island))
|
|
; compute the closest center for each cell
|
|
(time
|
|
(displayln "Cell computation")
|
|
(set-closest-voronoi-center! island))
|
|
)
|
|
|
|
; Island generation, step 10: add cities
|
|
; For each cell, we need to compute a city score
|
|
; The city score take several parameters, so the computation is separated in several functions
|
|
|
|
; City score from the cells surrounding the city (in the 8 directions)
|
|
(define (city-score-from-neighbours-with-corners island i j cell)
|
|
(foldl
|
|
(lambda (pos res)
|
|
(define ni (+ i (car pos)))
|
|
(define nj (+ j (cdr pos)))
|
|
(define ncell (and (island-is-inside? island ni nj)
|
|
(island-get-cell island ni nj)))
|
|
(if ncell
|
|
(+ res
|
|
; penalize the presence of cliffs, prefer plane area
|
|
(/ (abs (- (cell-altitude ncell) (cell-altitude cell))) -5)
|
|
; take into account the surrounding biomes
|
|
(if (or (eq? 'sea (cell-biome ncell))
|
|
(eq? 'lake (cell-biome ncell)))
|
|
10
|
|
(/ (biome-city-score (cell-biome ncell)) 8))
|
|
; take into account the presence of rivers
|
|
(* 2 (cell-river-count ncell)))
|
|
(+ res 0)))
|
|
0
|
|
(list
|
|
north-west north north-east
|
|
west east
|
|
south-west south south-east)))
|
|
|
|
; City score from the cells surronding the city (in the 4 river directions)
|
|
(define (city-score-from-neighbours island i j cell)
|
|
(foldl
|
|
(lambda (pos res)
|
|
(define ni (+ i (car pos)))
|
|
(define nj (+ j (cdr pos)))
|
|
(define ncell (and (island-is-inside? island ni nj)
|
|
(island-get-cell island ni nj)))
|
|
(if ncell
|
|
; penalize if there is not enough ground to make a road to the city
|
|
(* res
|
|
(if (or (eq? 'sea (cell-biome ncell))
|
|
(eq? 'lake (cell-biome ncell)))
|
|
10
|
|
1))
|
|
(* res 1)))
|
|
-1
|
|
river-directions))
|
|
|
|
; City score from the cell itself
|
|
(define (city-score-from-cell cell)
|
|
(+ ; biome of the cell
|
|
(biome-city-score (cell-biome cell))
|
|
; altitude of the cell: avoid too high altitudes
|
|
(max 0 (+ 50 (* -1/10 (cell-altitude cell))))
|
|
; avoid being placed on a river
|
|
(* -100 (cell-river-count cell))
|
|
; avoid dry areas
|
|
(cell-rainfall cell)
|
|
))
|
|
|
|
; Compute the city score for each voronoi center and return a list of possible cities with their score
|
|
(define (compute-possible-cities island)
|
|
(define candidates (list))
|
|
(for-each
|
|
(lambda (x)
|
|
(define i (car x))
|
|
(define j (cdr x))
|
|
(define cell (island-get-cell island (car x) (cdr x)))
|
|
; compute the city score
|
|
(set-cell-city-score! cell
|
|
(+ (city-score-from-cell cell)
|
|
(city-score-from-neighbours island i j cell)
|
|
(city-score-from-neighbours-with-corners island i j cell)
|
|
))
|
|
; exclude places with a too negative score
|
|
(when (< -200 (cell-city-score cell))
|
|
(set! candidates (cons (make-city (point i j) (cell-city-score cell)) candidates))))
|
|
(island-voronoi-centers island))
|
|
(sort
|
|
candidates
|
|
(lambda (x y) (> (city-score x) (city-score y)))))
|
|
|
|
; Get the list of city from the closest to the furthest from another city
|
|
(define (closest-cities ct lst-cities)
|
|
(sort
|
|
(filter (lambda (x) (not (eq? ct x))) lst-cities) ; remove the city we are checking
|
|
(lambda (x y) (< (distance-between (city-position ct) (city-position x))
|
|
(distance-between (city-position ct) (city-position y))))))
|
|
|
|
; Get the closest city from a point
|
|
(define (closest-city-from pnt lst-cities)
|
|
(car
|
|
(foldl
|
|
(lambda (x res)
|
|
(define dist (distance-between pnt (city-position x)))
|
|
(if (< dist (cdr res))
|
|
(cons x dist)
|
|
res))
|
|
(cons #f +inf.0) ; Point + distance
|
|
lst-cities)))
|
|
|
|
; Distance between a point and the closest city
|
|
(define (horizontal-distance-to-city island pos)
|
|
(if (null? (island-cities island))
|
|
+inf.0
|
|
(distance-between
|
|
pos
|
|
(city-position (closest-city-from pos (island-cities island))))))
|
|
|
|
; add a certain number of cities of a given size taken from a list of candidates
|
|
; candidates should be sorted by city-score (higher first)
|
|
(define (add-cities island candidates nb-cities size min-score min-distance-to-other)
|
|
(when (and (< 0 nb-cities)
|
|
(not (null? candidates))
|
|
(< min-score (city-score (car candidates))))
|
|
(define possible-city (car candidates))
|
|
(define nb nb-cities)
|
|
(define cell
|
|
(island-get-cell
|
|
island
|
|
(car (city-position possible-city))
|
|
(cdr (city-position possible-city))))
|
|
(when (and
|
|
(not (cell-city cell))
|
|
(< min-distance-to-other (horizontal-distance-to-city island (city-position possible-city))))
|
|
(set-city-size! possible-city size)
|
|
(set-island-cities! island (cons possible-city (island-cities island)))
|
|
(set-cell-city! cell possible-city)
|
|
(set! nb (- nb-cities 1)))
|
|
(add-cities island (cdr candidates) nb size min-score min-distance-to-other)
|
|
))
|
|
|
|
; add the cities
|
|
(define (add-cities! island)
|
|
(define candidates (compute-possible-cities island))
|
|
(add-cities island candidates 1 'capital -inf.0 30)
|
|
(add-cities island candidates 20 'city 150 30)
|
|
(add-cities island candidates 60 'town 0 15)
|
|
(add-cities island candidates 120 'village -inf.0 5))
|
|
|
|
; Island generation, step 11: add subdivisions
|
|
; Indicate which city manages a cell
|
|
|
|
; Add the municipality on cells
|
|
(define (add-municipalities island)
|
|
; For each voronoi cell, define to which municipality it belongs to (closest municipality)
|
|
(for-each
|
|
(lambda (x)
|
|
(define cell (island-get-cell island (car x) (cdr x)))
|
|
(set-cell-municipality! cell
|
|
(closest-city-from x (island-cities island))))
|
|
(island-voronoi-centers island))
|
|
; For each cell, assign the municipality of its voronoi center
|
|
(2d-array-for-each
|
|
(island-cells island)
|
|
(lambda (cell)
|
|
(set-cell-municipality! cell
|
|
(cell-municipality
|
|
(island-get-cell island
|
|
(car (cell-voronoi-center cell))
|
|
(cdr (cell-voronoi-center cell))
|
|
)))))
|
|
)
|
|
|
|
; Add territories
|
|
(define (add-territories! island)
|
|
(define capital (car (filter (lambda (x) (eq? 'capital (city-size x))) (island-cities island))))
|
|
(define cities (filter (lambda (x) (eq? 'city (city-size x))) (island-cities island)))
|
|
(define towns (filter (lambda (x) (eq? 'town (city-size x))) (island-cities island)))
|
|
(define villages (filter (lambda (x) (eq? 'village (city-size x))) (island-cities island)))
|
|
(define region-capitals (cons capital cities))
|
|
(define canton-capitals (append region-capitals towns))
|
|
; Add municipalities
|
|
(add-municipalities island)
|
|
; Add canton
|
|
(for-each
|
|
(lambda (ca)
|
|
(define pos (city-position ca))
|
|
(define cell (island-get-cell island (car pos) (cdr pos)))
|
|
(set-cell-canton! cell ca))
|
|
canton-capitals)
|
|
; Attach each village to its closest canton-capital
|
|
(for-each
|
|
(lambda (vi)
|
|
(define pos (city-position vi))
|
|
(define cell (island-get-cell island (car pos) (cdr pos)))
|
|
(set-cell-canton! cell
|
|
(car
|
|
(closest-cities vi canton-capitals))))
|
|
villages)
|
|
; Add region
|
|
(for-each
|
|
(lambda (re)
|
|
(define pos (city-position re))
|
|
(define cell (island-get-cell island (car pos) (cdr pos)))
|
|
(set-cell-region! cell re))
|
|
region-capitals)
|
|
; Attach each town to its closest region capital
|
|
(for-each
|
|
(lambda (tw)
|
|
(define pos (city-position tw))
|
|
(define cell (island-get-cell island (car pos) (cdr pos)))
|
|
(set-cell-region! cell
|
|
(car
|
|
(closest-cities tw region-capitals))))
|
|
towns)
|
|
; Attach each village to the region capital of its canton capital
|
|
(for-each
|
|
(lambda (vi)
|
|
(define pos (city-position vi))
|
|
(define cell (island-get-cell island (car pos) (cdr pos)))
|
|
(define cpos (city-position (cell-canton cell)))
|
|
(define ccell (island-get-cell island (car cpos) (cdr cpos)))
|
|
(set-cell-region! cell (cell-region ccell)))
|
|
villages)
|
|
; Fix canton & region to be the same as the one of the municipality a cell belongs to
|
|
(2d-array-for-each
|
|
(island-cells island)
|
|
(lambda (cell)
|
|
(define ct (cell-municipality cell))
|
|
(define ct-cell (island-get-cell island (car (city-position ct)) (cdr (city-position ct))))
|
|
(define canton (cell-canton ct-cell))
|
|
(define region (cell-region ct-cell))
|
|
(set-cell-canton! cell canton)
|
|
(set-cell-region! cell region))))
|
|
|
|
; Neighbours
|
|
; Add a neighbour to a territory
|
|
(define (add-neighbour island type ct1 ct2)
|
|
(hash-set!
|
|
(type island)
|
|
ct1
|
|
(cons ct2 (hash-ref (type island) ct1 (list)))))
|
|
|
|
; Compute the neighbours of each territories
|
|
(define (add-neighbours! island)
|
|
; add the neighbours
|
|
(2d-array-for-each/indexes
|
|
(island-cells island)
|
|
(lambda (cell i j)
|
|
; ignore the neighbours when at sea
|
|
(when (not (eq? 'sea (cell-biome cell)))
|
|
(define municipality (cell-municipality cell))
|
|
(define canton (cell-canton cell))
|
|
(define region (cell-region cell))
|
|
(for-each
|
|
(lambda (dir)
|
|
(define ni (+ i (car dir)))
|
|
(define nj (+ j (cdr dir)))
|
|
(when (island-is-inside? island ni nj)
|
|
(define ncell (island-get-cell island ni nj))
|
|
(when (not (eq? municipality (cell-municipality ncell)))
|
|
(add-neighbour island island-municipality-neighbours municipality (cell-municipality ncell)))
|
|
(when (not (eq? canton (cell-canton ncell)))
|
|
(add-neighbour island island-canton-neighbours canton (cell-canton ncell)))
|
|
(when (not (eq? region (cell-region ncell)))
|
|
(add-neighbour island island-region-neighbours region (cell-region ncell)))
|
|
))
|
|
river-directions))))
|
|
; remove the duplications in lists
|
|
(for-each
|
|
(lambda (type)
|
|
(hash-for-each
|
|
(type island)
|
|
(lambda (k v)
|
|
(hash-set! (type island) k (remove-duplicates v)))))
|
|
(list
|
|
island-municipality-neighbours
|
|
island-canton-neighbours
|
|
island-region-neighbours))
|
|
)
|
|
|
|
; Island generation, step 12: add roads
|
|
; Link cities with roads
|
|
|
|
; Compute the cost to move from a cell to another
|
|
; If #f is returned, no road can be built between a cell and its neighbour
|
|
(define (road-cost island origin direction)
|
|
(define i (car origin))
|
|
(define j (cdr origin))
|
|
(define cell (island-get-cell island i j))
|
|
(define ni (+ i (car direction)))
|
|
(define nj (+ j (cdr direction)))
|
|
(cond
|
|
; The next must be inside
|
|
( (not (island-is-inside? island ni nj))
|
|
#f)
|
|
( (or (not (biome-new-road-cost (cell-biome (island-get-cell island ni nj)))) ; the biome forbids a road
|
|
(and (< 0 (cell-river-count cell))
|
|
(< 0 (cell-river-count (island-get-cell island ni nj)))) ; the current cell and next cell are rivers
|
|
)
|
|
#f)
|
|
; Other cases
|
|
(#t
|
|
(define ncell (island-get-cell island ni nj))
|
|
(/
|
|
(+
|
|
1000
|
|
(biome-new-road-cost (cell-biome ncell))
|
|
(abs (- (cell-altitude ncell) (cell-altitude cell))) ; avoid to much slopes
|
|
; a bridge should be built if there is a river, only the first bridge is penalized
|
|
(* 1.2 (cell-river-count ncell))
|
|
; avoid mountains
|
|
(cond
|
|
((< 2100 (cell-altitude ncell)) 100)
|
|
((< 1800 (cell-altitude ncell)) 50)
|
|
((< 1500 (cell-altitude ncell)) 25)
|
|
((< 1200 (cell-altitude ncell)) 12)
|
|
((< 900 (cell-altitude ncell)) 6)
|
|
(#t 0))
|
|
)
|
|
; If there is already a road, reduce the cost
|
|
(if (< 0 (cell-road-count ncell))
|
|
(+ 1 (/ (cell-road-count ncell) 3))
|
|
1)
|
|
; If there is a city, further reduce the cost
|
|
(if (cell-city ncell)
|
|
1.2
|
|
1)
|
|
))))
|
|
|
|
; Compute the heuristic cost of a cell
|
|
(define (heuristic-cost island origin destination)
|
|
(define i (car origin))
|
|
(define j (cdr origin))
|
|
(define di (car destination))
|
|
(define dj (cdr destination))
|
|
(+
|
|
(* 1000 (distance-between origin destination))
|
|
(abs (- (island-altitude island i j) (island-altitude island di dj)))))
|
|
|
|
; Draw a road
|
|
(define (draw-road island origin-city destination-city count road-cost-function heuristic-cost-function)
|
|
(let loop ((road (or (island-pathfind
|
|
island
|
|
(city-position origin-city) (city-position destination-city)
|
|
road-cost-function heuristic-cost-function)
|
|
'()))
|
|
(cities-on-path (list))
|
|
)
|
|
(cond
|
|
( (null? road)
|
|
; End by connecting the cities to each others
|
|
(for-each
|
|
(lambda (ct)
|
|
(for-each
|
|
(lambda (ct2)
|
|
(hash-set! (city-roads-to ct) ct2 #t))
|
|
cities-on-path))
|
|
cities-on-path))
|
|
(#t
|
|
; Draw the road
|
|
(define current (car road))
|
|
(define cell (island-get-cell island (car current) (cdr current)))
|
|
(define next (and (not (null? (cdr road))) (cadr road)))
|
|
(define edge (and next
|
|
(island-edge-between
|
|
island
|
|
(car current) (cdr current)
|
|
(car next) (cdr next))))
|
|
(set-cell-road-count! cell (+ (cell-road-count cell) count))
|
|
(when edge
|
|
(set-edge-road-count! edge (+ (edge-road-count edge) count)))
|
|
(loop
|
|
(cdr road)
|
|
(if (cell-city cell)
|
|
(cons (cell-city cell) cities-on-path)
|
|
cities-on-path)
|
|
)))))
|
|
|
|
; Road cost function when not creating new road. Only follow olready existing roads
|
|
; If #f is returned, no road can be built between a cell and its neighbour
|
|
(define (road-cost-no-new-road island origin direction)
|
|
(define i (car origin))
|
|
(define j (cdr origin))
|
|
(define ni (+ i (car direction)))
|
|
(define nj (+ j (cdr direction)))
|
|
(define ncell (island-get-cell island ni nj))
|
|
(and (< 0 (cell-road-count ncell)) 1))
|
|
|
|
; Heuristic cost of a cell when not creating new roads
|
|
(define (heuristic-cost-no-new-road island origin destination)
|
|
(distance-between origin destination))
|
|
|
|
; Road size depending on the cities
|
|
(define (road-size ct1 ct2)
|
|
(define size-ct1 (city-size ct1))
|
|
(define size-ct2 (city-size ct2))
|
|
(define ct1-capital? (eq? 'capital size-ct1))
|
|
(define ct2-capital? (eq? 'capital size-ct2))
|
|
(define ct1-city? (eq? 'city size-ct1))
|
|
(define ct2-city? (eq? 'city size-ct2))
|
|
(define ct1-town? (eq? 'town size-ct1))
|
|
(define ct2-town? (eq? 'town size-ct2))
|
|
(cond
|
|
((and (or ct1-capital? ct1-city?)
|
|
(or ct2-capital? ct2-city?))
|
|
16)
|
|
((and (or ct1-capital? ct1-city? ct1-town?)
|
|
ct2-town?)
|
|
8)
|
|
(#t
|
|
1)))
|
|
|
|
; Add roads
|
|
(define (add-roads! island)
|
|
; link every municipality to its neighbours
|
|
(hash-for-each
|
|
(island-municipality-neighbours island)
|
|
(lambda (ct1 v)
|
|
(define region? (or (eq? 'capital (city-size ct1)) (eq? 'city (city-size ct1))))
|
|
(define canton? (or (eq? 'capital (city-size ct1)) (eq? 'city (city-size ct1)) (eq? 'town (city-size ct1))))
|
|
(for-each
|
|
(lambda (ct2)
|
|
(when (not (hash-has-key? (city-roads-to ct1) ct2))
|
|
(draw-road
|
|
island ct1 ct2
|
|
; Use the right road importance
|
|
(road-size ct1 ct2)
|
|
road-cost heuristic-cost)))
|
|
v)))
|
|
; Link every canton to its neighbours - don't create new roads, only improve existing ones
|
|
(hash-for-each
|
|
(island-canton-neighbours island)
|
|
(lambda (ct1 v)
|
|
(for-each
|
|
(lambda (ct2)
|
|
(when (not (hash-has-key? (city-roads-to ct1) ct2))
|
|
(draw-road island ct1 ct2 (road-size ct1 ct2) road-cost-no-new-road heuristic-cost-no-new-road)))
|
|
v)))
|
|
; Link every region to its neighbours - don't create new roads, only improve existing ones
|
|
(hash-for-each
|
|
(island-region-neighbours island)
|
|
(lambda (ct1 v)
|
|
(for-each
|
|
(lambda (ct2)
|
|
(when (not (hash-has-key? (city-roads-to ct1) ct2))
|
|
(draw-road island ct1 ct2 (road-size ct1 ct2) road-cost-no-new-road heuristic-cost-no-new-road)))
|
|
v)))
|
|
)
|
|
|
|
; Island generator
|
|
(define (island-generate size)
|
|
(define island (make-island size size))
|
|
(time
|
|
(displayln "Add Island")
|
|
(island-set-altitude! island))
|
|
(time
|
|
(displayln "Add Erosion")
|
|
(island-erode! island))
|
|
(time
|
|
(displayln "Add Sea")
|
|
(island-set-sea! island))
|
|
(time
|
|
(displayln "Add Temperature")
|
|
(island-set-temperature! island))
|
|
(time
|
|
(displayln "Add Rainfall")
|
|
(island-set-rainfall! island))
|
|
(time
|
|
(displayln "Add River springs")
|
|
(add-river-springs! island))
|
|
(time
|
|
(displayln "Add Rivers")
|
|
(add-rivers! island))
|
|
(time
|
|
(displayln "Add biomes")
|
|
(island-set-biome! island))
|
|
(time
|
|
(displayln "Add Voronoi cells")
|
|
(add-voronoi-cells! island))
|
|
(time
|
|
(displayln "Add cities")
|
|
(add-cities! island))
|
|
(time
|
|
(displayln "Add territories")
|
|
(add-territories! island))
|
|
(time
|
|
(displayln "Add neighbours")
|
|
(add-neighbours! island))
|
|
(time
|
|
(displayln "Add roads")
|
|
(add-roads! island))
|
|
island)
|