tracer/src/Floorplan.hs

module Floorplan where

import Data.Matrix (Matrix(..))
import qualified Data.Matrix as M
import Data.Foldable (find)
import Data.Maybe (fromMaybe)

import System.Random

import Debug.Trace

data TileState
  = Wall
  | Wind
  | Door
  | Hall
  | Offi
  | Toil
  | Kitc
  | Elev
  | Unde
  deriving (Eq)

instance Show TileState where
  show Wall = "#"
  show Wind = "~"
  show Door = "+"
  show Hall = "_"
  show Offi = "."
  show Toil = "o"
  show Kitc = "k"
  show Elev = "x"
  show Unde = " "

data FloorConfig = FloorConfig
  { elevator    :: (Int, Int)
  , facilities  :: [(Int, Int)]
  , size        :: (Int, Int)
  } deriving (Show)

data Boundaries = Boundaries
  { matmin :: (Int, Int)
  , matmax :: (Int, Int)
  } deriving (Show)

buildHallFloorIO :: FloorConfig -> IO (Matrix TileState)
buildHallFloorIO fc = do
  rand <- newStdGen
  return $ buildHallFloor fc rand

buildHallFloor :: FloorConfig -> StdGen -> Matrix TileState
buildHallFloor fc gen =
  let empty         = emptyFloor fc
      (g1, withElv) = buildElevator fc (placeHalls gen fc empty)
      (g2, withIW)  = buildInnerWalls g1 withElv
      withOW        = buildOuterWalls withIW
      closed        = closeOffices withOW
  in  closed

emptyFloor :: FloorConfig -> Matrix TileState
emptyFloor fc =
  let (rows, cols) = size fc
  in  M.matrix rows cols (const Unde)

buildElevator
  :: FloorConfig
  -> (StdGen, Matrix TileState)
  -> (StdGen, Matrix TileState)
buildElevator fc (gen, emptyFloor) =
  let (row, col) = elevator fc
      boxCoord x = (,) <$> [row - x .. row + x] <*> [col - x .. col + x]
      buildShaft = foldl
        (\acc coord -> M.setElem (replaceTile (acc M.! coord) Hall) coord acc)
        (foldl (\acc coord -> M.setElem Wall coord acc) emptyFloor (boxCoord 2))
        (boxCoord 5)
      elvDoor = M.setElem Door (row + 2, col) buildShaft
  in  (gen, foldl (\acc coord -> M.setElem Elev coord acc) elvDoor (boxCoord 1))

placeHalls
  :: StdGen
  -> FloorConfig
  -> Matrix TileState
  -> (StdGen, Matrix TileState)
placeHalls rng fc input =
  doHalls rng
   [(Boundaries (1,1) (nrows input, ncols input))]
   (elevator fc) 5 input
  where
    elPos = elevator fc
    doHalls rand bounds cross wmax mat =
      let (rnd, gen) = next rand
      in  foldl (\(agen, amat) b ->
            let (row, g1)   = randomR (fst (matmin b), fst (matmax b)) agen
                (col, g2)   = randomR (snd (matmin b), snd (matmax b)) g1
                (nw, g3)    = randomR (2, wmax) g2
                (nbs, nmat) = buildHall cross nw b amat
            in
              if hallRatio nmat < 0.4 && wmax - 1 > 2
              then doHalls g3 nbs (row, col) (wmax -1) nmat
              else (g3, nmat)
            ) (rand, mat) bounds

boundSize :: Boundaries -> Int
boundSize (Boundaries min max) =
  (fst max - fst min) * (snd max - snd min)

buildHall
  :: (Int, Int)
  -> Int
  -> Boundaries
  -> Matrix TileState
  -> ([Boundaries], Matrix TileState)
buildHall coord@(row, col) width bounds mat =
  let vertHalls = foldl (\acc c -> M.mapCol
        (\r cur -> if r >= fst (matmin bounds) && r <= fst (matmax bounds)
          then replaceTile cur Hall
          else cur
          ) c acc)
        mat
        [col - (width `div` 2) .. col + (width `div` 2)]
      horzHalls = foldl (\acc r -> M.mapRow
        (\c cur -> if c >= snd (matmin bounds) && c <= snd (matmax bounds)
          then replaceTile cur Hall
          else cur
          ) r acc)
        vertHalls
        [row - (width `div` 2) .. row + (width `div` 2)]
  in  ( [ Boundaries (matmin bounds) coord
        , Boundaries (fst (matmin bounds), col) (row, snd (matmax bounds))
        , Boundaries (row, snd (matmin bounds)) (fst (matmax bounds), col)
        , Boundaries coord (matmax bounds)
        ]
      , horzHalls
      )

