From 713bc1adf2810065a9a7e0ab99f80e04965eea3d Mon Sep 17 00:00:00 2001 From: nek0 Date: Fri, 16 Feb 2018 21:19:15 +0100 Subject: [PATCH] placing doors works now --- src/Floorplan.hs | 256 +++++++++++++++++++++++++++++------------------ 1 file changed, 160 insertions(+), 96 deletions(-) diff --git a/src/Floorplan.hs b/src/Floorplan.hs index 2fadbf2..09b3838 100644 --- a/src/Floorplan.hs +++ b/src/Floorplan.hs @@ -3,7 +3,9 @@ module Floorplan where import Data.Matrix (Matrix(..)) import qualified Data.Matrix as M import qualified Data.Vector as V -import Data.Maybe (isJust) +import Data.Maybe + +import Control.Monad (foldM) import System.Random @@ -46,18 +48,17 @@ data Boundaries = Boundaries buildHallFloorIO :: FloorConfig -> IO (Matrix TileState) buildHallFloorIO fc = do rand <- newStdGen - return $ buildHallFloor fc rand - -buildHallFloor :: FloorConfig -> StdGen -> Matrix TileState -buildHallFloor fc gen = let empty = emptyFloor fc - (g1, withElv) = buildElevator fc (placeHalls gen fc empty) + (g1, withElv) = buildElevator fc (placeHalls rand fc empty) (g2, withIW) = buildInnerWalls g1 withElv withOW = buildOuterWalls withIW closed = closeOffices withOW - (g3, doors) = buildDoors g2 closed - (g4, facils) = buildFacilities g3 fc (trace "doors finished" doors) - in facils + doorgraph = buildDoorsGraph closed + traceIO "built graph" + doors <- buildDoors closed doorgraph + traceIO "built doors" + let (g4, facils) = buildFacilities g2 fc doors + return facils emptyFloor :: FloorConfig -> Matrix TileState emptyFloor fc = @@ -312,8 +313,8 @@ findNearestOffice mat (rrr, ccc) = else acc ) (fst $ head inlist) inlist -buildDoors :: StdGen -> Matrix TileState -> (StdGen, Matrix TileState) -buildDoors rand mat = +buildDoorsGraph :: Matrix TileState -> [Graph] +buildDoorsGraph mat = let maxRow r c | M.safeGet (r + 1) c mat == Just Offi = maxRow (r + 1) c | otherwise = r @@ -332,95 +333,158 @@ buildDoors rand mat = Nothing | otherwise = Just fg - buildGraph amat rnd coord@(br, bc) + buildGraph :: Matrix TileState -> [Graph] -> (Int, Int) -> [Graph] + buildGraph amat root coord@(br, bc) | bc > ncols amat - 1 = - buildGraph amat rnd (br + 1, 1) + buildGraph amat root (br + 1, 1) | br > nrows amat - 1 = - (rnd, amat) + root | M.safeGet br bc amat == Just Offi = - let b = Boundaries (minRow br bc, minCol br bc) (maxRow br bc, maxCol br bc) - neighs = - [ (North, M.safeGet (minRow br bc - 2) bc amat) - , (South, M.safeGet (maxRow br bc + 2) bc amat) - , (East, M.safeGet br (minCol br bc - 2) amat) - , (West, M.safeGet br (maxCol br bc + 2) amat) - ] - (namat, rnd2) = - if Just Hall `elem` map snd neighs - then - let halls = filter ((== Just Hall) . snd) neighs - (rh, r1) = randomR (0, length halls - 1) rnd - (dir, _) = halls !! rh - (dp , r2) - | dir == North = - let (col, rr) = randomR (minCol br bc, maxCol br bc) r1 - doorpos = ((minRow br bc) - 1, col) - in (doorpos, rr) - | dir == South = - let (col, rr) = randomR (minCol br bc, maxCol br bc) r1 - doorpos = ((maxRow br bc) + 1, col) - in (doorpos, rr) - | dir == East = - let (row, rr) = randomR (minRow br bc, maxRow br bc) r1 - doorpos = (row, (minCol br bc) - 1) - in (doorpos, rr) - | dir == West = - let (row, rr) = randomR (minRow br bc, maxRow br bc) r1 - doorpos = (row, (maxCol br bc) + 1) - in (doorpos, rr) - in - if any (== Door) (M.toList $ M.submatrix - ((fst $ matmin b) - 1) - ((fst $ matmax b) + 1) - ((snd $ matmin b) - 1) - ((snd $ matmax b) + 1) - amat) - then (amat, rnd) - else - ( if amat M.! dp == Hall || amat M.! dp == Offi - then amat - else M.setElem Door dp amat - , r2 - ) - else - let others = filter ((== Just Offi) . snd) neighs - (ro, r1) = randomR (0, length others - 1) rnd - (dir, _) = others !! ro - (dp, r2) - | dir == North = - let (col, rr) = randomR (minCol br bc, maxCol br bc) r1 - doorpos = ((minRow br bc) - 1, col) - in (doorpos, rr) - | dir == South = - let (col, rr) = randomR (minCol br bc, maxCol br bc) r1 - doorpos = ((maxRow br bc) + 1, col) - in (doorpos, rr) - | dir == East = - let (row, rr) = randomR (minRow br bc, maxRow br bc) r1 - doorpos = (row, (minCol br bc) - 1) - in (doorpos, rr) - | dir == West = - let (row, rr) = randomR (minRow br bc, maxRow br bc) r1 - doorpos = (row, (maxCol br bc) + 1) - in (doorpos, rr) - in - if any (== Door) (M.toList $ M.submatrix - ((fst $ matmin b) - 1) - ((fst $ matmax b) + 1) - ((snd $ matmin b) - 1) - ((snd $ matmax b) + 1) - amat) - then (amat, rnd) - else - ( if amat M.! dp == Hall || amat M.! dp == Offi - then amat - else M.setElem Door dp amat - , r2 - ) - in buildGraph namat rnd2 (br, bc + 1) + let flood acc fcoord@(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 + b = Boundaries + (minimum (map fst roomcoords), minimum (map snd roomcoords)) + (maximum (map fst roomcoords), maximum (map snd roomcoords)) + neighs = map (\(a, b) -> (a, fromJust b)) (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 = GHall + { connects = connects (head root) ++ [GRoom neighs b] + } : tail root + in buildGraph amat nroot (br, 1 + snd (matmax b)) + else + let nroot = root ++ + [GRoom neighs b] + in buildGraph amat nroot (br, 1 + snd (matmax b)) | otherwise = - buildGraph amat rnd (br, maxCol br (bc + 1)) - in foldl (\(aar, aam) c -> buildGraph aam aar c) (rand, mat) matcoord + buildGraph amat root (br, maxCol br (bc + 1)) + in buildGraph mat [GHall []] (2, 2) data GraphDirection = North | South | East | West deriving (Eq) + +data Graph + = GHall + { connects :: [Graph] + } + | GRoom + { neighbs :: [(GraphDirection, TileState)] + , bounds :: Boundaries + } + +buildDoors :: Matrix TileState -> [Graph] -> IO (Matrix TileState) +buildDoors input graph = + foldM placeDoors input graph + where + placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState) + placeDoors amat (GHall conns) = + foldM placeDoors amat conns + placeDoors amat (GRoom neighs bounds) = + 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 bounds) - 1) + (snd (matmin bounds), snd (matmax bounds)) + South -> + inRow + amat + (fst (matmax bounds) + 1) + (snd (matmin bounds), snd (matmax bounds)) + East -> + inCol + amat + (fst (matmin bounds), fst (matmax bounds)) + (snd (matmin bounds) - 1) + West -> + inCol + amat + (fst (matmin bounds), fst (matmax bounds)) + (snd (matmax bounds) + 1) + else do + idx <- randomRIO (0, length neighs - 1) + let (dir, _) = neighs !! idx + case dir of + North -> + inRow + amat + (fst (matmin bounds) - 1) + (snd (matmin bounds), snd (matmax bounds)) + South -> + inRow + amat + (fst (matmax bounds) + 1) + (snd (matmin bounds), snd (matmax bounds)) + East -> + inCol + amat + (fst (matmin bounds), fst (matmax bounds)) + (snd (matmin bounds) - 1) + West -> + inCol + amat + (fst (matmin bounds), fst (matmax bounds)) + (snd (matmax bounds) + 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 + traceIO "placing door" + 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 + traceIO "placing door" + return $ M.setElem Door (row, col) mat + else + inCol mat rows col