diff --git a/src/Floorplan.hs b/src/Floorplan.hs index 0d6a22e..9ee62fd 100644 --- a/src/Floorplan.hs +++ b/src/Floorplan.hs @@ -6,7 +6,6 @@ import Data.Matrix (Matrix(..)) import qualified Data.Matrix as M import qualified Data.Text as T import Data.Maybe -import Data.List (intersect) import Linear (V2(..)) @@ -134,10 +133,6 @@ placeHalls rng fc input = else (g2, nmat) ) (rand, mat) bs -boundSize :: Boundaries Int -> Int -boundSize (Boundaries mi ma) = - (fst ma - fst mi) * (snd ma - snd mi) - buildHall :: (V2 Int) -> Int @@ -211,6 +206,7 @@ buildInnerWalls rng input = doCross g2 (cr, cc) + coord (Boundaries coord (maxRow, maxCol)) mat else @@ -224,56 +220,59 @@ buildInnerWalls rng input = 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) +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] @@ -423,16 +422,16 @@ assignClearance graph imat = foldM doAssignClearance [] graph where doAssignClearance acc (GHall conns) = do - ret <- GHall <$> foldM (\acc a -> do - res <- reassign True acc a - return (acc ++ [res]) + ret <- GHall <$> foldM (\facc a -> do + res <- reassign True facc a + return (facc ++ [res]) ) [] conns return (ret : acc) doAssignClearance acc room = do ret <- reassign False acc room return (acc ++ [ret]) reassign :: Bool -> [Graph] -> Graph -> IO Graph - reassign p acc room@(GRoom ns b c t) = + reassign p acc room@(GRoom ns b _ _) = if p then do if actualRoomType b imat == Offi @@ -440,7 +439,7 @@ assignClearance graph imat = let neigh = filter (all ((/= Hall) . snd) . neighbs) $ catMaybes (map - (\n -> findNeighbor n b imat onlyrooms) + (\n -> findNeighbor n b onlyrooms) nonhalls ) onlyrooms = tail graph @@ -458,7 +457,7 @@ assignClearance graph imat = let neigh = catMaybes (map - (\n -> findNeighbor n b imat onlyrooms) + (\n -> findNeighbor n b onlyrooms) nonhalls ) onlyrooms = connects (head acc) @@ -490,8 +489,12 @@ doBoundedAssign g b = do { clearance = c } -findNeighbor :: (GraphDirection, TileState) -> Boundaries Int -> M.Matrix TileState -> [Graph] -> Maybe Graph -findNeighbor (dir, _) bnds imat ingraph +findNeighbor + :: (GraphDirection, TileState) + -> Boundaries Int + -> [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) @@ -509,14 +512,13 @@ findNeighbor (dir, _) bnds imat ingraph col = snd (matmin bnds) - 2 in postprocess row col where - neighTile row col = imat M.! (row, col) postprocess row col = let filtered = filter (inBounds (V2 row col) . bounds) ingraph in case filtered of - [a@(GRoom _ _ _ ts)] -> Just a + [a@(GRoom _ _ _ _)] -> Just a -- if ts == neighTile row col -- then Just a -- else error "findNeighbor: Query Result does not match"