tracer/src/Floorplan.hs

module Floorplan where

import Data.Matrix (Matrix(..))
import qualified Data.Matrix as M
import Data.Maybe

import Control.Monad (foldM)
import Control.Concurrent.MVar

import System.Random

import Types.Map

import Debug.Trace

buildHallFloorIO
  :: FloorConfig
  -> MVar Float
  -> Float
  -> IO (Matrix TileState, [Graph])
buildHallFloorIO fc progress increment = do
  rand <- newStdGen
  modifyMVar_ progress (return . (+ increment))
  let empty         = emptyFloor fc
  modifyMVar_ progress (return . (+ increment))
  let (g1, withElv) = buildElevator fc (placeHalls rand fc empty)
  modifyMVar_ progress (return . (+ increment))
  let (g2, withIW)  = buildInnerWalls g1 withElv
  modifyMVar_ progress (return . (+ increment))
  let withOW        = buildOuterWalls withIW
  modifyMVar_ progress (return . (+ increment))
  let closed        = closeOffices withOW
  modifyMVar_ progress (return . (+ increment))
  let doorgraph     = buildDoorsGraph closed
  modifyMVar_ progress (return . (+ increment))
  doors <- buildDoors closed doorgraph
  modifyMVar_ progress (return . (+ increment))
  let (_, facils)  = buildFacilities g2 fc doors
  modifyMVar_ progress (return . (+ increment))
  return (facils, doorgraph)

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

buildElevator
  :: FloorConfig
  -> (StdGen, Matrix TileState)
  -> (StdGen, Matrix TileState)
buildElevator fc (gen, empty) =
  let (row, col) = fcElevator 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 (flip $ M.setElem Wall) empty (boxCoord 2))
        (boxCoord 5)
      elvDoor = M.setElem Door (row + 2, col) buildShaft
  in  (gen, foldl ( flip $ M.setElem Elev) elvDoor (boxCoord 1))

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

boundSize :: Boundaries Int -> Int
boundSize (Boundaries mi ma) =
  (fst ma - fst mi) * (snd ma - snd mi)

buildHall
  :: (Int, Int)
  -> Int
  -> Boundaries Int
  -> Matrix TileState
  -> ([Boundaries Int], Matrix TileState)
