#lang racket/base

; Island generator using a theme similar to old road maps

(require
  racket/math
  racket/string
  "../collection/2d-array.rkt"
  "../collection/graph.rkt"
  "../graphics/image.rkt"
  "../base-generation/noise.rkt"
  "../base-generation/random.rkt")

(provide
  ; Constructor
  road-map-generate
  road-map-render
  make-road-map-tileset
  )

; Cell structure
(struct cell
  (variation ; Tile variation - a number between 0 and 2
   [sea? #:mutable] ; Filled with sea ?
   [forest? #:mutable] ; Filled with forest ?
   [feature? #:mutable] ; Contain a feature (buildings)
   [city? #:mutable] ; City ?
   [road-N? #:mutable] ; Road to North ?
   [road-S? #:mutable] ; Road to South ?
   [road-E? #:mutable] ; Road to East ?
   [road-W? #:mutable] ; Road to West ?
   [summit? #:mutable] ; Summit ?
   [ruin? #:mutable] ; Ruin ?
   ))

(define (make-cell [sea? #f])
  (cell (random 3) sea? #f #f #f #f #f #f #f #f #f))

; Generation of sea and summits
(define (island-set-sea! island)
  (define size (min (2d-array-width island) (2d-array-height island)))
  (define half-size (/ size 2))
  (define noise-size (floor (/ size 6)))
  (define ns (make-noise 2 noise-size))
  ; Rough altitudes
  (define altitudes
    (build-2d-array
      (2d-array-width island)
      (2d-array-height island)
      (lambda (i j)
        (+ -8
          (* 16 (* (sin (/ (* pi i) size)) (sin (/ (* pi j) size))))
          (* -4 (+ (expt (- i half-size) 2) (expt (- j half-size) 2)) (/ 2 (* size size)))
          (* 8 (noise-gradient-value ns i j))
          (noise-value ns i j)
          ))))
  ; Set the sea and summits
  (2d-array-for-each/indexes
    island
    (lambda (cell i j)
      ; Alt
      (define alt (2d-array-ref altitudes i j))
      ; Sea if the altitude is negative
      (define sea? (> 0 alt))
      (set-cell-sea?! cell sea?)
      ; The cell is a summit if it is higher than its 8 surrounding cells
      (define summit?
        (andmap
          (lambda (x y)
            (define other-i (+ i x))
            (define other-j (+ j y))
            (and
              (2d-array-inside? island other-i other-j)
              (< (2d-array-ref altitudes other-i other-j) alt)))
          '(-1 -1 -1  0  0  1 1 1)
          '(-1  0  1 -1  1 -1 0 1)))
      ; Underwater summmit are ignored
      (set-cell-summit?! cell (and summit? (not sea?)))))
  )

; City generation
(define (island-set-city! island)
  ; Define a noise
  (define size (min (2d-array-width island) (2d-array-height island)))
  (define ns (make-noise 2 size))
  ; feature if not sea?, not summit? and absolute value of fractal noise is above 0.75
  (2d-array-for-each/indexes
    island
    (lambda (cell i j)
      (define val (abs (noise-fractal-value ns 6 0.1 i j)))
      (set-cell-feature?! cell (and (not (cell-sea? cell))
                                   (not (cell-summit? cell))
                                   (< 0.8 val)))))
  ; Only cluster of features are cities for sure
  ; Other may be ruins or cities
  (2d-array-for-each/indexes
    island
    (lambda (cell i j)
      (when (cell-feature? cell)
        ; Count the number of features around the cell
        (define count
          (foldl
            (lambda (di dj res)
              (define x (+ i di))
              (define y (+ j dj))
              (+ res
                (if (and (2d-array-inside? island x y)
                         (cell-feature? (2d-array-ref island x y)))
                    1
                    0)))
            0
            '( 0  0 -1  1)
            '(-1  1  0  0)))
        (if (< 0 count)
            (set-cell-city?! cell #t)
            ((random:from-list (list set-cell-city?! set-cell-ruin?!)) cell #t)))))
  )

; Manhattan distance
(define (point-distance p1 p2)
  (+ (abs (- (point-x p1) (point-x p2)))
     (abs (- (point-y p1) (point-y p2)))))

; Edge length
(define (edge-length e)
  (point-distance (edge-first e) (edge-last e)))

; Road generation
(define (island-set-road! island)
  ; Get all the city points
  (define cities
    (2d-array-fold/indexes
      island
      '()
      (lambda (cell i j res)
        (if (cell-city? cell)
            (cons (point i j) res)
            res))))
  ; All roads connecting the different cities
  (define roads
    (if (< (length cities) 2)
        ; No need to build roads if there are less than two cities on the map
        (list)
        ; Else
        ; For each cell of the island, find the two closest cities, those two are linked by a road
        ; Roads are sorted by length - to draw the shortest roads first
        (sort
          (2d-array-fold/indexes
            island
            '()
            (lambda (cell i j res)
              ; Do not check: sea, summit, ruins - no road can be built on them
              (cond
                ((or (cell-sea? cell)
                     (cell-summit? cell)
                     (cell-ruin? cell))
                 res)
                (#t
                  (define p (point i j))
                  (define closest-cities
                    (sort
                      cities
                      (lambda (p1 p2) (< (point-distance p1 p) (point-distance p2 p)))))
                  (define new-road (edge (car closest-cities) (cadr closest-cities)))
                  (if (not (member new-road res edge-equal?))
                      (cons new-road res)
                      res)))))
          (lambda (e1 e2) (< (edge-length e1) (edge-length e2))))))
  ; Find the path of an edge - return either a list of points or #f
  (define (path-find e)
    (2d-array-path-find
      island
      ; From
      (point-x (edge-first e)) (point-y (edge-first e))
      ; To
      (point-x (edge-last e)) (point-y (edge-last e))
      ; Move cost
      (lambda (cell next-cell di dj)
        ; If there is already a road, the move cost is less than the normal cost
        (define cost
          (if (or (and (eq? di 0) (eq? dj 1) (cell-road-S? cell))
                  (and (eq? di 0) (eq? dj -1) (cell-road-N? cell))
                  (and (eq? di 1) (eq? dj 0) (cell-road-E? cell))
                  (and (eq? di -1) (eq? dj 0) (cell-road-W? cell)) )
              0.25
              1))
        ; can't move to sea, summit, or ruin
        (and (not (cell-sea? cell))
             (not (cell-summit? cell))
             (not (cell-ruin? cell))
             (not (cell-sea? next-cell))
             (not (cell-summit? next-cell))
             (not (cell-ruin? next-cell))
             cost))
      ; Heuristic cost : manhattan distance between the current and destination position
      (lambda (isl i j to-i to-j)
        (point-distance (point i j) (point to-i to-j)))))
  ; Draw a path
  (define (draw-path path)
    (when (and path
               (not (null? path))
               (not (null? (cdr path))))
      (define current (car path))
      (define current-cell (2d-array-ref island (point-x current) (point-y current)))
      (define next (cadr path))
      (define next-cell (2d-array-ref island (point-x next) (point-y next)))
      (cond
        ((and (eq? (point-x current) (point-x next))
              (eq? (+ (point-y current) 1) (point-y next)))
         ; Go to south
         (set-cell-road-S?! current-cell #t)
         (set-cell-road-N?! next-cell #t))
        ((and (eq? (point-x current) (point-x next))
              (eq? (- (point-y current) 1) (point-y next)))
         ; Go to north
         (set-cell-road-N?! current-cell #t)
         (set-cell-road-S?! next-cell #t))
        ((and (eq? (+ (point-x current) 1) (point-x next))
              (eq? (point-y current) (point-y next)))
         ; Go to east
         (set-cell-road-E?! current-cell #t)
         (set-cell-road-W?! next-cell #t))
        ((and (eq? (- (point-x current) 1) (point-x next))
              (eq? (point-y current) (point-y next)))
         ; Go to west
         (set-cell-road-W?! current-cell #t)
         (set-cell-road-E?! next-cell #t))
        )
      (draw-path (cdr path))))
  ; Trace one road
  (define (trace-road road)
    (draw-path (path-find road)))
  ; Trace a list of roads
  (define (trace-roads rd)
    (when (not (null? rd))
      (trace-road (car rd))
      (trace-roads (cdr rd))))
  ; Trace the roads
  (trace-roads roads))

; Forest generation : forest presence depends on the features present
(define (island-set-forest! island)
  (2d-array-for-each
    island
    (lambda (cell)
      ; Random dice
      (define alea (+ 1 (random 10)))
      ; Forest presence
      (set-cell-forest?!
        cell
        (cond
          ((cell-sea? cell) #f) ; No underwater forest
          ((cell-city? cell) (< 8 alea)) ; 2/10 if there is a city
          ((cell-summit? cell) (< 3 alea)) ; 7/10 if there is a summit
          ((or (cell-road-N? cell)
               (cell-road-S? cell)
               (cell-road-E? cell)
               (cell-road-W? cell))
            (< 6 alea)) ; 4/10 if there is a road
          ((cell-ruin? cell) (< 4 alea)) ; 6/10 if there is a ruin
          (#t (< 1 alea))))))) ; 9/10 if there is no feature

; Island generation
(define (road-map-generate size)
  ; An island is a 2d array of cells
  (define island (build-2d-array size size (lambda (i j) (make-cell))))
  ; Altitude generation => to define the cell of sea + summits
  (island-set-sea! island)
  ; City generation
  (island-set-city! island)
  ; Road generation
  (island-set-road! island)
  ; Forest generation
  (island-set-forest! island)
  ; Return
  island)

; Tileset
; From image path and tile size
(define (make-road-map-tileset path size)
  ; Function to define the tiles from their position
  ; (the sprite bank allows sprites of aribtrary sizes, arbitrary positioned in the image)
  (define (resize lst)
    (map
      (lambda (x)
        (cons
          (car x)
          (append
            (map (lambda (n) (* size n)) (cdr x))
            (list size size))))
      lst))
  ; Function to build directional tiles from a block of 4x4
  ; SE  SEW  SW  S
  ; NSE NSEW NSW NS
  ; NE  NEW  NW  N
  ; E   EW   W   -
  (define (directional-tiles name x y)
    (map
      (lambda (suffix offset-x offset-y)
        (list (string-append name suffix)
              (+ x offset-x)
              (+ y offset-y)))
      '("-SE"  "-SEW"  "-SW"  "-S"
        "-NSE" "-NSEW" "-NSW" "-NS"
        "-NE"  "-NEW"  "-NW"  "-N"
        "-E"   "-EW"   "-W"   "-")
      '(0 1 2 3
        0 1 2 3
        0 1 2 3
        0 1 2 3)
      '(0 0 0 0
        1 1 1 1
        2 2 2 2
        3 3 3 3)))
  ;
  (make-sprite-bank
    path
    (resize
      (append
        '(("land" 0 0)
          ("summit" 0 1)
          ("ruin" 1 1)
         )
        (directional-tiles "road" 4 0)
        (directional-tiles "0-sea" 0 4)
        (directional-tiles "1-sea" 4 4)
        (directional-tiles "2-sea" 8 4)
        (directional-tiles "0-forest" 0 8)
        (directional-tiles "1-forest" 4 8)
        (directional-tiles "2-forest" 8 8)
        (directional-tiles "0-city" 0 12)
        (directional-tiles "1-city" 4 12)
        (directional-tiles "2-city" 8 12)
        ))))

; Island rendering
(define (road-map-render island tile-size tileset output)
  ; an island is made of three layers
  ; the first layer is the background : land, sea or forest
  ; the second layer contains roads
  ; the third layer contain city and other features
  ; They are rendered on a single image (for now)
  (define img
    (make-image
      (* tile-size (2d-array-width island))
      (* tile-size (2d-array-height island))))
  ; Outside cell : contains only sea
  (define outside-cell (make-cell #t))
  ; Get a cell
  (define (get-cell i j)
    (if (2d-array-inside? island i j)
        (2d-array-ref island i j)
        outside-cell))
  ; Compute the suffix for the directional tiles
  (define (get-suffix i j pred?)
    (string-join
      (map
        (lambda (str x y)
          (if (pred? (get-cell (+ i x) (+ j y)))
              str
              ""))
        '("N" "S" "E" "W")
        '( 0   0   1  -1)
        '(-1   1   0   0))
      ""
      #:before-first "-"))
  ; Get the background tile name
  (define (get-background cell i j)
    (cond
      ((cell-sea? cell)
       (string-append
         (number->string (cell-variation cell))
         "-sea"
         (get-suffix i j cell-sea?)))
      ((cell-forest? cell)
       (string-append
         (number->string (cell-variation cell))
         "-forest"
         (get-suffix i j cell-forest?)))
      (#t "land")))
  ; Get a city tile name
  (define (get-city cell i j)
    (define suffix (get-suffix i j cell-city?))
    (string-append
      (number->string (cell-variation cell))
      "-city"
      (if (<= (string-length suffix) 2)
        suffix
        (string-join
          (map
            (lambda (str x y road-pred?)
              (if (or (road-pred? cell)
                      (cell-city? (get-cell (+ i x) (+ j y))))
                  str
                  ""))
            '("N" "S" "E" "W")
            '( 0   0   1  -1)
            '(-1   1   0   0)
            (list cell-road-N? cell-road-S? cell-road-E? cell-road-W?))
          ""
          #:before-first "-"))))
  ; Get the feature tile name
  (define (get-feature cell i j)
    (cond
      ((cell-summit? cell) "summit")
      ((cell-ruin? cell) "ruin")
      ((cell-city? cell) (get-city cell i j))
      (#t #f)))
  ; Get the road tile name
  (define (get-road cell)
    (string-append
      "road-"
      (string-join
        (map
          (lambda (str getter)
            (if (getter cell)
                str
                ""))
          (list "N" "S" "E" "W")
          (list cell-road-N? cell-road-S? cell-road-E? cell-road-W?))
        "")))
  ; Draw each cell
  (2d-array-for-each/indexes
    island
    (lambda (cell i j)
      ; Draw the background
      (image-draw-sprite! img (* i tile-size) (* j tile-size) tileset (get-background cell i j))
      ; Draw the roads
      (image-draw-sprite! img (* i tile-size) (* j tile-size) tileset (get-road cell))
      ; Draw the other features
      (define feature (get-feature cell i j))
      (when feature
        (image-draw-sprite! img (* i tile-size) (* j tile-size) tileset feature))
      ))
  ; Save the image to the output
  (image-save img output))
