#lang racket/base

; Dungeon generator
; Name from Etrian Odyssey, as the original output style was to look like Etrian Odyssey maps

; The generator outputs a 2d-array of cells, that should be given to a renderer
(require
  "../collection/2d-array.rkt"
  "../base-generation/random.rkt"
  "maze.rkt"
  "yggdrasil/cell.rkt"
  "yggdrasil/hard-coded.rkt"
  "yggdrasil/maze.rkt"
  "yggdrasil/undefined-filler.rkt"
  )

(provide
  yggdrasil-generate)

; The generator uses sectors to generate the dungeon
; Each sector is filled with a pattern (generated or hard-coded)

; Hard-coded sectors
; Those should be completed by changing the unknown parts with wall or path
(define *sector-hard-coded*
  (map
    yggdrasil-hard-coded-generate
    '(("$$$$$$$"
       "$#####$"
       "$#...#$"
       "$#.!.#$"
       "$#...#$"
       "$##+##$"
       "$$$.$$$")
      ("$$$$$$$"
       "$#####$"
       "$#...#$"
       ".+.!.#$"
       "$#...#$"
       "$#####$"
       "$$$$$$$")
      ("$$.$$$"
       "$#v##$"
       "$#..#$"
       "$#.!#$"
       "$#v##$"
       "$$.$$$")
      ("$$$$$$"
       "$####$"
       ".>..>."
       "$#!.#$"
       "$####$"
       "$$$$$$")
      ("$$.$$$$"
       "$#+###$"
       "$#.#!#$"
       "$#!#.#$"
       "$###+#$"
       "$$$$.$$")
      ("$$$$$$$"
       "$#####$"
       ".+.#!#$"
       "$#!#.+."
       "$#####$"
       "$$$$$$$")
      )))

; Fill a sector with an hard coded part
; Each hard-coded section is at most 7×7, so there is a need to fill the surrounding area
(define (sector-hard-coded-generate width height)
  (define sector (make-2d-array width height (yggdrasil-cell-undefined)))
  (define hard-coded-part (random:from-list *sector-hard-coded*))
  ; Place the hard-coded part inside the sector, at random place
  (define max-offset-x (- width (2d-array-width hard-coded-part)))
  (define max-offset-y (- height (2d-array-height hard-coded-part)))
  (2d-array-copy! sector
    (if (> max-offset-x 0) (random max-offset-x) 0)
    (if (> max-offset-y 0) (random max-offset-y) 0)
    hard-coded-part)
  ; Remove the undefined cells
  (yggdrasil-undefined-fill sector))

; Fill a sector with undefined and replace all of it
; Similar to hard-coded-generate, but without the hard-coded part
(define (sector-undefined-fill-generate width height)
  (define sector (make-2d-array width height (yggdrasil-cell-undefined)))
  (yggdrasil-undefined-fill sector))

; Transformation functions for changing the orientation of a sector (mainly useful for sectors with hard-coded parts)
; No transformation
(define (sector-identity sect)
  sect)