buildHall coord@(row, col) width bs mat =
  let vertHalls = foldl (flip (M.mapCol
        (\r cur -> if r >= fst (matmin bs) && r <= fst (matmax bs)
          then replaceTile cur Hall
          else cur
          )))
        mat
        [col - (width `div` 2) .. col + (width `div` 2)]
      horzHalls = foldl (flip ( M.mapRow
        (\c cur -> if c >= snd (matmin bs) && c <= snd (matmax bs)
          then replaceTile cur Hall
          else cur
          )))
        vertHalls
        [row - (width `div` 2) .. row + (width `div` 2)]
  in  ( [ Boundaries (matmin bs) coord
        , Boundaries (fst (matmin bs), col) (row, snd (matmax bs))
        , Boundaries (row, snd (matmin bs)) (fst (matmax bs), col)
        , Boundaries coord (matmax bs)
        ]
      , 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 :: Int
  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
                ( if maxRow - 3 < row + 3
                  then (row + 2, row + 2)
                  else (row + 3, maxRow - 3)
                ) gn
              (cc, g2) = randomR
                ( if maxCol - 3 < col + 3
                  then (col + 2, col + 2)
                  else (col + 3,maxCol - 3)
                ) g1
              (nngen, nnmat) =
                if (cr - 2 > row && cr + 2 < maxRow)
                  && (cc - 2 > col && cc + 2 < maxCol)
                then
                  doCross
                    g2
                    (cr, cc)
                    (Boundaries coord (maxRow, maxCol))
                    mat
                else
                  let btups = (,)
                        <$> [fst coord .. maxRow]
                        <*> [snd coord .. maxCol]
                  in
                    ( g2
                    , foldl
                        (\acc coords ->
                          M.setElem (replaceTile (acc M.! coords) Offi) coords acc
                          ) mat btups
                    )
              doCross
                :: StdGen
                -> (Int, Int)
                -> Boundaries Int
                -> Matrix TileState
                -> (StdGen, Matrix TileState)
              doCross gen cd@(xr, xc) b imat =
                let nbs = map (uncurry Boundaries) bs
                    bs =
                      [ (matmin b, cd)
                      , ((fst (matmin b), col), (row, snd (matmax b)))
                      , ((row, snd (matmin b)), (fst (matmax b), col))
                      , (cd, matmax b)
                      ]
                    (ngen, crosses) = foldl
                      (\(agen, acc) (minb, maxb) ->
                        let (fc, gg1) = randomR (fst minb, fst maxb) agen
                            (fr, gg2) = randomR (snd minb, snd maxb) gg1
                        in  (gg2, acc ++ [(fc, fr)])
                        ) (gen, []) bs
                    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 boundSize b >= 16
                   then foldl
                     (\(agen, amat) (acr, nb) -> doCross agen acr nb amat)
                     (ngen, omat)
                     (zip crosses nbs)
                   else
                     (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  Hall `elem` (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
        (flip $ M.mapRow (\_ _ -> Wall))
        input
        [ 1
        , nrows input
        ]
      vert =
        foldl
        (flip $ M.mapCol (\_ _ -> Wall))
        horz
        [ 1
        , ncols horz
        ]
  in  vert

buildFacilities
  :: StdGen
  -> FloorConfig
  -> Matrix TileState
  -> (StdGen, Matrix TileState)
buildFacilities gen fc input =
  let flood ts mat coords@(cr, cc) =
        let cur = mat M.! coords
            altered = M.setElem ts coords mat
        in
          if cur == ts || cur /= Offi
          then mat
          else foldl (flood ts)
            altered
            [ (cr + 1, cc)
            , (cr - 1, cc)
            , (cr, cc + 1)
            , (cr, cc - 1)
            ]
      nearests = map (findNearestOffice input) (fcFacilities fc)
  in  foldl (\(agen, acc) x ->
        let (numfac, ngen) = randomR (0 :: Int, 1 :: Int) agen
            facil = if numfac == 1 then Kitc else Toil
        in  (ngen, flood facil acc x)
        ) (gen, input) nearests

findNearestOffice
  :: Matrix TileState
  -> (Int, Int)
  -> (Int, Int)
findNearestOffice mat (rrr, ccc) =
  let matcoord = (,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]
      distance :: (Int, Int) -> Int
      distance (ar, ac) = (ar - rrr) ^ (2 :: Int) + (ac - ccc) ^ (2 :: Int)
      inlist = zip matcoord (M.toList mat)
  in  foldl (\acc (xc, ts) ->
        if ts == Offi && distance acc > distance xc
        then xc
        else acc
        ) (fst $ head inlist) inlist

buildDoorsGraph :: Matrix TileState -> [Graph]
buildDoorsGraph mat =
  let maxCol r c
        | M.safeGet r (c + 1) mat == Just Offi = maxCol r (c + 1)
        | otherwise = c
      buildGraph :: Matrix TileState -> [Graph] -> (Int, Int) -> [Graph]
      buildGraph amat root coord@(br, bc)
        | bc > ncols amat - 1 =
          buildGraph amat root (br + 1, 1)
        | br > nrows amat - 1 =
          root
        | M.safeGet br bc amat == Just Offi =
          let flood acc (fr, fc) =
                let ncoords = [] ++
                      (if (fr + 1, fc) `notElem` acc &&
                        M.safeGet (fr + 1) fc amat == Just Offi
                      then [(fr + 1, fc)]
                      else []) ++
                      (if (fr - 1, fc) `notElem` acc &&
                        M.safeGet (fr - 1) fc amat == Just Offi
                      then [(fr - 1, fc)]
                      else []) ++
                      (if (fr, fc - 1) `notElem` acc &&
                        M.safeGet fr (fc - 1) amat == Just Offi
                      then [(fr, fc - 1)]
                      else []) ++
                      (if (fr, fc + 1) `notElem` acc &&
                        M.safeGet fr (fc + 1) amat == Just Offi
                      then [(fr, fc + 1)]
                      else [])
                in  foldl flood (acc ++ ncoords) ncoords
              roomcoords = flood [coord] coord
              b = Boundaries
                (minimum (map fst roomcoords), minimum (map snd roomcoords))
                (maximum (map fst roomcoords), maximum (map snd roomcoords))
              neighs = map (\(a, bx) -> (a, fromJust bx)) (filter ((/=Nothing) . snd)
                [ (North, M.safeGet (fst (matmin b) - 2) (snd (matmin b)) amat)
                , (South, M.safeGet (fst (matmax b) + 2) (snd (matmin b)) amat)
                , (East,  M.safeGet (fst (matmin b)) (snd (matmin b) - 2) amat)
                , (West,  M.safeGet (fst (matmin b)) (snd (matmax b) + 2) amat)
                ])
          in
            if Hall `elem` map snd neighs
            then
              let nroot =
                    if GRoom neighs b `notElem` connects (head root)
                    then
                      GHall
                        { connects = connects (head root) ++ [GRoom neighs b]
                        } : tail root
                    else root
              in  buildGraph amat nroot (br, 1 + snd (matmax b))
            else
              let nroot = root ++
                    if GRoom neighs b `elem` root
                    then []
                    else [GRoom neighs b]
              in  buildGraph amat nroot (br, 1 + snd (matmax b))
        | otherwise =
          buildGraph amat root (br, maxCol br (bc + 1))
  in  buildGraph mat [GHall []] (2, 2)

buildDoors :: Matrix TileState -> [Graph] -> IO (Matrix TileState)
buildDoors input graph = do
    foldM placeDoors input graph
  where
    placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState)
    placeDoors amat (GHall conns) =
      foldM placeDoors amat conns
    placeDoors amat (GRoom neighs bs) =
      if Hall `elem` map snd neighs
      then do
        let halls = filter ((== Hall) . snd) neighs
        idx <- randomRIO (0, length halls - 1)
        let (dir, _) = halls !! idx
        case dir of
          North ->
            inRow
              amat
              (fst (matmin bs) - 1)
              (snd (matmin bs), snd (matmax bs))
          South ->
            inRow
              amat
              (fst (matmax bs) + 1)
              (snd (matmin bs), snd (matmax bs))
          East ->
            inCol
              amat
              (fst (matmin bs), fst (matmax bs))
              (snd (matmin bs) - 1)
          West ->
            inCol
              amat
              (fst (matmin bs), fst (matmax bs))
              (snd (matmax bs) + 1)
      else do
        idx <- randomRIO (0, length neighs - 1)
        let (dir, _) = neighs !! idx
        case dir of
          North ->
            inRow
              amat
              (fst (matmin bs) - 1)
              (snd (matmin bs), snd (matmax bs))
          South ->
            inRow
              amat
              (fst (matmax bs) + 1)
              (snd (matmin bs), snd (matmax bs))
          East ->
            inCol
              amat
              (fst (matmin bs), fst (matmax bs))
              (snd (matmin bs) - 1)
          West ->
            inCol
              amat
              (fst (matmin bs), fst (matmax bs))
              (snd (matmax bs) + 1)
    inRow :: Matrix TileState -> Int -> (Int, Int) -> IO (Matrix TileState)
    inRow mat row cols = do
      col <- randomRIO cols
      let tile = mat M.! (row, col)
      if tile == Wall
        && length (filter
          (== Wall)
          (M.toList (M.submatrix (row - 1) (row + 1) col col mat)))
          == 1
      then
        if Door `elem` M.toList (M.submatrix row row (fst cols) (snd cols) mat)
        then return mat
        else do
          return $ M.setElem Door (row, col) mat
      else
        inRow mat row cols
    inCol :: Matrix TileState -> (Int, Int) -> Int -> IO (Matrix TileState)
    inCol mat rows col = do
      row <- randomRIO rows
      let tile = mat M.! (row, col)
      if tile == Wall
        && length (filter
          (== Wall)
          (M.toList (M.submatrix row row (col - 1) (col + 1) mat)))
          == 1
      then
        if Door `elem` M.toList (M.submatrix (fst rows) (snd rows) col col mat)
        then return mat
        else do
          return $ M.setElem Door (row, col) mat
      else
        inCol mat rows col