replaceTile :: TileState -> TileState -> TileState
replaceTile cur new
  | cur == Unde = new
  | otherwise   = cur

hallRatio :: Matrix TileState -> Double
hallRatio mat =
  let hs = foldl (\acc a -> if a == Hall then acc + 1 else acc) 0 mat
  in  fromIntegral hs / fromIntegral (nrows mat * ncols mat)

buildInnerWalls :: StdGen -> Matrix TileState -> (StdGen, Matrix TileState)
buildInnerWalls rng input =
  let floodSearchReplace
        :: StdGen
        -> (Int, Int)
        -> Matrix TileState
        -> (StdGen, Matrix TileState)
      floodSearchReplace gn coord@(row, col) mat
        | mat M.! coord == Unde =
          let maxRow = doRow row
              doRow r
                | M.safeGet (r + 1) col mat == Just Unde = doRow (r + 1)
                | otherwise = r
              maxCol = doCol col
              doCol c
                | M.safeGet row (c + 1) mat == Just Unde = doCol (c + 1)
                | otherwise = c
              (cr, g1) = randomR (row, maxRow) gn
              (cc, g2) = randomR (col, maxCol) g1
              (nngen, nnmat) = doCross
                g2
                (cr, cc)
                (Boundaries coord (maxRow, maxCol))
                mat
              doCross
                :: StdGen
                -> (Int, Int)
                -> Boundaries
                -> Matrix TileState
                -> (StdGen, Matrix TileState)
              doCross gen coord@(xr, xc) b imat =
                let nbs = map (\(min, max) -> Boundaries min max) bounds
                    bounds =
                      [ (matmin b, coord)
                      , ((fst (matmin b), col), (row, snd (matmax b)))
                      , ((row, snd (matmin b)), (fst (matmax b), col))
                      , (coord, matmax b)
                      ]
                    (ngen, crosses) = foldl
                      (\(agen, acc) (minb, maxb) ->
                        let (fc, g1) = randomR (fst minb, fst maxb) agen
                            (fr, g2) = randomR (snd minb, snd maxb) g1
                        in  (g2, acc ++ [(fc, fr)])
                        ) (gen, []) bounds
                    horz = M.mapRow (\icol cur ->
                      if icol >= snd (matmin b) && icol <= snd (matmax b)
                      then replaceTile cur Wall
                      else cur
                      ) xr imat
                    vert = M.mapCol (\irow cur ->
                      if irow >= fst (matmin b) && irow <= fst (matmax b)
                      then replaceTile cur Wall
                      else cur
                      ) xc horz
                    omat = foldl
                      (\acc coords ->
                        M.setElem (replaceTile (acc M.! coords) Offi) coords acc
                        ) vert btups
                    btups = (,)
                      <$> [fst (matmin b) .. fst (matmax b)]
                      <*> [snd (matmin b) .. snd (matmax b)]
                in if trace ("bs: " ++ show (boundSize b)) (boundSize b) >= 16
                   then foldl
                     (\(agen, amat) (cr, nb) -> doCross agen cr nb amat)
                     (ngen, omat)
                     (zip crosses nbs)
                   else trace
                     ("built cross at " ++ show coord ++ " within " ++ show b)
                     (gen, omat)
          in  (nngen, nnmat)
        | otherwise = (gn, mat)
      tups mat = (,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]
  in  foldl (\(agen, amat) cds -> floodSearchReplace agen cds amat)
        (rng, input) (tups input)

closeOffices :: Matrix TileState -> Matrix TileState
closeOffices input =
  let tups mat = (,) <$> [2 .. nrows mat - 1] <*> [2 .. ncols mat - 1]
      isNeighbor (row, col) =
        let subm = M.submatrix (row -1) (row + 1) (col - 1) (col + 1) input
        in  any (== Hall) (M.toList subm)
  in  foldl (\acc coord ->
        if input M.! coord == Offi && isNeighbor coord
        then M.setElem Wall coord acc
        else acc
        ) input (tups input)

buildOuterWalls :: Matrix TileState -> Matrix TileState
buildOuterWalls input =
  let horz :: Matrix TileState
      horz =
        foldl
        (\amat r -> M.mapRow (\_ _ -> Wall) r amat)
        input
        [ 1
        , nrows input
        ]
      vert =
        foldl
        (\amat c -> M.mapCol (\_ _ -> Wall) c amat)
        horz
        [ 1
        , ncols horz
        ]
  in  vert