; Horizontal flip
(define (sector-horizontal-flip sect)
  (define width (2d-array-width sect))
  (2d-array-map/indexes
    sect
    (lambda (_ i j)
      (define cell (2d-array-ref sect (- width 1 i) j))
      ; Shortcut orientation is changed
      (cond
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-EW)
         (get-yggdrasil-cell 'shortcut-WE))
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-WE)
         (get-yggdrasil-cell 'shortcut-EW))
        (#t cell)))))

; Vertical flip
(define (sector-vertical-flip sect)
  (define height (2d-array-height sect))
  (2d-array-map/indexes
    sect
    (lambda (_ i j)
      (define cell (2d-array-ref sect i (- height 1 j)))
      ; Shortcut orientation is changed
      (cond
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-NS)
         (get-yggdrasil-cell 'shortcut-SN))
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-SN)
         (get-yggdrasil-cell 'shortcut-NS))
        (#t cell)))))

; Rotation 180°
(define (sector-180-rotate sect)
  (define width (2d-array-width sect))
  (define height (2d-array-height sect))
  (2d-array-map/indexes
    sect
    (lambda (_ i j)
      (define cell (2d-array-ref sect (- width 1 i) (- height 1 j)))
      ; Shortcut orientation is changed
      (cond
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-NS)
         (get-yggdrasil-cell 'shortcut-SN))
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-SN)
         (get-yggdrasil-cell 'shortcut-NS))
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-EW)
         (get-yggdrasil-cell 'shortcut-WE))
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-WE)
         (get-yggdrasil-cell 'shortcut-EW))
        (#t cell)))))

; Transposition (square sector only)
(define (sector-transpose sect)
  (2d-array-map/indexes
    sect
    (lambda (_ i j)
      (define cell (2d-array-ref sect j i))
      ; Shortcut orientation is changed
      (cond
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-NS)
         (get-yggdrasil-cell 'shortcut-WE))
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-SN)
         (get-yggdrasil-cell 'shortcut-EW))
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-EW)
         (get-yggdrasil-cell 'shortcut-SN))
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-WE)
         (get-yggdrasil-cell 'shortcut-NS))
        (#t cell)))))

; Antitransposition (square sector only)
(define (sector-antitranspose sect)
  (define width (2d-array-width sect))
  (define height (2d-array-height sect))
  (2d-array-map/indexes
    sect
    (lambda (_ i j)
      (define cell (2d-array-ref sect (- height 1 j) (- width 1 i)))
      ; Shortcut orientation is changed
      (cond
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-NS)
         (get-yggdrasil-cell 'shortcut-EW))
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-SN)
         (get-yggdrasil-cell 'shortcut-WE))
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-EW)
         (get-yggdrasil-cell 'shortcut-NS))
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-WE)
         (get-yggdrasil-cell 'shortcut-SN))
        (#t cell)))))

; Rotation 90° counter-clockwise (square sector only)
(define (sector-90-rotate sect)
  (define height (2d-array-height sect))
  (2d-array-map/indexes
    sect
    (lambda (_ i j)
      (define cell (2d-array-ref sect (- height 1 j) i))
      ; Shortcut orientation is changed
      (cond
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-NS)
         (get-yggdrasil-cell 'shortcut-WE))
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-SN)
         (get-yggdrasil-cell 'shortcut-EW))
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-EW)
         (get-yggdrasil-cell 'shortcut-NS))
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-WE)
         (get-yggdrasil-cell 'shortcut-SN))
        (#t cell)))))

; Rotation 270° counter-clockwise (square sector only)
(define (sector-270-rotate sect)
  (define width (2d-array-width sect))
  (2d-array-map/indexes
    sect
    (lambda (_ i j)
      (define cell (2d-array-ref sect j (- width 1 i)))
      ; Shortcut orientation is changed
      (cond
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-NS)
         (get-yggdrasil-cell 'shortcut-EW))
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-SN)
         (get-yggdrasil-cell 'shortcut-WE))
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-EW)
         (get-yggdrasil-cell 'shortcut-SN))
        ((eq? (yggdrasil-cell-feature cell) 'shortcut-WE)
         (get-yggdrasil-cell 'shortcut-NS))
        (#t cell)))))

; Apply a transformation to a sector, choosen at random
(define (sector-transform sect)
  (define width (2d-array-width sect))
  (define height (2d-array-height sect))
  (define lst-transform
    (append
      (list sector-identity sector-horizontal-flip sector-vertical-flip sector-180-rotate)
      (if (eq? width height)
          (list sector-transpose sector-antitranspose sector-90-rotate sector-270-rotate)
          (list))))
  ((random:from-list lst-transform) sect))

; Generate a sector, from a generator choosen at random
(define (sector-generate width height)
  (define lst-generator
    (list
      (lambda (width height)
        (yggdrasil-maze-generate width height #t))
      (lambda (width height)
        (yggdrasil-maze-generate width height #f))
      sector-hard-coded-generate
      sector-undefined-fill-generate
      ))
  (sector-transform
    ((random:from-list lst-generator) width height)))

; Replace one event in the sector with the given cell
(define (sector-replace-one-event sect cell)
  ; Find the position of all events
  (define pos-events
    (2d-array-fold/indexes
      sect
      '()
      (lambda (val i j res)
        (if (yggdrasil-cell-event? val)
            (cons (cons i j) res)
            res))))
  ; choose one event position, if there is one
  (when (not (null? pos-events))
    (define pos (random:from-list pos-events))
    ; Change the event with the cell
    (2d-array-set! sect (car pos) (cdr pos) cell))
  ; Return the sector
  sect)

; Find the paths between sectors:
; It's the list of positions where the right/bottom line of the first and the left/top line of the second have both paths or event
(define (path-or-event? cell)
  (or (yggdrasil-cell-path? cell)
      (eq? 'event (yggdrasil-cell-feature cell))))
; Note: the sectors should have the same width or height
; E-W (right/left)
(define (sector-find-paths-EW sector1 sector2 [idx 0] [res '()])
  (define width1 (2d-array-width sector1))
  (define height (2d-array-height sector1))
  (cond
    ( (>= idx height)
      res)
    (#t
      (define cell1 (2d-array-ref sector1 (- width1 1) idx))
      (define cell2 (2d-array-ref sector2 0 idx))
      (sector-find-paths-EW
        sector1
        sector2
        (+ idx 1)
        (if (and (path-or-event? cell1) (path-or-event? cell2))
            (cons idx res)
            res)))))
; N-S (bottom/top)
(define (sector-find-paths-NS sector1 sector2 [idx 0] [res '()])
  (define width (2d-array-width sector1))
  (define height1 (2d-array-height sector1))
  (cond
    ( (>= idx width)
      res)
    (#t
      (define cell1 (2d-array-ref sector1 idx (- height1 1)))
      (define cell2 (2d-array-ref sector2 idx 0))
      (sector-find-paths-NS
        sector1
        sector2
        (+ idx 1)
        (if (and (path-or-event? cell1) (path-or-event? cell2))
            (cons idx res)
            res)))))

; Add a staircase to a sector
(define (sector-add-staircase sector start? end?)
  (cond
    ; Start sector ? => add a staircase-down
    (start?
     (sector-replace-one-event sector (get-yggdrasil-cell 'staircase-down)))
    ; End sector? => add a staircase-up
    (end?
     (sector-replace-one-event sector (get-yggdrasil-cell 'staircase-up)))
    ; Else, return the sector unmodified
    (#t sector)))

; Add a path/door/shortcut on a level at one of the possible positions
(define (add-path-or-shortcut! level linked? shortcut positions direction)
  (when (not (null? positions))
    (define pos (random:from-list positions))
    (define x (car pos))
    (define y (cdr pos))
    (define EW-direction? (eq? 'EW direction))
    ; Replace the possible events in the surrounding by paths
    (2d-array-set! level
      (if EW-direction? (- x 1) x)
      (if EW-direction? y (- y 1))
      (get-yggdrasil-cell 'path))
    (2d-array-set! level
      (if EW-direction? (+ x 1) x)
      (if EW-direction? y (+ y 1))
      (get-yggdrasil-cell 'path))
    ; Replace the cell
    (2d-array-set! level x y
      (cond
        ; If linked, can be a door or a path
        ((and linked? (random:boolean)) (get-yggdrasil-cell 'door))
        (linked? (get-yggdrasil-cell 'path))
        ; If a shortcut is possible, put it
        (shortcut shortcut)
        ; Else, do not change the cell
        (#t (2d-array-ref level x y))
        ))))

;;
; The way sectors are created depends on the next functions

; Maze-like topography
; This generator divides the dungeon into sectors of equal sizes (of 9×9 squares).
; A maze is used to generate how sectors are connected between each others.
(define (maze-topography-generate width height)
  (define sector-size 9)
  (define sector-size-with-wall (+ 1 sector-size)) ; +1 to be able to put walls between sectors
  (define nb-sector-horizontal (/ width sector-size-with-wall))
  (define nb-sector-vertical (/ height sector-size-with-wall))
  ; Level to output
  (define level
    (build-2d-array
      width
      height
      (lambda (i j)
        (if (or (eq? 0 (modulo (+ i 1) sector-size-with-wall))
                (eq? 0 (modulo (+ j 1) sector-size-with-wall)))
            (get-yggdrasil-cell 'wall)
            (get-yggdrasil-cell 'undefined)))))
  ; Maze topology
  (define maze (make-maze nb-sector-horizontal nb-sector-vertical #f))
  ; Find the position of the maze-cell at the max distance from the starting place
  (define max-distance-pos
    (cdr
      (2d-array-fold/indexes
        maze
        '(-1 . #f)
        (lambda (val i j res)
          (if (> (maze-cell-distance-from-start val)
                 (car res))
              (cons (maze-cell-distance-from-start val) (cons i j))
              res)))))
  ; Helping function to place the staircases
  (define (add-staircase maze-cell i j sector)
    (sector-add-staircase
      sector
      (eq? 0 (maze-cell-distance-from-start maze-cell))
      (and (eq? i (car max-distance-pos))
           (eq? j (cdr max-distance-pos)))))
  ; create each sector
  (define sectors
    (2d-array-map/indexes
      maze
      (lambda (maze-cell i j)
        ; Replace one of the event with a staircase for the maze-cell with min and max distance
        (add-staircase maze-cell i j
          (sector-generate sector-size sector-size)))))
  ; Draw the sectors
  (2d-array-for-each/indexes
    sectors
    (lambda (sector i j)
      (2d-array-copy! level (* i sector-size-with-wall) (* j sector-size-with-wall) sector)))
  ; Place the paths and shortcuts between sectors
  (2d-array-for-each/indexes
    maze
    (lambda (cell i j)
      ; Link to previous horizontal sector
      (when (2d-array-inside? maze (- i 1) j)
        ; Previous cell
        (define pcell (2d-array-ref maze (- i 1) j))
        ; The position of the possible paths
        (define possible-paths
          (map
            (lambda (y)
              (cons (- (* i sector-size-with-wall) 1)
                    (+ y (* j sector-size-with-wall))))
            (sector-find-paths-EW
              (2d-array-ref sectors (- i 1) j)
              (2d-array-ref sectors i j))))
        ; Distance between the two cells
        (define cell-distance (- (maze-cell-distance-from-start cell) (maze-cell-distance-from-start pcell)))
        ; Place a path
        (add-path-or-shortcut!
          level
          (maze-cell-linked-left? cell)
          (or (and (< 4 cell-distance) (get-yggdrasil-cell 'shortcut-EW))
              (and (> -4 cell-distance) (get-yggdrasil-cell 'shortcut-WE)))
          possible-paths
          'EW))
      ; Link to previous vertical sector
      (when (2d-array-inside? maze i (- j 1))
        ; Next cell
        (define pcell (2d-array-ref maze i (- j 1)))
        ; The position of the possible paths
        (define possible-paths
          (map
            (lambda (x)
              (cons (+ x (* i sector-size-with-wall))
                    (- (* j sector-size-with-wall) 1)))
            (sector-find-paths-NS
              (2d-array-ref sectors i (- j 1))
              (2d-array-ref sectors i j))))
        ; Distance between the two cells
        (define cell-distance (- (maze-cell-distance-from-start cell) (maze-cell-distance-from-start pcell)))
        ; Place a path
        (add-path-or-shortcut!
          level
          (maze-cell-linked-up? cell)
          (or (and (< 4 cell-distance) (get-yggdrasil-cell 'shortcut-SN))
              (and (> -4 cell-distance) (get-yggdrasil-cell 'shortcut-NS)))
          possible-paths
          'NS))
      ))
  ; Return the level
  level)

; Binary space partition topography
; The sectors are cut using a binary space partition algorithm
; The entrance and exit are put in the leaves of the different child from the root.
; The steps are:
; - generate a tree of sectors
; - generate the sectors
; - place paths and walls between connected sectors
; - place the entrance and exit
; Note: no shortcut is generated
; Recursive function
(define (bsp-topography-generate width height [start? #t] [exit? #t])
  ; Min size in a direction to be able to cut along the perpendiculary direction
  (define min-cut-size 15)
  ; Dimensions of the area to partition (should be odd)
  (define w (or (and (odd? width) width) (- width 1)))
  (define h (or (and (odd? height) height) (- height 1)))
  ; Level, filled with walls
  (define level (make-2d-array width height (get-yggdrasil-cell 'wall)))
  ; Function to return the repartition of start?/exit? between the two childs
  (define (child-staircase)
    (if (random:boolean)
        (cons (cons start? #f) (cons #f exit?))
        (cons (cons #f exit?) (cons start? #f))))
  ; Function to cut a level vertically
  (define (cut-level-vertical)
    ; Size of the first area (the second has a size of (width - size-first - 1))
    (define available (- w min-cut-size))
    (define size-first
      (+ (floor (/ min-cut-size 2))
         (if (eq? available 0)
             0
             (* 2 (floor (/ (random available) 2))))))
    (define staircases (child-staircase))
    ; Draw the first child
    (define first-child (bsp-topography-generate size-first height (caar staircases) (cdar staircases)))
    (2d-array-copy! level 0 0 first-child)
    ; Draw the second child
    (define second-child (bsp-topography-generate (- width size-first 1) height (cadr staircases) (cddr staircases)))
    (2d-array-copy! level (+ size-first 1) 0 second-child)
    ; Link the two areas
    (define possible-paths
      (map
        (lambda (y) (cons size-first y))
        (sector-find-paths-EW first-child second-child)))
    (add-path-or-shortcut! level #t #f possible-paths 'EW))
  ; Function to cut a level horizontally
  (define (cut-level-horizontal)
    ; Size of the first area (the second has a size of (height - size-first - 1))
    (define available (- h min-cut-size))
    (define size-first
      (+ (floor (/ min-cut-size 2))
         (if (eq? available 0)
             0
             (* 2 (floor (/ (random available) 2))))))
    (define staircases (child-staircase))
    ; Draw the first child
    (define first-child (bsp-topography-generate width size-first (caar staircases) (cdar staircases)))
    (2d-array-copy! level 0 0 first-child)
    ; Draw the second child
    (define second-child (bsp-topography-generate width (- height size-first 1) (cadr staircases) (cddr staircases)))
    (2d-array-copy! level 0 (+ size-first 1) second-child)
    ; Link the two areas
    (define possible-paths
      (map
        (lambda (x) (cons x size-first))
        (sector-find-paths-NS first-child second-child)))
    (add-path-or-shortcut! level #t #f possible-paths 'NS))
  ;
  ; Check the size
  (cond
    ; If not large enough to cut into two parts, generate a sector in the area
    ( (and (< w min-cut-size) (< h min-cut-size))
      (2d-array-copy! level 0 0
        (sector-add-staircase
          (sector-generate w h)
          start?
          exit?)))
    ; If the width is large enough, but not the height, cut vertically
    ( (and (>= w min-cut-size) (< h min-cut-size))
      (cut-level-vertical))
    ; If the height is large enough, but not the width, cut horizontally
    ( (and (< w min-cut-size) (>= h min-cut-size))
      (cut-level-horizontal))
    ; Else, choose a direction at random
    ( #t
      ((if (random:boolean) cut-level-horizontal cut-level-vertical))))
  ; Return the level
  level)

; Single sector topography
; This algorithm generates just one sector
; and replaces two events with staircases
(define (single-sector-topography-generate width height)
  ; The sector
  ; Width and height are -1 to put a wall on the bottom and left lines
  (define sector
    (sector-add-staircase
      (sector-add-staircase
        (sector-generate (- width 1) (- height 1))
        #t #f)
      #f #t))
  ; Return the level
  (build-2d-array
    width
    height
    (lambda (i j)
      (if (2d-array-inside? sector i j)
          (2d-array-ref sector i j)
          (get-yggdrasil-cell 'wall)))))

; Choose a topography
(define (yggdrasil-topography-generate width height)
  (define topographies
    (list
      maze-topography-generate
      maze-topography-generate
      bsp-topography-generate
      bsp-topography-generate
      single-sector-topography-generate))
  ((random:from-list topographies) width height))

; Replace events
; Event are used to indicate something interesting may be present at a location during generation
; This function replace all the events generated with a more interesting feature
(define (yggdrasil-replace-events level)
  (define possible-events
    (map
      get-yggdrasil-cell
      '(path path path event check check check resource-mine resource-take resource-chop resource-harvest resource-harvest chest chest chest)))
  (2d-array-map
    level
    (lambda (cell)
      (if (yggdrasil-cell-event? cell)
          (random:from-list possible-events)
          cell))))

; Generator function
(define (yggdrasil-generate)
  (define width 41)
  (define height 31)
  (define level (make-2d-array width height (get-yggdrasil-cell 'wall)))
  (2d-array-copy! level 1 1
    (yggdrasil-topography-generate (- width 1) (- height 1)))
  ; At the end of generation, replace all events with another kind of feature
  (yggdrasil-replace-events level))

;  ; Fixed for testing tileset rendering
;  (yggdrasil-hard-coded-generate
;    '("################"
;      "#.L.....+..<...#"
;      "#.......#..#v#^#"
;      "#Omhtc!?#7.>...#"
;      "################")))

