From 1c9579428578dc4dc420e089adde6ea0a053b576 Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 29 Mar 2019 12:30:47 +0100 Subject: [PATCH] *insert screechy music* --- src/Floorplan.hs | 446 +++++++++++++++++++++++++---------------------- 1 file changed, 236 insertions(+), 210 deletions(-) diff --git a/src/Floorplan.hs b/src/Floorplan.hs index 9ee62fd..0f4601a 100644 --- a/src/Floorplan.hs +++ b/src/Floorplan.hs @@ -174,58 +174,59 @@ hallRatio 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) - 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) - tups mat = (,) <$> [1 .. nrows mat] <*> [1 .. ncols mat] + 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 @@ -310,26 +311,40 @@ buildFacilities -> 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) + -- 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) + -- ] + 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, flood 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 (flood ts) + altered + [ (cr + 1, cc) + , (cr - 1, cc) + , (cr, cc + 1) + , (cr, cc - 1) + ] + findNearestOffice :: Matrix TileState -> (V2 Int) @@ -347,66 +362,7 @@ findNearestOffice mat (V2 rrr ccc) = buildDoorsGraph :: Matrix TileState -> IO [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) - , (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 `elem` map snd neighs - then - let nroot = - if GRoom neighs b 0 Offi `notElem` connects (head root) - then - GHall - { connects = connects (head root) ++ - [GRoom neighs b 0 Offi] - } : tail root - else root - in buildGraph amat nroot (br, 1 + snd (matmax b)) - else - let nroot = root ++ - if GRoom neighs b 0 Offi `elem` root - then [] - else [GRoom neighs b 0 Offi] - in buildGraph amat nroot (br, 1 + snd (matmax b)) - | otherwise = - buildGraph amat root (br, maxCol br (bc + 1)) - in weedOut $ buildGraph mat [GHall []] (2, 2) + weedOut $ buildGraph mat mat [GHall []] (2, 2) where weedOut (hall@(GHall _):gs) = (hall :) <$> weedOut gs weedOut (g@(GRoom neighs _ _ _):gs) = do @@ -417,6 +373,74 @@ buildDoorsGraph mat = return (g { neighbs = nneigh } : rest) weedOut [] = return [] +buildGraph + :: Matrix TileState + -> Matrix TileState + -> [Graph] + -> (Int, Int) + -> [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 = 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) + , (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 `elem` map snd neighs + then + let nroot = + if GRoom neighs b 0 Offi `notElem` connects (head root) + then + GHall + { connects = connects (head root) ++ + [GRoom neighs b 0 Offi] + } : tail root + else root + in buildGraph amat mat nroot (br, 1 + snd (matmax b)) + else + let nroot = root ++ + if GRoom neighs b 0 Offi `elem` root + then [] + else [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 :: [Graph] -> M.Matrix TileState -> IO [Graph] assignClearance graph imat = foldM doAssignClearance [] graph @@ -527,90 +551,92 @@ findNeighbor (dir, _) bnds ingraph buildDoors :: Matrix TileState -> [Graph] -> IO (Matrix TileState) buildDoors = foldM placeDoors - 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)) - 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 !! 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 + +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)) + 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 !! 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