tracer/src/Floorplan.hs

module Floorplan where

import Affection as A

import Data.Matrix (Matrix(..))
import qualified Data.Matrix as M
import qualified Data.Text as T
import Data.Maybe
import qualified Data.Vector as V
import Data.String

import Linear (V2(..))

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

import System.Random

-- internal imports

import Util

import Types.Map

buildHallFloorIO
  :: FloorConfig
  -> MVar (Float, T.Text)
  -> Float
  -> IO (Matrix TileState, V.Vector Graph)
buildHallFloorIO fc progress increment = do
  rand <- newStdGen
  modifyMVar_ progress (return . (\(p, _) ->
    ( p + increment
    , "New RNG"
    )))
  let empty         = emptyFloor fc
  modifyMVar_ progress (return . (\(p, _) ->
    ( p + increment
    , "Built empty floor"
    )))
  let (g1, withElv) = buildElevator fc (placeHalls rand fc empty)
  modifyMVar_ progress (return . (\(p, _) ->
    ( p + increment
    , "Placed Elevator"
    )))
  let (g2, withIW)  = buildInnerWalls g1 withElv
  modifyMVar_ progress (return . (\(p, _) ->
    ( p + increment
    , "Built inner walls"
    )))
  let withOW        = buildOuterWalls withIW
  modifyMVar_ progress (return . (\(p, _) ->
    ( p + increment
    , "built outer walls"
    )))
  let closed        = closeOffices withOW
  modifyMVar_ progress (return . (\(p, _) ->
    ( p + increment
    , "Closed offices"
    )))
  doorgraph     <- buildDoorsGraph closed
  modifyMVar_ progress (return . (\(p, _) ->
    ( p + increment
    , "Doorgraph"
    )))
  doors <- buildDoors closed doorgraph
  modifyMVar_ progress (return . (\(p, _) ->
    ( p + increment
    , "Built doors"
    )))
  let (_, facils)  = buildFacilities g2 fc doors
  modifyMVar_ progress (return . (\(p, _) ->
    ( p + increment
    , "Built facilities"
    )))
  accessGraph <- assignClearance doorgraph facils
  modifyMVar_ progress (return . (\(p, _) ->
    ( p + increment
    , "Assigned room clearances"
    )))
  A.logIO
    A.Debug
    ("length accessGraph: " <> fromString (show $ length accessGraph))
  A.logIO
    A.Debug
    ("length doorgraph: " <> fromString (show $ length doorgraph))
  return (facils, accessGraph)

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 (V2 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 1))
        (boxCoord 3)
      elvDoor = M.setElem Door (row + 1, col) buildShaft
  in  (gen, foldl ( flip $ M.setElem Elev) elvDoor (boxCoord 0))

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
      :: StdGen
      -> [Boundaries Int]
      -> (V2 Int)
      -> Int
      -> Matrix TileState
      -> (StdGen, Matrix TileState)
    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
            (nbs, nmat) = buildHall cross 3 b amat
        in
          if wmax - 1 >= 3 &&
            all (\(Boundaries (minr, minc) (maxr, maxc)) ->
              maxr - minr > 3 && maxc - minc > 3) nbs
          then doHalls g2 nbs (V2 row col) (wmax -1) nmat
          else (g2, nmat)
        ) (rand, mat) bs

buildHall
  :: (V2 Int)
  -> Int
  -> Boundaries Int
  -> Matrix TileState
  -> ([Boundaries Int], Matrix TileState)
buildHall (V2 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) (row, col)
        , Boundaries (fst (matmin bs), col) (row, snd (matmax bs))
        , Boundaries (row, snd (matmin bs)) (fst (matmax bs), col)
        , Boundaries (row, col) (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 tups mat = (,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]
  in  foldl (\(agen, amat) cds -> floodSearchReplace agen cds amat)
        (rng, input) (tups input)

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)
              coord
              (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
              )
    in  (nngen, nnmat)
  | otherwise = (gn, mat)

doCross
  :: RandomGen t
  => t
  -> (Int, Int)
  -> (Int, Int)
  -> Boundaries Int
  -> Matrix TileState
  -> (t, Matrix TileState)
doCross gen cd@(xr, xc) coord@(row, col) 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 size b >= 16
     then foldl
       (\(agen, amat) (acr, nb) -> doCross agen acr coord nb amat)
       (ngen, omat)
       (zip crosses nbs)
     else
       (gen, omat)

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 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, facilFlood facil acc x)
        ) (gen, input) nearests

facilFlood 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 (facilFlood ts)
      altered
      [ (cr + 1, cc)
      , (cr - 1, cc)
      , (cr, cc + 1)
      , (cr, cc - 1)
      ]

findNearestOffice
  :: Matrix TileState
  -> (V2 Int)
  -> (Int, Int)
findNearestOffice mat (V2 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 -> IO (V.Vector Graph)
buildDoorsGraph mat =
  weedOut (buildGraph mat mat (V.singleton (GHall V.empty)) (2, 2))
  where
    weedOut vect = if V.null vect
      then
        return V.empty
      else
        case V.head vect of
          hall@(GHall _) ->
            (hall `V.cons`) <$> weedOut (V.tail vect)
          g@(GRoom neighs _ _ _) -> do
            let filtered = V.filter ((== Offi) . snd) neighs
            rand <- randomRIO (0, length filtered -1) :: IO Int
            let nneigh = filtered V.! rand `V.cons` V.empty
            rest <- weedOut (V.tail vect)
            return (g { neighbs = nneigh } `V.cons` rest)

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


flood amat 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 amat) (acc ++ ncoords) ncoords

