#lang racket/base

; Island generator

(require
  racket/math
  racket/list
  racket/function
  data/queue
  "island/island.rkt"
  "island/biome.rkt"
  "../collection/2d-array.rkt"
  "../base-generation/noise.rkt"
  "../base-generation/random.rkt")

(provide
  ; Constructor
  island-generate
  )

; Island generation, step 1: generate altitude
(define (island-set-altitude! island)
  (define cells (island-cells island))
  (define size (min (2d-array-width cells) (2d-array-height cells)))
  (define half-size (/ size 2))
  (define noise-size (floor (/ size 15)))
  (define ns (make-noise 2 noise-size))
  (define (on-border? i j)
    (or (< i 5)
        (< j 5)
        (< (- (2d-array-width cells) i) 5)
        (< (- (2d-array-height cells) j) 5)))
  (2d-array-for-each/indexes
    (island-cells island)
    (lambda (cell i j)
      (set-cell-altitude!
        cell
        (cond
          ((on-border? i j) -700)
          (#t
            (* 200
              (+ -7
                (* 14 (* (sin (/ (* pi i) size)) (sin (/ (* pi j) size))))
                (* -4 (+ (expt (- i half-size) 2) (expt (- j half-size) 2)) (/ 2 (* size size)))
                (* 4 (noise-gradient-fractal-value ns 6 0.80 i j))
                (* 2 (noise-gradient-value ns i j))
                (* 1 (noise-value ns i j))
                )))))))
  ; Add a temporary sea biome to remove the inland depressions
  (2d-array-flood-map!
    (island-cells island)
    0 0
    (lambda (cell)
      (set-cell-biome! cell 'sea)
      cell)
    (lambda (init-cell visited-cell)
      (and (not (cell-biome visited-cell))
           (<= (cell-altitude visited-cell) 0)))
    )
  ; Update the altitude to remove inland depressions
  (2d-array-for-each
    (island-cells island)
    (lambda (cell)
      (define alt (cell-altitude cell))
      (when (and (not (eq? (cell-biome cell) 'sea))
                 (> 0 alt))
        (set-cell-altitude!
          cell
          (- 0 alt)))))
  ; Remove the sea biome
  (2d-array-for-each
    (island-cells island)
    (lambda (cell)
      (set-cell-biome! cell #f)))
  )

; Island generation, step 2: erosion pass
; The erosion pass redistributes the altitudes around the neighbour cells
(define (island-erode! island)
  (define cells (island-cells island))
  ; 1st pass - sum the contribution from all neighbours
  (define new-alt-1
    (2d-array-map/indexes
      cells
      (lambda (cell i j)
        (define alt (cell-altitude cell))
        (foldl
          (lambda (v res)
            (define x (+ i (caar v)))
            (define y (+ j (cdar v)))
            (define factor (cdr v))
            (cond
              ((2d-array-inside? cells x y)
                (define alt-next (island-altitude island x y))
                (+ res (* (- alt-next alt) factor)))
              (#t res)))
          alt
          ; each element of the neighbour array is [position . factor]
          '([(0 . 1) . 1/8] [(0 . -1) . 1/8] [(1 . 0) . 1/8] [(-1 . 0) . 1/8] ; adjacent
            [(1 . 1) . 1/12] [(-1 . 1) . 1/12] [(1 . -1) . 1/12] [(-1 . -1) . 1/12] ; corners
            )))))
  ; 2nd pass - sum the contributions from the highest (+) and lowest (-) only
  (define new-alt-2
    (2d-array-map/indexes
      new-alt-1
      (lambda (alt i j)
        (define add-remove
          (foldl
            (lambda (v res)
              (define x (+ i (car v)))
              (define y (+ j (cdr v)))
              (cond
                ((2d-array-inside? new-alt-1 x y)
                  (define alt-next (2d-array-ref new-alt-1 x y))
                  (define diff-next (- alt-next alt))
                  (cons (max (car res) diff-next)
                        (min (cdr res) diff-next)))
                (#t res)))
            '(0 . 0)
            ; each element of the neighbour array is position
            '((0 . 1) (0 . -1) (1 . 0) (-1 . 0)))) ; adjacent
        (+ alt (/ (car add-remove) 3) (/ (cdr add-remove) 3))
        )))
  ; Update the altitudes
  (2d-array-for-each/indexes
    cells
    (lambda (cell i j)
      (set-cell-altitude!
        cell
        (2d-array-ref new-alt-2 i j))))
  )

; Island generation, step 3: Add the sea biome
(define (island-set-sea! island)
  (2d-array-flood-map!
    (island-cells island)
    0 0
    (lambda (cell)
      (set-cell-biome! cell 'sea)
      cell)
    (lambda (init-cell visited-cell)
      (and (not (cell-biome visited-cell))
           (<= (cell-altitude visited-cell) 0)))
    ))

; Island generation, step 4: Temperatures
; Compute the temperature, depending on the altitude and latitude
(define (island-set-temperature! island)
  (define lat (+ 20 (random 45))) ; latitude of the island
  (2d-array-for-each
    (island-cells island)
    (lambda (cell)
      ; Altitude is 0 for the sea
      (define alt
        (or (and (eq? 'sea (cell-biome cell)) 0)
            (cell-altitude cell)))
      (set-cell-temperature!
        cell
        (+ ; Approximative model:
          ; 28°C at equator, 0°C at 70° lat
          ; the 1.8 parameters is here to get temperatures at around 20°C at 35° lat, 15°C at 45° lat, 10°C at 55° lat
          (+ 28 (* -28 (expt (/ lat 70) 1.8)))
          ; Usual model for loss of temperature depending on the altitude
          (* alt (/ -0.64 100))
          ; TODO: distance to sea ?
          )))))

; Wind structure
; Used in rainfall
(struct wind
  (direction
   increment))
; Make a list of winds from a main direction and a set of booleans indicating which winds are added
(define (make-winds dir M? A? P? AO? O?)
  (append
    ; main direction
    (if M? (list (wind dir 1)) (list))
    ; adjacents
    (if A?
      (list
        (wind
          (cond
            ((eq? (car dir) 0) (cons -1 (cdr dir)))
            ((eq? (cdr dir) 0) (cons (car dir) -1))
            (#t (cons (car dir) 0)))
          4)
        (wind
          (cond
            ((eq? (car dir) 0) (cons 1 (cdr dir)))
            ((eq? (cdr dir) 0) (cons (car dir) 1))
            (#t (cons 0 (cdr dir))))
          4))
      (list))
    ; perpendiculars
    (if P?
      (list
        (wind
          (cons (* -1 (cdr dir)) (car dir))
          9)
        (wind
          (cons (cdr dir) (* -1 (car dir)))
          9))
      (list))
    ; Adjacents' opposites
    (if AO?
      (list
        (wind
          (cond
            ((eq? (car dir) 0) (cons 1 (* -1 (cdr dir))))
            ((eq? (cdr dir) 0) (cons (* -1 (car dir)) 1))
            (#t (cons (* -1 (car dir)) 0)))
          19)
        (wind
          (cond
            ((eq? (car dir) 0) (cons -1 (* -1 (cdr dir))))
            ((eq? (cdr dir) 0) (cons (* -1 (car dir)) -1))
            (#t (cons 0 (* -1 (cdr dir)))))
          19))
      (list))
    ; Opposite
    (if O?
      (list
        (wind
          (cons (* -1 (car dir)) (* -1 (cdr dir)))
          39))
      (list))
    ))

; Winds + starting pos
(define (pos+winds dir width height M? A? P? AO? O?)
  (case dir
    ; each element is '(start-pos wind ...)
    ; Wind from NW
    ((NW) (cons '(0 . 0) (make-winds '(1 . 1) M? A? P? AO? O?)))
    ; Wind from SW
    ((SW) (cons `(0 . ,(- height 1)) (make-winds '(1 . -1) M? A? P? AO? O?)))
    ; Wind from NE
    ((NE) (cons `(,(- width 1) . 0) (make-winds '(-1 . 1) M? A? P? AO? O?)))
    ; Wind from SE
    ((SE) (cons `(,(- width 1) . ,(- height 1)) (make-winds '(-1 . -1) M? A? P? AO? O?)))
    ; Wind from N
    ((N) (cons `(,(floor (/ width 2)) . 0) (make-winds '(0 . 1) M? A? P? AO? O?)))
    ; Wind from S
    ((S) (cons `(,(floor (/ width 2)) . ,(- height 1)) (make-winds '(0 . -1) M? A? P? AO? O?)))
    ; Wind from W
    ((W) (cons `(0 . ,(floor (/ height 2))) (make-winds '(1 . 0) M? A? P? AO? O?)))
    ; Wind from E
    ((E) (cons `(,(- width 1) . ,(floor (/ height 2))) (make-winds '(-1 . 0) M? A? P? AO? O?)))
    ))

; Island generation, step 5: Set rainfall
; This is done by computing a distance to sea from a dominant wind
(define (island-set-rainfall! island)
  (define is-cells (island-cells island))
  (define width (2d-array-width is-cells))
  (define height (2d-array-height is-cells))
  ; Directional flood-map function
  ; Visit every node from a queue and apply the function
  ; The function should return a value passed to the next cell, or #f to stop
  ; If the function return non-#f, add the neighbours computed from dirs to the queue
  ; Repeat until there is no more
  (define (directional-flood-map! arr fun pos-queue dirs)
    (when (not (queue-empty? pos-queue))
      (define val+pos (dequeue! pos-queue))
      (define val (car val+pos))
      (define pos (cdr val+pos))
      (define i (car pos))
      (define j (cdr pos))
      (define cell (2d-array-ref arr i j))
      (define current (fun cell val i j))
      (when current
        (2d-array-set! arr i j current)
        (for-each
          (lambda (x)
            (define next-dir (wind-direction x))
            (define next-i (+ (car next-dir) i))
            (define next-j (+ (cdr next-dir) j))
            (when (2d-array-inside? arr next-i next-j)
              (enqueue! pos-queue
                (cons
                  (+ current (wind-increment x))
                  (cons next-i next-j)))))
          dirs))
      (directional-flood-map! arr fun pos-queue dirs)))
  ; Function to set the distance to sea with a threshold
  (define (make-dist-to-sea-func threshold)
    (lambda (cell next i j)
      (define icell (2d-array-ref is-cells i j))
      (define alt (cell-altitude icell))
      (define sea? (eq? 'sea (cell-biome icell)))
      (define above-thres? (< threshold alt))
      ; Next value
      (define new
        (cond
          (sea? 0)
          (above-thres?
            (min cell (+ 15 next)))
          (#t (min cell next))))
      (if (equal? cell new) #f new)))
  ; Choose a dominant wind: a starting position and winds
  (define dominant-wind (random:from-list '(NW SW NE SE N S W E)))
  ; Distances to sea
  (define distances-to-sea
    (build-list 3 (lambda (_) (make-2d-array width height +inf.0))))
  (for-each
    (lambda (arr thres pos+wind)
      (define pos-queue (make-queue))
      (enqueue! pos-queue (cons 0 (car pos+wind)))
      (directional-flood-map!
        arr
        (make-dist-to-sea-func thres)
        pos-queue
        (cdr pos+wind)))
    distances-to-sea
    '(1919 1313 777)
    (list
      (pos+winds dominant-wind width height #t #f #f #t #f) ; M + AO
      (pos+winds dominant-wind width height #f #t #f #f #t) ; A + O
      (pos+winds dominant-wind width height #f #t #t #f #f)) ; A + P
    )
  ; Convert a distance to sea, altitude and temperature to a rainfall
  ; The rainfalls decrease with the distance to sea, but increase with altitude
  (define (compute-rainfall dists alt temp)
    (max
      0
      (+
        (foldl
          (lambda (dist weight max-dist ret)
            (+ ret (* weight (max 0 (/ (- max-dist dist) max-dist)))))
          0
          dists
          '(100 75 75)
          '(200 140 80))
        (sqrt (* alt alt 1/100000))
        (* -50 temp 1/50)
        )))
  ; Update island
  (2d-array-for-each/indexes
    is-cells
    (lambda (cell i j)
      (define alt (cell-altitude cell))
      (define temp (cell-temperature cell))
      (define dists (map (lambda (arr) (2d-array-ref arr i j)) distances-to-sea))
      (set-cell-rainfall! cell (compute-rainfall dists (max alt 0) temp))))
  )

; Island generation, step 6: Determine the river springs
; All places with a rainfall > 100 are candidates for river springs
; However, river springs cannot be placed on two adjacent cells
(define (add-river-springs! island)
  ; collect all the positions with rainfall > 100, with their rainfall (exclude sea)
  (define candidates
    (2d-array-fold/indexes
      (island-cells island)
      (list)
      (lambda (cell i j res)
        (if (and (> (cell-rainfall cell) 100)
                 (not (eq? 'sea (cell-biome cell))))
          (cons
            (list (cons i j) (cell-rainfall cell))
            res)
          res))))
  ; sort the candidates by decreasing rainfall,
  ; and set the springs
  (for-each
    (lambda (x)
      (define i (caar x))
      (define j (cdar x))
      ; check there is no spring on an adjacent tiles in a radius of 2
      (when (null?
              (filter
                (lambda (pos)
                  (and
                    (island-is-inside? island (+ i (car pos)) (+ j (cdr pos)))
                    (island-river-spring? island (+ i (car pos)) (+ j (cdr pos)))
                    ))
                '(( 2 . 2) ( 2 . 1) ( 2 . 0) ( 2 . -1) ( 2 . -2)
                  ( 1 . 2) ( 1 . 1) ( 1 . 0) ( 1 . -1) ( 1 . -2)
                  ( 0 . 2) ( 0 . 1)          ( 0 . -1) ( 0 . -2)
                  (-1 . 2) (-1 . 1) (-1 . 0) (-1 . -1) (-1 . -2)
                  (-2 . 2) (-2 . 1) (-2 . 0) (-2 . -1) (-2 . -2)
                  )))
        ; when a spring is found, add the info on the cell and add it to the list of springs of the island
        (island-add-river-spring! island i j)))
    (sort candidates (lambda (x y) (> (cadr x) (cadr y))))))

; Island generation, step 7: draw the rivers
; When drawing a river, we need to find the next point of the path
(define (draw-river-and-find-next-point island i j cell path river-count)
  ; Increase the river count of the cell
  (set-cell-river-count! cell (+ river-count (cell-river-count cell)))
  ; find the next point: the surrounding cell with the lower altitude
  (define next-position+altitude
    (car
      (sort
        (map
          (lambda (x)
            (define ni (+ i (car x)))
            (define nj (+ j (cdr x)))
            (list (cons ni nj)
                  (cond
                    ; Outside should be excluded
                    ((not (island-is-inside? island ni nj))
                      +inf.0)
                    ; if there is sea around, move to it in priority
                    ((eq? 'sea (island-biome island ni nj))
                      (+ -10000 (island-altitude island ni nj)))
                    ; if there is a river around at a lower altitude, but not yet in the path, move to it in priority
                    ((and (< (island-altitude island ni nj) (cell-altitude cell))
                          (< 0 (island-river-count island ni nj))
                          (not (member (cons ni nj) path)))
                      (+ -1000 (island-altitude island ni nj)))
                    ; Other cases
                    (#t
                      (island-altitude island ni nj))
                    )))
          river-directions)
        (lambda (x y) (< (cadr x) (cadr y))))))
  ; return the next position if it has lower altitude than the current position
  ; Also set the river count of the corresponding edge
  ; if there is no next position, return false
  (if (< (cadr next-position+altitude) (cell-altitude cell))
      (begin
        (set-edge-river-count!
          (island-edge-between island i j (caar next-position+altitude) (cdar next-position+altitude))
          (cell-river-count cell))
        (car next-position+altitude))
      #f))

; From the river spring, draw the river up to the sea or to sinkholes
; The sinkhole will be used later to draw lakes
(define (draw-river-from-spring island spring river-count)
  (let loop ((i (car spring))
             (j (cdr spring))
             (cell (island-get-cell island (car spring) (cdr spring)))
             (path (list)))
    (define next (draw-river-and-find-next-point island i j cell path river-count))
    (define next-cell (and next (island-get-cell island (car next) (cdr next))))
    (cond
      ((not next-cell)
        ; sinkhole reached, stop for now
        (set-island-sinkholes! island (append (island-sinkholes island) (list (cons i j)))))
      ((eq? (cell-biome next-cell) 'sea)
        ; sea reached, stop
        #t)
      (#t
        ; continue to draw the river
        (loop (car next) (cdr next) next-cell (cons next path))))))

; Draw a lakes from a sinkhole
(define (draw-lake-from-sinkhole island sinkhole)
  (define i (car sinkhole))
  (define j (cdr sinkhole))
  ; If the sinkhole is already inside a lake, skip completely
  (when (not (eq? 'lake (island-biome island i j)))
    (define river-count (island-river-count island i j))
    (define nb-iter (expt (+ river-count 2) 2)) ; number of iterations for the lake. The larger the river-count, the larger the lake.
    ; the goal is to find a new "spring" position from where the lake overflows
    (let loop ( (iter nb-iter)
                (ni i)
                (nj j)
                (next-points+altitude (list)))
      (when (and (< 0 iter) (island-is-inside? island ni nj))
        ; 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
                    (cdr x)
                    (not (eq? 'lake (island-biome island (caar x) (cdar x))))))
                (map
                  (lambda (x)
                    (define nni (+ ni (car x)))
                    (define nnj (+ nj (cdr x)))
                    (define nnalt (and (island-is-inside? island nni nnj)
                                       (island-altitude island nni nnj)))
                    (cons (point nni nnj) nnalt))
                  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)
  ; Fix lake touching sea by changing them to sea
  ; Change sea to lake
  (2d-array-flood-map!
    (island-cells island)
    0 0
    (lambda (cell)
      (set-cell-biome! cell 'lake)
      cell)
    (lambda (init-cell visited-cell)
      (eq? (cell-biome visited-cell) 'sea)))
  ; Change lake to sea
  (2d-array-flood-map!
    (island-cells island)
    0 0
    (lambda (cell)
      (set-cell-biome! cell 'sea)
      cell)
    (lambda (init-cell visited-cell)
      (eq? (cell-biome visited-cell) 'lake)))
  ; Compute the other biomes
  (2d-array-for-each
    (island-cells island)
    (lambda (cell)
      (set-cell-biome!
        cell
        (compute-biome
          (cell-biome cell)
          (cell-temperature cell)
          (cell-rainfall cell))))))

; Island generation, step 9: generate voronoi cells for the island
; Distance between to points on the island
; Mean between the manhattan distance and the infinite norm
(define (distance-between pos1 pos2)
  (define x (abs (- (car pos1) (car pos2))))
  (define y (abs (- (cdr pos1) (cdr pos2))))
  (/ (+ x y (max x y)) 2))

; Get the closest point of a list from another point
(define (closest-from pnt lst-points)
  (car
    (foldl
      (lambda (x res)
        (define dist (distance-between pnt x))
        (if (< dist (cdr res))
            (cons x dist)
            res))
      (cons #f +inf.0) ; Point + distance
      lst-points)))

; Compute for each cell the closest voronoi center
(define (set-closest-voronoi-center! island)
  (2d-array-for-each/indexes
    (island-cells island)
    (lambda (cell i j)
      ; reset the cell-voronoi-center of cell
      (set-cell-voronoi-center! cell
        (closest-from (point i j) (island-voronoi-centers island))))))

; compute the center of each voronoi cells defined on the island, and set it as the new centers
(define (relax-centers-of-voronoi-cells island)
  (define cells (island-cells island))
  (define h (make-hash))
  ; use a statistic version: pick a point on the island and use it to compute the new center
  ; Instead of using all the cells of the island, only use 10 * (nb of voronoi cells)
  (let loop ((n (* 10 (length (island-voronoi-centers island)))))
    (when (< 0 n)
      (define i (random (2d-array-width cells)))
      (define j (random (2d-array-height cells)))
      (define vcell (closest-from (point i j) (island-voronoi-centers island)))
      (if (hash-has-key? h vcell)
          (let ((prev (hash-ref h vcell)))
            (hash-set! h vcell
              (cons (point-add (point i j) (car prev)) (+ 1 (cdr prev)))))
          (hash-set! h vcell
            (cons (point i j) 1)))
      (loop (- n 1))))
  ; update the centers
  (set-island-voronoi-centers! island
    (hash-map
      h
      (lambda (k v)
        (point
          (floor (/ (caar v) (cdr v)))
          (floor (/ (cdar v) (cdr v)))))))
  )

; Add the voronoi cells on the island (a cell is represented by its center)
(define (add-voronoi-cells! island)
  (define cells (island-cells island))
  (define width (2d-array-width cells))
  (define height (2d-array-height cells))
  (time
    (displayln "Computation of centers")
    ; random centers
    (set-island-voronoi-centers! island
      ; remove identical points
      (remove-duplicates
        ; build the list: each point is randomly choosen
        (build-list
          (ceiling (* width height 1/25)) ; number of points: island-width/25 * island-height/25
            (lambda (i)
              (point (random width) (random height)))))))
  ; relax twice the points : recompute the voronoi centers from each voronoi cell
  (time
    (displayln "Relax centers")
    (relax-centers-of-voronoi-cells island))
  ; compute the closest center for each cell
  (time
    (displayln "Cell computation")
    (set-closest-voronoi-center! island))
)

; Island generation, step 10: add cities
; For each cell, we need to compute a city score
; The city score take several parameters, so the computation is separated in several functions

; City score from the cells surrounding the city (in the 8 directions)
(define (city-score-from-neighbours-with-corners island i j cell)
  (foldl
    (lambda (pos res)
      (define ni (+ i (car pos)))
      (define nj (+ j (cdr pos)))
      (define ncell (and (island-is-inside? island ni nj)
                         (island-get-cell island ni nj)))
      (if ncell
        (+ res
          ; penalize the presence of cliffs, prefer plane area
          (/ (abs (- (cell-altitude ncell) (cell-altitude cell))) -5)
          ; take into account the surrounding biomes
          (if (or (eq? 'sea (cell-biome ncell))
                  (eq? 'lake (cell-biome ncell)))
              10
              (/ (biome-city-score (cell-biome ncell)) 8))
          ; take into account the presence of rivers
          (* 2 (cell-river-count ncell)))
        (+ res 0)))
    0
    (list
      north-west north north-east
      west             east
      south-west south south-east)))

; City score from the cells surronding the city (in the 4 river directions)
(define (city-score-from-neighbours island i j cell)
  (foldl
    (lambda (pos res)
      (define ni (+ i (car pos)))
      (define nj (+ j (cdr pos)))
      (define ncell (and (island-is-inside? island ni nj)
                         (island-get-cell island ni nj)))
      (if ncell
          ; penalize if there is not enough ground to make a road to the city
          (* res
            (if (or (eq? 'sea (cell-biome ncell))
                    (eq? 'lake (cell-biome ncell)))
                10
                1))
          (* res 1)))
    -1
    river-directions))

; City score from the cell itself
(define (city-score-from-cell cell)
  (+ ; biome of the cell
     (biome-city-score (cell-biome cell))
     ; altitude of the cell: avoid too high altitudes
     (max 0 (+ 50 (* -1/10 (cell-altitude cell))))
     ; avoid being placed on a river
     (* -100 (cell-river-count cell))
     ; avoid dry areas
     (cell-rainfall cell)
  ))

; Compute the city score for each voronoi center and return a list of possible cities with their score
(define (compute-possible-cities island)
  (define candidates (list))
  (for-each
    (lambda (x)
      (define i (car x))
      (define j (cdr x))
      (define cell (island-get-cell island (car x) (cdr x)))
      ; compute the city score
      (set-cell-city-score! cell
        (+  (city-score-from-cell cell)
            (city-score-from-neighbours island i j cell)
            (city-score-from-neighbours-with-corners island i j cell)
        ))
      ; exclude places with a too negative score
      (when (< -200 (cell-city-score cell))
        (set! candidates (cons (make-city (point i j) (cell-city-score cell)) candidates))))
    (island-voronoi-centers island))
  (sort
    candidates
    (lambda (x y) (> (city-score x) (city-score y)))))

; Get the list of city from the closest to the furthest from another city
(define (closest-cities ct lst-cities)
  (sort
    (filter (lambda (x) (not (eq? ct x))) lst-cities) ; remove the city we are checking
    (lambda (x y) (< (distance-between (city-position ct) (city-position x))
                     (distance-between (city-position ct) (city-position y))))))

; Get the closest city from a point
(define (closest-city-from pnt lst-cities)
  (car
    (foldl
      (lambda (x res)
        (define dist (distance-between pnt (city-position x)))
        (if (< dist (cdr res))
            (cons x dist)
            res))
      (cons #f +inf.0) ; Point + distance
      lst-cities)))

; Distance between a point and the closest city
(define (horizontal-distance-to-city island pos)
  (if (null? (island-cities island))
      +inf.0
      (distance-between
        pos
        (city-position (closest-city-from pos (island-cities island))))))

; add a certain number of cities of a given size taken from a list of candidates
; candidates should be sorted by city-score (higher first)
(define (add-cities island candidates nb-cities size min-score min-distance-to-other)
  (when (and (< 0 nb-cities)
             (not (null? candidates))
             (< min-score (city-score (car candidates))))
    (define possible-city (car candidates))
    (define nb nb-cities)
    (define cell
      (island-get-cell
        island
        (car (city-position possible-city))
        (cdr (city-position possible-city))))
    (when (and
            (not (cell-city cell))
            (< min-distance-to-other (horizontal-distance-to-city island (city-position possible-city))))
      (set-city-size! possible-city size)
      (set-island-cities! island (cons possible-city (island-cities island)))
      (set-cell-city! cell possible-city)
      (set! nb (- nb-cities 1)))
    (add-cities island (cdr candidates) nb size min-score min-distance-to-other)
    ))

; add the cities
(define (add-cities! island)
  (define candidates (compute-possible-cities island))
  (add-cities island candidates 1 'capital -inf.0 30)
  (add-cities island candidates 20 'city 150 30)
  (add-cities island candidates 60 'town 0 15)
  (add-cities island candidates 120 'village -inf.0 5))

; Island generation, step 11: add subdivisions
; Indicate which city manages a cell

; Add the municipality on cells
(define (add-municipalities island)
  ; For each voronoi cell, define to which municipality it belongs to (closest municipality)
  (for-each
    (lambda (x)
      (define cell (island-get-cell island (car x) (cdr x)))
      (set-cell-municipality! cell
        (closest-city-from x (island-cities island))))
    (island-voronoi-centers island))
  ; For each cell, assign the municipality of its voronoi center
  (2d-array-for-each
    (island-cells island)
    (lambda (cell)
      (set-cell-municipality! cell
        (cell-municipality
          (island-get-cell island
            (car (cell-voronoi-center cell))
            (cdr (cell-voronoi-center cell))
            )))))
  )

; Add territories
(define (add-territories! island)
  (define capital (car (filter (lambda (x) (eq? 'capital (city-size x))) (island-cities island))))
  (define cities (filter (lambda (x) (eq? 'city (city-size x))) (island-cities island)))
  (define towns (filter (lambda (x) (eq? 'town (city-size x))) (island-cities island)))
  (define villages (filter (lambda (x) (eq? 'village (city-size x))) (island-cities island)))
  (define region-capitals (cons capital cities))
  (define canton-capitals (append region-capitals towns))
  ; Add municipalities
  (add-municipalities island)
  ; Add canton
  (for-each
    (lambda (ca)
      (define pos (city-position ca))
      (define cell (island-get-cell island (car pos) (cdr pos)))
      (set-cell-canton! cell ca))
    canton-capitals)
  ; Attach each village to its closest canton-capital
  (for-each
    (lambda (vi)
      (define pos (city-position vi))
      (define cell (island-get-cell island (car pos) (cdr pos)))
      (set-cell-canton! cell
        (car
          (closest-cities vi canton-capitals))))
    villages)
  ; Add region
  (for-each
    (lambda (re)
      (define pos (city-position re))
      (define cell (island-get-cell island (car pos) (cdr pos)))
      (set-cell-region! cell re))
    region-capitals)
  ; Attach each town to its closest region capital
  (for-each
    (lambda (tw)
      (define pos (city-position tw))
      (define cell (island-get-cell island (car pos) (cdr pos)))
      (set-cell-region! cell
        (car
          (closest-cities tw region-capitals))))
    towns)
  ; Attach each village to the region capital of its canton capital
  (for-each
    (lambda (vi)
      (define pos (city-position vi))
      (define cell (island-get-cell island (car pos) (cdr pos)))
      (define cpos (city-position (cell-canton cell)))
      (define ccell (island-get-cell island (car cpos) (cdr cpos)))
      (set-cell-region! cell (cell-region ccell)))
    villages)
  ; Fix canton & region to be the same as the one of the municipality a cell belongs to
  (2d-array-for-each
    (island-cells island)
    (lambda (cell)
      (define ct (cell-municipality cell))
      (define ct-cell (island-get-cell island (car (city-position ct)) (cdr (city-position ct))))
      (define canton (cell-canton ct-cell))
      (define region (cell-region ct-cell))
      (set-cell-canton! cell canton)
      (set-cell-region! cell region))))

; Neighbours
; Add a neighbour to a territory
(define (add-neighbour island type ct1 ct2)
  (hash-set!
    (type island)
    ct1
    (cons ct2 (hash-ref (type island) ct1 (list)))))

; Compute the neighbours of each territories
(define (add-neighbours! island)
  ; add the neighbours
  (2d-array-for-each/indexes
    (island-cells island)
    (lambda (cell i j)
      ; ignore the neighbours when at sea
      (when (not (eq? 'sea (cell-biome cell)))
        (define municipality (cell-municipality cell))
        (define canton (cell-canton cell))
        (define region (cell-region cell))
        (for-each
          (lambda (dir)
            (define ni (+ i (car dir)))
            (define nj (+ j (cdr dir)))
            (when (island-is-inside? island ni nj)
              (define ncell (island-get-cell island ni nj))
              (when (not (eq? municipality (cell-municipality ncell)))
                (add-neighbour island island-municipality-neighbours municipality (cell-municipality ncell)))
              (when (not (eq? canton (cell-canton ncell)))
                (add-neighbour island island-canton-neighbours canton (cell-canton ncell)))
              (when (not (eq? region (cell-region ncell)))
                (add-neighbour island island-region-neighbours region (cell-region ncell)))
              ))
          river-directions))))
  ; remove the duplications in lists
  (for-each
    (lambda (type)
      (hash-for-each
        (type island)
        (lambda (k v)
          (hash-set! (type island) k (remove-duplicates v)))))
    (list
      island-municipality-neighbours
      island-canton-neighbours
      island-region-neighbours))
  )

; Island generation, step 12: add roads
; Link cities with roads

; Compute the cost to move from a cell to another
; If #f is returned, no road can be built between a cell and its neighbour
(define (road-cost island origin direction)
  (define i (car origin))
  (define j (cdr origin))
  (define cell (island-get-cell island i j))
  (define ni (+ i (car direction)))
  (define nj (+ j (cdr direction)))
  (cond
    ; The next must be inside
    ( (not (island-is-inside? island ni nj))
      #f)
    ( (or (not (biome-new-road-cost (cell-biome (island-get-cell island ni nj)))) ; the biome forbids a road
          (and (< 0 (cell-river-count cell))
               (< 0 (cell-river-count (island-get-cell island ni nj))))  ; the current cell and next cell are rivers
          )
      #f)
    ; Other cases
    (#t
      (define ncell (island-get-cell island ni nj))
      (/
        (+
          1000
          (biome-new-road-cost (cell-biome ncell))
          (abs (- (cell-altitude ncell) (cell-altitude cell))) ; avoid to much slopes
          ; a bridge should be built if there is a river, only the first bridge is penalized
          (* 1.2 (cell-river-count ncell))
          ; avoid mountains
          (cond
            ((< 2100 (cell-altitude ncell)) 100)
            ((< 1800 (cell-altitude ncell)) 50)
            ((< 1500 (cell-altitude ncell)) 25)
            ((< 1200 (cell-altitude ncell)) 12)
            ((< 900 (cell-altitude ncell)) 6)
            (#t 0))
        )
        ; If there is already a road, reduce the cost
        (if (< 0 (cell-road-count ncell))
            (+ 1 (/ (cell-road-count ncell) 3))
            1)
        ; If there is a city, further reduce the cost
      (if (cell-city ncell)
          1.2
          1)
    ))))

; Compute the heuristic cost of a cell
(define (heuristic-cost island origin destination)
  (define i (car origin))
  (define j (cdr origin))
  (define di (car destination))
  (define dj (cdr destination))
  (+
    (* 1000 (distance-between origin destination))
    (abs (- (island-altitude island i j) (island-altitude island di dj)))))

; Draw a road
(define (draw-road island origin-city destination-city count road-cost-function heuristic-cost-function)
  (let loop ((road (or (island-pathfind
                         island
                         (city-position origin-city) (city-position destination-city)
                         road-cost-function heuristic-cost-function)
                      '()))
             (cities-on-path (list))
             )
    (cond
      ( (null? road)
        ; End by connecting the cities to each others
        (for-each
          (lambda (ct)
            (for-each
              (lambda (ct2)
                (hash-set! (city-roads-to ct) ct2 #t))
              cities-on-path))
          cities-on-path))
      (#t
        ; Draw the road
        (define current (car road))
        (define cell (island-get-cell island (car current) (cdr current)))
        (define next (and (not (null? (cdr road))) (cadr road)))
        (define edge (and next
                          (island-edge-between
                            island
                            (car current) (cdr current)
                            (car next) (cdr next))))
        (set-cell-road-count! cell (+ (cell-road-count cell) count))
        (when edge
          (set-edge-road-count! edge (+ (edge-road-count edge) count)))
        (loop
          (cdr road)
          (if (cell-city cell)
              (cons (cell-city cell) cities-on-path)
              cities-on-path)
          )))))

; Road cost function when not creating new road. Only follow olready existing roads
; If #f is returned, no road can be built between a cell and its neighbour
(define (road-cost-no-new-road island origin direction)
  (define i (car origin))
  (define j (cdr origin))
  (define ni (+ i (car direction)))
  (define nj (+ j (cdr direction)))
  (define ncell (island-get-cell island ni nj))
  (and (< 0 (cell-road-count ncell)) 1))

; Heuristic cost of a cell when not creating new roads
(define (heuristic-cost-no-new-road island origin destination)
  (distance-between origin destination))

; Road size depending on the cities
(define (road-size ct1 ct2)
  (define size-ct1 (city-size ct1))
  (define size-ct2 (city-size ct2))
  (define ct1-capital? (eq? 'capital size-ct1))
  (define ct2-capital? (eq? 'capital size-ct2))
  (define ct1-city? (eq? 'city size-ct1))
  (define ct2-city? (eq? 'city size-ct2))
  (define ct1-town? (eq? 'town size-ct1))
  (define ct2-town? (eq? 'town size-ct2))
  (cond
    ((and (or ct1-capital? ct1-city?)
          (or ct2-capital? ct2-city?))
      16)
    ((and (or ct1-capital? ct1-city? ct1-town?)
          ct2-town?)
      8)
    (#t
      1)))

; Add roads
(define (add-roads! island)
  ; link every municipality to its neighbours
  (hash-for-each
    (island-municipality-neighbours island)
    (lambda (ct1 v)
      (define region? (or (eq? 'capital (city-size ct1)) (eq? 'city (city-size ct1))))
      (define canton? (or (eq? 'capital (city-size ct1)) (eq? 'city (city-size ct1)) (eq? 'town (city-size ct1))))
      (for-each
        (lambda (ct2)
          (when (not (hash-has-key? (city-roads-to ct1) ct2))
            (draw-road
              island ct1 ct2
              ; Use the right road importance
              (road-size ct1 ct2)
              road-cost heuristic-cost)))
        v)))
  ; Link every canton to its neighbours - don't create new roads, only improve existing ones
  (hash-for-each
    (island-canton-neighbours island)
    (lambda (ct1 v)
      (for-each
        (lambda (ct2)
          (when (not (hash-has-key? (city-roads-to ct1) ct2))
            (draw-road island ct1 ct2 (road-size ct1 ct2) road-cost-no-new-road heuristic-cost-no-new-road)))
        v)))
  ; Link every region to its neighbours - don't create new roads, only improve existing ones
  (hash-for-each
    (island-region-neighbours island)
    (lambda (ct1 v)
      (for-each
        (lambda (ct2)
          (when (not (hash-has-key? (city-roads-to ct1) ct2))
            (draw-road island ct1 ct2 (road-size ct1 ct2) road-cost-no-new-road heuristic-cost-no-new-road)))
        v)))
  )

; Island generator
(define (island-generate size)
  (define island (make-island size size))
  (time
    (displayln "Add Altitude")
    (island-set-altitude! island))
  (time
    (displayln "Add Erosion")
    (island-erode! island))
  (time
    (displayln "Add Sea")
    (island-set-sea! island))
  (time
    (displayln "Add Temperature")
    (island-set-temperature! island))
  (time
    (displayln "Add Rainfall")
    (island-set-rainfall! island))
  (time
    (displayln "Add River springs")
    (add-river-springs! island))
  (time
    (displayln "Add Rivers")
    (add-rivers! island))
  (time
    (displayln "Add biomes")
    (island-set-biome! island))
  (time
    (displayln "Add Voronoi cells")
    (add-voronoi-cells! island))
  (time
    (displayln "Add cities")
    (add-cities! island))
  (time
    (displayln "Add territories")
    (add-territories! island))
  (time
    (displayln "Add neighbours")
    (add-neighbours! island))
  (time
    (displayln "Add roads")
    (add-roads! island))
  island)
