diff --git a/daily-island-updater.rkt b/daily-island-updater.rkt index dcaf1cd..044678b 100644 --- a/daily-island-updater.rkt +++ b/daily-island-updater.rkt @@ -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)) diff --git a/src/generators/island.rkt b/src/generators/island.rkt index 49003a0..bf98ab7 100644 --- a/src/generators/island.rkt +++ b/src/generators/island.rkt @@ -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) diff --git a/src/generators/island/biome.rkt b/src/generators/island/biome.rkt index 7c78858..715d659 100644 --- a/src/generators/island/biome.rkt +++ b/src/generators/island/biome.rkt @@ -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) diff --git a/src/generators/island/cell.rkt b/src/generators/island/cell.rkt deleted file mode 100644 index 1624210..0000000 --- a/src/generators/island/cell.rkt +++ /dev/null @@ -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)) diff --git a/src/generators/island/island.rkt b/src/generators/island/island.rkt new file mode 100644 index 0000000..d92cf31 --- /dev/null +++ b/src/generators/island/island.rkt @@ -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)) diff --git a/src/generators/island/renderer.rkt b/src/generators/island/renderer.rkt index e93857d..81c8ea3 100644 --- a/src/generators/island/renderer.rkt +++ b/src/generators/island/renderer.rkt @@ -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") + )) ) diff --git a/static/images/island-cities.png b/static/images/island-cities.png new file mode 100644 index 0000000..a242463 Binary files /dev/null and b/static/images/island-cities.png differ diff --git a/static/images/island-cities.svg b/static/images/island-cities.svg new file mode 100644 index 0000000..5b8a9c0 --- /dev/null +++ b/static/images/island-cities.svg @@ -0,0 +1,107 @@ + + + + + + + + image/svg+xml + + + + + + + + + + + + + +