assignClearance :: V.Vector Graph -> M.Matrix TileState -> IO (V.Vector Graph)
assignClearance graph imat =
  V.foldM doAssignClearance V.empty graph
  where
    doAssignClearance acc (GHall conns) = do
      ret <- GHall <$> V.foldM (\facc a -> do
        res <- reassign True facc a
        return (facc `V.snoc` res)
        ) V.empty conns
      return (ret `V.cons` acc)
    doAssignClearance acc room = do
      ret <- reassign False acc room
      return (acc `V.snoc` ret)
    reassign :: Bool -> V.Vector Graph -> Graph -> IO Graph
    reassign p acc room@(GRoom ns b _ _) =
      if p
      then do
        if actualRoomType b imat == Offi
        then do
          let neigh = V.filter (all ((/= Hall) . snd) . neighbs) $
                V.fromList $ catMaybes $ V.toList $
                  (V.map
                    (\n -> findNeighbor n b onlyrooms)
                    nonhalls
                    )
              onlyrooms = V.tail graph
              nonhalls = ns -- filter ((/= Hall) . snd) ns
          if not (null neigh) && any ((Offi /=) . flip actualRoomType imat . bounds) neigh
          then
            return room
          else do
            ret <- doRandomAssign room
            return ret
        else return room
      else do
        if actualRoomType b imat == Offi
        then do
          let neigh =
                V.fromList $ catMaybes $ V.toList $
                  (V.map
                    (\n -> findNeighbor n b onlyrooms)
                    nonhalls
                    )
              onlyrooms = connects (V.head acc)
              nonhalls = ns -- filter ((/= Hall) . snd) ns
          ret <- if null neigh
            then doRandomAssign room
            else doBoundedAssign room (clearance $ V.head neigh)
          return ret
        else
          return room

actualRoomType :: Boundaries Int -> M.Matrix TileState -> TileState
actualRoomType (Boundaries (minrow, mincol) (maxrow, maxcol)) imat =
  let row = minrow + ((maxrow - minrow) `div` 2)
      col = mincol + ((maxcol - mincol) `div` 2)
  in  imat M.! (row, col)

doRandomAssign :: Graph -> IO Graph
doRandomAssign g = do
  c <- randomRIO (0, 4)
  return g
    { clearance = c
    }

doBoundedAssign :: Graph -> Word -> IO Graph
doBoundedAssign g b = do
  c <- randomRIO (b, 4)
  return g
    { clearance = c
    }

findNeighbor
  :: (GraphDirection, TileState)
  -> Boundaries Int
  -> V.Vector Graph
  -> Maybe Graph
findNeighbor (dir, _) bnds ingraph
  | dir == North =
    let row = fst (matmin bnds) - 2
        col = snd (matmin bnds) + ((snd (matmax bnds) - snd (matmin bnds)) `div` 2)
    in  postprocess row col
  | dir == East =
    let row = fst (matmin bnds) + ((fst (matmax bnds) - fst (matmin bnds)) `div` 2)
        col = snd (matmax bnds) + 2
    in  postprocess row col
  | dir == South =
    let row = fst (matmax bnds) + 2
        col = snd (matmin bnds) + ((snd (matmax bnds) - snd (matmin bnds)) `div` 2)
    in  postprocess row col
  | dir == West =
    let row = fst (matmin bnds) + ((fst (matmax bnds) - fst (matmin bnds)) `div` 2)
        col = snd (matmin bnds) - 2
    in  postprocess row col
  where 
    postprocess row col =
      let filtered = V.filter
            (inBounds (V2 row col) . bounds)
            ingraph
      in
        if V.null filtered
        then Nothing
        else if V.length filtered == 1
          then
            case V.head filtered of
              a@(GRoom _ _ _ _) -> Just a
              _                 -> error "findNeighbor: Not a GRoom result"
          else
            error "findNeighbor: Non-Singleton filter result"

buildDoors :: Matrix TileState -> V.Vector Graph -> IO (Matrix TileState)
buildDoors = V.foldM placeDoors

placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState)
placeDoors amat (GHall conns) =
  foldM placeDoors amat conns
placeDoors amat (GRoom neighs bs _ _) =
  if Hall `V.elem` V.map snd neighs
  then do
    let halls = V.filter ((== Hall) . snd) neighs
    idx <- randomRIO (0, length halls - 1)
    let (dir, _) = halls V.! 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))
      West ->
        inCol
          amat
          (fst (matmin bs), fst (matmax bs))
          (snd (matmin bs) - 1)
      East ->
        inCol
          amat
          (fst (matmin bs), fst (matmax bs))
          (snd (matmax bs) + 1)
  else do
    idx <- randomRIO (0, length neighs - 1)
    let (dir, _) = neighs V.! 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))
      West ->
        inCol
          amat
          (fst (matmin bs), fst (matmax bs))
          (snd (matmin bs) - 1)
      East ->
        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 (uncurry (M.submatrix row row) cols mat)
    then return mat
    else
      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 (uncurry M.submatrix rows col col mat)
    then return mat
    else
      return $ M.setElem Door (row, col) mat
  else
    inCol mat rows col