Feufochmar
/
feuforeve.v4
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Merge the previous island generator with the new ideas explored so far.

This commit is contained in:
Feufochmar 2020-07-19 19:19:19 +02:00
parent 1660f991a7
commit 6bb1217ef7
8 changed files with 1453 additions and 245 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
daily-island-updater.rkt
View File

@ -27,4 +27,4 @@
; Create the directory
(make-directory* directory-name)
; Save the island
(island-render (island-cells island) directory-name))
(island-render island directory-name))

849
src/generators/island.rkt
View File

@ -5,8 +5,9 @@
(require
racket/math
racket/list
racket/function
data/queue
"island/cell.rkt"
"island/island.rkt"
"island/biome.rkt"
"../collection/2d-array.rkt"
"../base-generation/noise.rkt"
@ -15,60 +16,39 @@
(provide
; Constructor
island-generate
; Accessors to the array of cells, for rendering
island-cells
)
; Island structure
(struct s-island
(cells ; 2d-array of cells
))
; Accessor
(define (island-cells island)
(s-island-cells island))
; get altitude
(define (island-altitude island i j)
(cell-altitude
(2d-array-ref (s-island-cells island) i j)))
; set altitude
(define (set-island-altitude! island i j alt)
(2d-array-set!
(s-island-cells island) i j
(set-cell-altitude cell alt)))
; get biome
(define (island-biome island i j)
(cell-biome
(2d-array-ref (s-island-cells island) i j)))
; Altitude function
; Island generation, step 1: generate altitude
(define (island-set-altitude! island)
(define size (2d-array-width (s-island-cells 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 10)))
(define noise-size (floor (/ size 12)))
(define ns (make-noise 2 noise-size))
(define (block i n) (* n (quotient i n)))
(2d-array-map!/indexes
(s-island-cells island)
(2d-array-for-each/indexes
(island-cells island)
(lambda (cell i j)
(set-cell-altitude
(set-cell-altitude!
cell
(* 7
(+ -200 (* 420 (* (sin (/ (* pi i) size)) (sin (/ (* pi j) size))))
(* -150 (+ (expt (- i half-size) 2) (expt (- j half-size) 2)) (/ 2 (* size size)))
(+ -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)))
)))))
)
; Erosion pass
; 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
(s-island-cells island)
cells
(lambda (cell i j)
(define alt (cell-altitude cell))
(foldl
@ -77,7 +57,7 @@
(define y (+ j (cdar v)))
(define factor (cdr v))
(cond
((2d-array-inside? (s-island-cells island) x y)
((2d-array-inside? cells x y)
(define alt-next (island-altitude island x y))
(+ res (* (- alt-next alt) factor)))
(#t res)))
@ -109,37 +89,39 @@
(+ alt (/ (car add-remove) 3) (/ (cdr add-remove) 3))
)))
; Update the altitudes
(2d-array-map!/indexes
(s-island-cells island)
(2d-array-for-each/indexes
cells
(lambda (cell i j)
(set-cell-altitude
(set-cell-altitude!
cell
(2d-array-ref new-alt-2 i j))))
)
; Put sea
; Island generation, step 3: Add the sea biome
(define (island-set-sea! island)
(2d-array-flood-map!
(s-island-cells island)
(island-cells island)
0 0
(lambda (cell)
(set-cell-biome cell 'sea))
(set-cell-biome! cell 'sea)
cell)
(lambda (init-cell visited-cell)
(and (not (cell-biome visited-cell))
(<= (cell-altitude visited-cell) 0)))
))
; Set temperatures
; 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-map!
(s-island-cells 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
(set-cell-temperature!
cell
(+ ; Approximative model:
; 28°C at equator, 0°C at 70° lat
@ -233,7 +215,7 @@
((E) (cons `(,(- width 1) . ,(floor (/ height 2))) (make-winds '(-1 . 0) M? A? P? AO? O?)))
))
; Set rainfall
; 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))
@ -314,70 +296,779 @@
(+ ret (* weight (max 0 (/ (- max-dist dist) max-dist)))))
0
dists
'(200 75 50)
'(175 75 50)
'(75 125 250))
(* alt 1/60)
(* -50 temp 1/50)
)))
; Update island
(2d-array-map!/indexes
(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))))
(set-cell-rainfall! cell (compute-rainfall dists (max alt 0) temp))))
)
; Biome generation
; 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-map!
(2d-array-for-each
(island-cells island)
(lambda (cell)
(set-cell-biome
(set-cell-biome!
cell
(compute-biome
(cell-biome cell)
(cell-temperature cell)
(cell-rainfall cell))))))
; Generation function
; size is the width and height of the discrete map
; 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)
; Create an island
(define island
(s-island
(make-2d-array size size (cell))
))
; Set the altitude
(define island (make-island size size))
(time
(displayln "Define altitude")
(displayln "Add Island")
(island-set-altitude! island))
; Erosion pass
(time
(displayln "Erosion pass")
(displayln "Add Erosion")
(island-erode! island))
; Definition of sea
(time
(displayln "Sea definition")
(displayln "Add Sea")
(island-set-sea! island))
; Definition of temperatures
(time
(displayln "Temperature definition")
(displayln "Add Temperature")
(island-set-temperature! island))
; Definition of rainfall
(time
(displayln "Rainfall definition")
(displayln "Add Rainfall")
(island-set-rainfall! island))
; Definition of biome
(time
(displayln "Biome definition")
(displayln "Add River springs")
(add-river-springs! island))
(time
(displayln "Add Rivers")
(add-rivers! island))
(time
(displayln "Add biomes")
(island-set-biome! island))
; Definition of rivers and lakes
; TODO
; Definition of towns
; TODO
; Definition of roads
; TODO
; Return the 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)

71
src/generators/island/biome.rkt
View File

@ -9,6 +9,9 @@
biome-name
biome-color
compute-biome
;
biome-city-score
biome-new-road-cost
)
; Biome structure
@ -18,8 +21,8 @@
color
rainfall-threshold ; annual, in cm per m²
temperature-threshold ; annual mean, in °C
; city-score ; a score indicating how plausible a city would be located in that biome
; new-road-cost ; cost to trace a new road in that biome
city-score ; a score indicating how plausible a city would be located in that biome
new-road-cost ; cost to trace a new road in that biome
))
; Constructor
(define (biome
@ -28,8 +31,8 @@
#:color [color (rgb-color 0 0 0)]
#:rainfall-threshold [rainfall-threshold +inf.0]
#:temperature-threshold [temperature-threshold +inf.0]
; #:city-score [city-score -inf.0]
; #:new-road-cost [new-road-cost #f]
#:city-score [city-score -inf.0]
#:new-road-cost [new-road-cost #f]
)
(s-biome
key
@ -37,8 +40,8 @@
color
rainfall-threshold
temperature-threshold
; city-score
; new-road-cost
city-score
new-road-cost
))
; A small syntax to ease the definition of biomes
@ -56,104 +59,104 @@
#:color (rgb-color 20 80 180)
#:rainfall-threshold +inf.0
#:temperature-threshold +inf.0
; #:city-score -inf.0
; #:new-road-cost #f
#:city-score -inf.0
#:new-road-cost #f
)
(lake
#:name "Lake"
#:color (rgb-color 15 130 240)
#:rainfall-threshold +inf.0
#:temperature-threshold +inf.0
; #:city-score -inf.0
; #:new-road-cost #f
#:city-score -inf.0
#:new-road-cost #f
)
(tropical-rain-forest
#:name "Tropical rain forest"
#:color (rgb-color 10 195 70)
#:rainfall-threshold 250
#:temperature-threshold 20
; #:city-score 50
; #:new-road-cost 120
#:city-score 50
#:new-road-cost 120
)
(tropical-seasonal-forest
#:name "Tropical seasonal forest"
#:color (rgb-color 150 210 90)
#:rainfall-threshold 100
#:temperature-threshold 20
; #:city-score 100
; #:new-road-cost 60
#:city-score 100
#:new-road-cost 60
)
(savanna
#:name "Savanna"
#:color (rgb-color 150 240 60)
#:rainfall-threshold 30
#:temperature-threshold 20
; #:city-score 120
; #:new-road-cost 30
#:city-score 120
#:new-road-cost 30
)
(subtropical-desert
#:name "Subtropical desert"
#:color (rgb-color 240 180 120)
#:rainfall-threshold -inf.0
#:temperature-threshold 20
; #:city-score -100
; #:new-road-cost 20
#:city-score -100
#:new-road-cost 20
)
(temperate-rain-forest
#:name "Temperate rain forest"
#:color (rgb-color 60 240 120)
#:rainfall-threshold 200
#:temperature-threshold 7
; #:city-score 80
; #:new-road-cost 120
#:city-score 80
#:new-road-cost 120
)
(temperate-deciduous-forest
#:name "Temperate deciduous forest"
#:color (rgb-color 70 220 40)
#:rainfall-threshold 100
#:temperature-threshold 7
; #:city-score 150
; #:new-road-cost 60
#:city-score 150
#:new-road-cost 60
)
(boreal-forest
#:name "Boreal forest"
#:color (rgb-color 10 190 130)
#:rainfall-threshold 50
#:temperature-threshold 0
; #:city-score 50
; #:new-road-cost 90
#:city-score 50
#:new-road-cost 90
)
(shrubland
#:name "Shrubland"
#:color (rgb-color 130 170 30)
#:rainfall-threshold 50
#:temperature-threshold 7
; #:city-score 90
; #:new-road-cost 50
#:city-score 90
#:new-road-cost 50
)
(grassland
#:name "Grassland"
#:color (rgb-color 200 240 70)
#:rainfall-threshold -inf.0
#:temperature-threshold 0
; #:city-score 70
; #:new-road-cost 20
#:city-score 70
#:new-road-cost 20
)
(tundra
#:name "Tundra"
#:color (rgb-color 30 230 230)
#:rainfall-threshold -inf.0
#:temperature-threshold -10
; #:city-score -100
; #:new-road-cost 20
#:city-score -100
#:new-road-cost 20
)
(ice-shelf
#:name "Ice shelf"
#:color (rgb-color 160 250 250)
#:rainfall-threshold -inf.0
#:temperature-threshold -inf.0
; #:city-score -10000
; #:new-road-cost 800
#:city-score -10000
#:new-road-cost 800
)
))
@ -162,6 +165,10 @@
(s-biome-name (hash-ref biomes b)))
(define (biome-color b)
(s-biome-color (hash-ref biomes b)))
(define (biome-city-score b)
(s-biome-city-score (hash-ref biomes b)))
(define (biome-new-road-cost b)
(s-biome-new-road-cost (hash-ref biomes b)))
; Sort by temperature, then by rainfall
(define (sort-by-temperature-rainfall lst-biomes)

76
src/generators/island/cell.rkt
View File

@ -1,76 +0,0 @@
#lang racket/base
; Cell of island generator
; The island generator uses cells to discretely represents the map
(provide
; Constructor
cell
; Accessors
cell-altitude set-cell-altitude
cell-biome set-cell-biome
cell-temperature set-cell-temperature
cell-rainfall set-cell-rainfall
)
; Cell structure
(struct s-cell
(altitude ; number
biome ; symbol or #f is not set
temperature ; number, in °C
rainfall ; number, annual in cm per m²
))
; Cell constructor
(define (cell)
(s-cell
0
#f
0
0))
; Accessors
; Altitude
(define (cell-altitude c)
(s-cell-altitude c))
; Return a new cell copied from a cell with altitude changed
(define (set-cell-altitude c alt)
(s-cell
alt
(s-cell-biome c)
(s-cell-temperature c)
(s-cell-rainfall c)
))
; Biome
(define (cell-biome c)
(s-cell-biome c))
; Return a new cell copied from a cell with biome changed
(define (set-cell-biome c biome)
(s-cell
(s-cell-altitude c)
biome
(s-cell-temperature c)
(s-cell-rainfall c)))
; Temperature
(define (cell-temperature c)
(s-cell-temperature c))
; Return a new cell copied from a cell with temperature changed
(define (set-cell-temperature c temperature)
(s-cell
(s-cell-altitude c)
(s-cell-biome c)
temperature
(s-cell-rainfall c)))
; Rainfall
(define (cell-rainfall c)
(s-cell-rainfall c))
; Return a new cell copied from a cell with rainfall changed
(define (set-cell-rainfall c rainfall)
(s-cell
(s-cell-altitude c)
(s-cell-biome c)
(s-cell-temperature c)
rainfall))

308
src/generators/island/island.rkt Normal file
View File

@ -0,0 +1,308 @@
#lang racket/base
(require
racket/function
"../../collection/2d-array.rkt")
(provide
; points
point point-add
; directions
north south west east north-west north-east south-west south-east
river-directions
; edge
edge-river-count set-edge-river-count!
edge-road-count set-edge-road-count!
; cell
cell-voronoi-center set-cell-voronoi-center!
cell-altitude set-cell-altitude!
cell-biome set-cell-biome!
cell-temperature set-cell-temperature!
cell-rainfall set-cell-rainfall!
cell-river-spring?
cell-river-count set-cell-river-count!
cell-city-score set-cell-city-score!
cell-city set-cell-city!
cell-road-count set-cell-road-count!
cell-region set-cell-region!
cell-canton set-cell-canton!
cell-municipality set-cell-municipality!
; city
make-city
city-position city-score
city-size set-city-size!
city-roads-to
; island
make-island
island-cells
island-voronoi-centers set-island-voronoi-centers!
island-river-springs
island-sinkholes set-island-sinkholes!
island-cities set-island-cities!
island-municipality-neighbours
island-canton-neighbours
island-region-neighbours
;
island-get-cell island-is-inside?
island-pathfind
;
island-altitude island-biome island-temperature
island-rainfall island-river-spring? island-add-river-spring!
island-river-count island-city-score island-road-count
;
island-has-edges?
island-east-edge island-south-edge island-west-edge island-north-edge
island-edge island-edge-between
)
; Definitions around the concepts of edge/cell/island for the map of the island generator
; A point is a pair or two numbers
(define (point i j)
(cons i j))
; Points can be added
(define (point-add a b)
(cons (+ (car a) (car b))
(+ (cdr a) (cdr b))))
; Directions
(define north (point 0 -1))
(define south (point 0 1))
(define west (point -1 0))
(define east (point 1 0))
(define north-west (point-add north west))
(define north-east (point-add north east))
(define south-west (point-add south west))
(define south-east (point-add south east))
; River directions: rivers can't move in diagonals
(define river-directions
(list west north east south))
; Structure edge
(struct edge
([river-count #:mutable] ; number of river crossing the edge
[road-count #:mutable] ; number of roads crossing the edge
))
; constructor
(define (make-edge)
(edge
0 ; river-count
0 ; road-count
))
; City structure
(struct city
(position ; position of the city, as a point
score ; city score of the city
[size #:mutable] ; symbolic size of the city. Possible values: 'capital 'city 'town 'village
roads-to ; indicate the cities this one has a road to, to avoid building unnecessary roads
))
; city constructor
(define (make-city position score)
(city
position
score
'village ; default size
(make-hash) ; roads to
))
; Structure cell
(struct cell
(east-edge ; eastern edge
south-edge ; southern edge
[voronoi-center #:mutable] ; closest voronoi center to the cell
[altitude #:mutable] ; altitude of cell
[biome #:mutable] ; biome of the cell
[temperature #:mutable] ; Temperature
[rainfall #:mutable] ; Rainfall
[river-spring? #:mutable] ; tell if the cell is a river spring
[river-count #:mutable] ; how many rivers go on the cell
[city-score #:mutable] ; how the cell is compatible with the presence of a city
[city #:mutable] ; the city on the cell or #f
[road-count #:mutable] ; how many roads go on the cell
[region #:mutable] ; city the territory belongs to
[canton #:mutable] ; town, or city the territory belongs to
[municipality #:mutable] ; village, town, or city the territory belongs to
))
(define (make-cell)
(cell
(make-edge) ; eastern edge
(make-edge) ; southern edge
#f ; voronoi center
0 ; altitude
#f ; biome
0 ; temperature
0 ; rainfall
#f ; river spring
0 ; river count
0 ; city-score
#f; city
0 ; road count
#f ; region
#f ; canton
#f ; municipality
))
; An island is a 2d vector of cell
(struct island
(cells ; array of arrays of cells
[voronoi-centers #:mutable] ; list of points used as centers for voronoi cells
[river-springs #:mutable] ; list of river springs
[sinkholes #:mutable] ; list of sinkholes, used to draw lakes
[cities #:mutable] ; list of cities
municipality-neighbours ; table of neighbours by municipalities
canton-neighbours ; table of neighbours by cantons
region-neighbours ; table of neighbours by regions
))
; Constructor for an island
(define (make-island width height)
(island
(build-2d-array
width height
(lambda (i j)
(make-cell))) ; cells
(list) ; voronoi cells
(list) ; river-springs
(list) ; sinkholes
(list) ; cities
(make-hash) ; municipality-neighbours
(make-hash) ; canton-neighbours
(make-hash) ; region-neighbours
))
; Get the cell at a given coordinate
(define (island-get-cell zn x y)
(2d-array-ref (island-cells zn) x y))
; Check if a position is inside the island
(define (island-is-inside? zn x y)
(2d-array-inside? (island-cells zn) x y))
; Find a path from a point to another across a island using the costs functions
; The possible directions indicate the possible movements from a cell to another
; Return either a list of positions or #f if there is no path
(define (island-pathfind zn from to move-cost heuristic-cost [possible-directions river-directions])
(define position-cost (make-hash)) ; cost of each position
(define path (make-hash)) ; from which position do we go to another one ? (cell-to->cell-from)
; Build the path
(define (build-path lst current)
(if current
(build-path (cons current lst) (hash-ref path current))
lst))
; add a list of new position to the frontier
(define (push lst-next lst-frontier)
(sort
(append lst-next lst-frontier)
(lambda (x y) (< (cdr x) (cdr y)))))
; Return the next position and its cost from a current position and a direction
; Return #f if there is no way to go to the next position (or if it has already been visited with a lower cost)
(define (next+cost current-position next-direction)
(define move (move-cost zn current-position next-direction))
(define new-cost (and move (+ move (hash-ref position-cost current-position))))
(define next-position (point-add current-position next-direction))
(define next-cost (hash-ref position-cost next-position #f))
(if (and new-cost (or (not next-cost) (< new-cost next-cost)))
(begin
(hash-set! position-cost next-position new-cost)
(hash-set! path next-position current-position)
(cons next-position (+ new-cost (heuristic-cost zn next-position to))))
#f))
; Get the neighbours of a given position
(define (neighbours current-position)
(filter
identity
(map
(lambda (x) (next+cost current-position x))
possible-directions)))
; find the path
(define (findpath frontier)
(cond
((null? frontier) #f)
((equal? (caar frontier) to) (build-path (list) to))
(#t (findpath (push (neighbours (caar frontier)) (cdr frontier))))))
; Compute the path
(hash-set! position-cost from 0)
(hash-set! path from #f)
(findpath (list (cons from 0))))
; Get the altitude of a cell
(define (island-altitude zn x y)
(cell-altitude (island-get-cell zn x y)))
; Get the biome of a cell
(define (island-biome zn x y)
(cell-biome (island-get-cell zn x y)))
; Get the temperature of a cell
(define (island-temperature zn x y)
(cell-temperature (island-get-cell zn x y)))
; Get the rainfall of a cell
(define (island-rainfall zn x y)
(cell-rainfall (island-get-cell zn x y)))
; Get the spring status of a cell
(define (island-river-spring? zn x y)
(cell-river-spring? (island-get-cell zn x y)))
; Add a river spring
(define (island-add-river-spring! zn x y)
(set-cell-river-spring?! (island-get-cell zn x y) #t)
(set-island-river-springs! zn (cons (cons x y) (island-river-springs zn))))
; Get the river count of a cell
(define (island-river-count zn x y)
(cell-river-count (island-get-cell zn x y)))
; Get the city score of a cell
(define (island-city-score zn x y)
(cell-city-score (island-get-cell zn x y)))
; Get the road count of a cell
(define (island-road-count zn x y)
(cell-road-count (island-get-cell zn x y)))
; edges
; Check if the 4 edges of the given cell are defined
(define (island-has-edges? zn x y)
(and (island-is-inside? zn x y) ; east and south edges
(island-is-inside? zn (- x 1) y) ; west edge
(island-is-inside? zn x (- y 1)))) ; north edge
; east edge
(define (island-east-edge zn x y)
(cell-east-edge (island-get-cell zn x y)))
; south edge
(define (island-south-edge zn x y)
(cell-south-edge (island-get-cell zn x y)))
; west edge [east edge of (x-1,y)]
(define (island-west-edge zn x y)
(cell-east-edge (island-get-cell zn (- x 1) y)))
; north edge [south edge of (x,y-1)]
(define (island-north-edge zn x y)
(cell-south-edge (island-get-cell zn x (- y 1))))
; edge from a direction
(define (island-edge zn x y dir)
(cond
((equal? dir north)
(island-north-edge zn x y))
((equal? dir south)
(island-south-edge zn x y))
((equal? dir west)
(island-west-edge zn x y))
((equal? dir east)
(island-east-edge zn x y))
(#t #f)))
; edge between two points
(define (island-edge-between zn x1 y1 x2 y2)
(define diff (point (- x2 x1) (- y2 y1)))
(island-edge zn x1 y1 diff))

285
src/generators/island/renderer.rkt
View File

@ -2,7 +2,7 @@
; Render a 2d-array of cells into several layers of geographic data
(require
"cell.rkt"
"island.rkt"
"biome.rkt"
"../../collection/2d-array.rkt"
"../../graphics/color.rkt"
@ -11,9 +11,6 @@
(provide
island-render)
; Size of cells when rendered
(define cell-size 4) ; Each cell is represented by a (4px × 4px) rectangle
; Brush to use to render the altitude
(define (altitude-brush cell)
(define alt (cell-altitude cell))
@ -57,76 +54,250 @@
; Brush to use to render the temperature
(define (temperature-brush cell)
(define temp (cell-temperature cell))
(make-brush
(cond
((< 35 temp) (rgb-color 255 70 70))
((< 30 temp) (rgb-color 255 0 0))
((< 25 temp) (rgb-color 255 130 0))
((< 20 temp) (rgb-color 255 175 0))
((< 15 temp) (rgb-color 255 230 0))
((< 10 temp) (rgb-color 230 255 0))
((< 5 temp) (rgb-color 130 255 0))
((< 0 temp) (rgb-color 0 255 255))
((< -5 temp) (rgb-color 0 200 255))
((< -10 temp) (rgb-color 0 115 255))
((< -15 temp) (rgb-color 0 0 255))
(#t (rgb-color 160 0 255))
)))
(define bio (cell-biome cell))
; Do not draw over the sea
(if (eq? bio 'sea)
#f
(make-brush
(cond
((< 35 temp) (rgb-color 255 70 70))
((< 30 temp) (rgb-color 255 0 0))
((< 25 temp) (rgb-color 255 130 0))
((< 20 temp) (rgb-color 255 175 0))
((< 15 temp) (rgb-color 255 230 0))
((< 10 temp) (rgb-color 230 255 0))
((< 5 temp) (rgb-color 130 255 0))
((< 0 temp) (rgb-color 0 255 255))
((< -5 temp) (rgb-color 0 200 255))
((< -10 temp) (rgb-color 0 115 255))
((< -15 temp) (rgb-color 0 0 255))
(#t (rgb-color 160 0 255))
))))
; Brush to use to render the rainfall
(define (rainfall-brush cell)
(define val (inexact->exact (floor (min (cell-rainfall cell) 255))))
(make-brush
(rgb-color val val val)))
(define bio (cell-biome cell))
; Do not draw over the sea
(if (eq? bio 'sea)
#f
(make-brush
(rgb-color val val val))))
; Brush to use to render the biome
(define (biome-brush cell)
(make-brush
(biome-color (cell-biome cell))))
(define bio (cell-biome cell))
; Do not draw over the sea
(if (eq? bio 'sea)
#f
(make-brush
(biome-color bio))))
; Takes an array of cells, a brush procedure computing the color from a cell, and returns an image
(define (render-cell-layer cells brush-proc)
(define image (make-image
(* cell-size (2d-array-width cells))
(* cell-size (2d-array-height cells))))
; Render
(2d-array-for-each/indexes
cells
(lambda (cell i j)
(image-draw-square!
image
(* i cell-size)
(* j cell-size)
cell-size
(brush-proc cell))))
;
image)
; Brush to use to render the blank map
(define (blank-brush cell)
(define bio (cell-biome cell))
; Do not draw over the sea
(if (eq? bio 'sea)
#f
(make-brush
(rgb-color 255 255 255))))
; Size of cells when rendered
(define cell-size 4) ; Each cell is represented by a (4px × 4px) rectangle
; Layer constructor
(define (make-layer isl)
(define cells (island-cells isl))
(make-image
(* cell-size (2d-array-width cells))
(* cell-size (2d-array-height cells))))
; Layers on which the data is rendered
; Each layer is an image
(struct s-layers
(altitude
temperature
rainfall
biome
( ; Backgrounds
altitude
temperature
rainfall
biome
blank
; Foregrounds
rivers
cities
roads
territories
))
; Layers constructor
(define (layers cells)
(s-layers
(render-cell-layer cells altitude-brush)
(render-cell-layer cells temperature-brush)
(render-cell-layer cells rainfall-brush)
(render-cell-layer cells biome-brush)
))
(define (layers isl)
; Cells
(define cells (island-cells isl))
; Result
(define lays
(s-layers
(make-layer isl) ; altitude
(make-layer isl) ; temperature
(make-layer isl) ; rainfall
(make-layer isl) ; biome
(make-layer isl) ; blank
(make-layer isl) ; rivers
(make-layer isl) ; cities
(make-layer isl) ; roads
(make-layer isl) ; territories
))
; Sprite bank for cities - the name corresponds to the possible values of city-size
(define city-sprites
(make-sprite-bank
"static/images/island-cities.png"
'((capital 0 0 19 19)
(city 19 0 19 19)
(town 38 0 19 19)
(village 57 0 19 19))))
; Render
(2d-array-for-each/indexes
cells
(lambda (cell i j)
; A few definitions
(define x (* i cell-size))
(define y (* j cell-size))
; All background layers
(for-each
(lambda (layer+brush)
(image-draw-square!
((car layer+brush) lays)
x y
cell-size
((cdr layer+brush) cell)))
(list
(cons s-layers-altitude altitude-brush)
(cons s-layers-temperature temperature-brush)
(cons s-layers-rainfall rainfall-brush)
(cons s-layers-biome biome-brush)
(cons s-layers-blank blank-brush)))
; Foreground layers
; Rivers + lakes - not shown if there are ice-shelf
(define bio (cell-biome cell))
(define half-cell-size (/ cell-size 2))
(cond
( (eq? 'lake bio)
(image-draw-square!
(s-layers-rivers lays)
x y
cell-size
(biome-brush cell)))
( (and (not (eq? 'ice-shelf bio))
(not (eq? 'sea bio))
(< 0 (cell-river-count cell))
(island-has-edges? isl i j))
(for-each
(lambda (direction)
(define edge (island-edge isl i j direction))
(when (< 0 (edge-river-count edge))
(image-draw-line!
(s-layers-rivers lays)
(+ x half-cell-size) (+ y half-cell-size)
(+ x (* (+ 1 (car direction)) half-cell-size)) (+ y (* (+ 1 (cdr direction)) half-cell-size))
(make-pen
(biome-color 'lake)
(min (- cell-size 1) (+ 1 (floor (/ (edge-river-count edge) 10)))))
)))
river-directions)))
; Cities
(when (cell-city cell)
(image-draw-sprite!
(s-layers-cities lays)
(+ x half-cell-size -9) (+ y half-cell-size -9) ; -9 is sprite-size/2, sprite-size is 19
city-sprites
(city-size (cell-city cell))))
; Roads
(when (and (< 0 (cell-road-count cell))
(island-has-edges? isl i j))
(for-each
(lambda (direction)
(define edge (island-edge isl i j direction))
(when (< 0 (edge-road-count edge))
(image-draw-line!
(s-layers-roads lays)
(+ x half-cell-size) (+ y half-cell-size)
(+ x (* (+ 1 (car direction)) half-cell-size)) (+ y (* (+ 1 (cdr direction)) half-cell-size))
(make-pen
(named-color "red")
(min (- cell-size 1) (+ 1 (floor (/ (edge-road-count edge) 10)))))
)))
river-directions))
; Territories
(for-each
(lambda (dir)
(define ni (+ i (car dir)))
(define nj (+ j (cdr dir)))
(define ncell (and (island-is-inside? isl ni nj)
(island-get-cell isl ni nj)))
(define land? (and (not (eq? 'sea bio))
(and ncell (not (eq? 'sea (cell-biome ncell))))))
; Pen to use to draw the limit - use dotted lines if the border is at sea
(define pen
(cond
((and ncell (not (eq? (cell-region cell) (cell-region ncell))))
(make-pen (named-color "black") 2 (if land? 'solid 'dot)))
((and ncell (not (eq? (cell-canton cell) (cell-canton ncell))))
(make-pen (named-color "gray") 2 (if land? 'solid 'dot)))
((and ncell (not (eq? (cell-municipality cell) (cell-municipality ncell))))
(make-pen (named-color "gray") 1 (if land? 'solid 'dot)))
(#t #f)))
; Draw a line using the pen
(when pen
(image-draw-line!
(s-layers-territories lays)
(* ni cell-size) (* nj cell-size)
(+ x cell-size) (+ y cell-size)
pen)))
; check against the south and east
(list south east))
))
; Output
lays)
; Render an island into a directory
(define (island-render cells directory)
(define (island-render isl directory)
; Render the layers
(define lays (layers cells))
(define lays (layers isl))
; Output the layers
(image-save (s-layers-altitude lays) (string-append directory "/altitude.png"))
(image-save (s-layers-temperature lays) (string-append directory "/temperature.png"))
(image-save (s-layers-rainfall lays) (string-append directory "/rainfall.png"))
(image-save (s-layers-biome lays) (string-append directory "/biome.png"))
(for-each
(lambda (layer+file)
(image-save ((car layer+file) lays) (string-append directory "/" (cdr layer+file))))
(list
; Backgrounds
(cons s-layers-altitude "altitude.png")
(cons s-layers-temperature "temperature.png")
(cons s-layers-rainfall "rainfall.png")
(cons s-layers-biome "biomes.png")
(cons s-layers-blank "blank.png")
; Foregrounds
(cons s-layers-rivers "rivers.png")
(cons s-layers-cities "cities.png")
(cons s-layers-roads "roads.png")
(cons s-layers-territories "territories.png")
))
; Output composite images
(for-each
(lambda (layers+file)
(define composite (make-layer isl))
; Draw a sea biome background
(image-draw-rectangle!
composite
0 0 (image-width composite) (image-height composite)
(make-brush (biome-color 'sea)))
; Draw the layers
(for-each
(lambda (layer-proc)
(image-draw-image!
composite
(layer-proc lays)
0 0))
(car layers+file))
(image-save composite (string-append directory "/" (cdr layers+file))))
(list
(cons (list s-layers-altitude s-layers-rivers s-layers-cities) "altitude+rivers+cities.png")
(cons (list s-layers-blank s-layers-territories s-layers-cities) "blank+territories+cities.png")
))
)

BIN
static/images/island-cities.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 1.5 KiB

107
static/images/island-cities.svg Normal file
View File

@ -0,0 +1,107 @@
<?xml version="1.0" encoding="UTF-8" standalone="no"?>
<svg
xmlns:dc="http://purl.org/dc/elements/1.1/"
xmlns:cc="http://creativecommons.org/ns#"
xmlns:rdf="http://www.w3.org/1999/02/22-rdf-syntax-ns#"
xmlns:svg="http://www.w3.org/2000/svg"
xmlns="http://www.w3.org/2000/svg"
xmlns:sodipodi="http://sodipodi.sourceforge.net/DTD/sodipodi-0.dtd"
xmlns:inkscape="http://www.inkscape.org/namespaces/inkscape"
inkscape:export-ydpi="96"
inkscape:export-xdpi="96"
inkscape:export-filename="/home/feufochmar/projets/feuforeve.fr/feuforeve.v4/static/images/island-towns.png"
sodipodi:docname="island-towns.svg"
inkscape:version="1.0 (4035a4fb49, 2020-05-01)"
id="svg8"
version="1.1"
viewBox="0 0 20.108333 5.0270835"
height="19"
width="76">
<defs
id="defs2" />
<sodipodi:namedview
inkscape:window-maximized="1"
inkscape:window-y="0"
inkscape:window-x="0"
inkscape:window-height="1049"
inkscape:window-width="1920"
showguides="false"
units="px"
showgrid="false"
inkscape:document-rotation="0"
inkscape:current-layer="layer1"
inkscape:document-units="mm"
inkscape:cy="5.6777641"
inkscape:cx="8.5212011"
inkscape:zoom="5.6568542"
inkscape:pageshadow="2"
inkscape:pageopacity="0.0"
borderopacity="1.0"
bordercolor="#666666"
pagecolor="#ffffff"
id="base" />
<metadata
id="metadata5">
<rdf:RDF>
<cc:Work
rdf:about="">
<dc:format>image/svg+xml</dc:format>
<dc:type
rdf:resource="http://purl.org/dc/dcmitype/StillImage" />
<dc:title></dc:title>
</cc:Work>
</rdf:RDF>
</metadata>
<g
id="layer1"
inkscape:groupmode="layer"
inkscape:label="Calque 1">
<circle
r="2.2489583"
cy="2.5135419"
cx="2.5135419"
id="path833"
style="fill:#ffffff;fill-opacity:1;stroke:#000000;stroke-width:0.529167;stroke-linecap:square;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" />
<circle
r="1.7197917"
style="fill:#ffffff;fill-opacity:1;stroke:#000000;stroke-width:0.529167;stroke-linecap:square;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
id="circle844"
cx="7.5406251"
cy="2.5135419" />
<circle
r="1.3229166"
cy="2.5135419"
cx="12.567709"
id="circle846"
style="fill:#ffffff;fill-opacity:1;stroke:#000000;stroke-width:0.264583;stroke-linecap:square;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" />
<circle
r="0.79374999"
cy="2.5135419"
cx="17.594788"
id="circle848"
style="fill:#ffffff;fill-opacity:1;stroke:#000000;stroke-width:0.264583;stroke-linecap:square;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" />
<circle
r="0.52916664"
cy="2.5135419"
cx="7.5406251"
id="circle850"
style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:0.529167;stroke-linecap:square;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1" />
<path
transform="scale(1,-1)"
inkscape:transform-center-y="-0.17013199"
d="M 2.513542,-0.73867083 2.0946522,-1.943763 0.81909749,-1.9697567 1.8357641,-2.7405386 1.4663176,-3.9616957 l 1.0472244,0.7287228 1.0472242,-0.7287229 -0.3694465,1.2211573 1.0166667,0.7707817 -1.2755548,0.025994 z"
inkscape:randomized="0"
inkscape:rounded="0"
inkscape:flatsided="false"
sodipodi:arg2="2.1991149"
sodipodi:arg1="1.5707963"
sodipodi:r2="0.71265775"
sodipodi:r1="1.7816443"
sodipodi:cy="-2.5203152"
sodipodi:cx="2.5135419"
sodipodi:sides="5"
id="path852"
style="fill:#000000;fill-opacity:1;stroke:#000000;stroke-width:0.264583;stroke-linecap:square;stroke-miterlimit:4;stroke-dasharray:none;stroke-opacity:1"
sodipodi:type="star" />
</g>
</svg>
Side by Side

After

Width:  |  Height:  |  Size: 3.9 KiB