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 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: " ++ show (length accessGraph)) A.logIO A.Debug ("length doorgraph: " ++ 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