*insert screechy music*
This commit is contained in:
parent
e206062dfc
commit
1c95794285
1 changed files with 236 additions and 210 deletions
446
src/Floorplan.hs
446
src/Floorplan.hs
|
|
@ -174,58 +174,59 @@ hallRatio mat =
|
||||||
|
|
||||||
buildInnerWalls :: StdGen -> Matrix TileState -> (StdGen, Matrix TileState)
|
buildInnerWalls :: StdGen -> Matrix TileState -> (StdGen, Matrix TileState)
|
||||||
buildInnerWalls rng input =
|
buildInnerWalls rng input =
|
||||||
let floodSearchReplace
|
let tups mat = (,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]
|
||||||
:: 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]
|
|
||||||
in foldl (\(agen, amat) cds -> floodSearchReplace agen cds amat)
|
in foldl (\(agen, amat) cds -> floodSearchReplace agen cds amat)
|
||||||
(rng, input) (tups input)
|
(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
|
doCross
|
||||||
:: RandomGen t
|
:: RandomGen t
|
||||||
=> t
|
=> t
|
||||||
|
|
@ -310,26 +311,40 @@ buildFacilities
|
||||||
-> Matrix TileState
|
-> Matrix TileState
|
||||||
-> (StdGen, Matrix TileState)
|
-> (StdGen, Matrix TileState)
|
||||||
buildFacilities gen fc input =
|
buildFacilities gen fc input =
|
||||||
let flood ts mat coords@(cr, cc) =
|
-- let flood ts mat coords@(cr, cc) =
|
||||||
let cur = mat M.! coords
|
-- let cur = mat M.! coords
|
||||||
altered = M.setElem ts coords mat
|
-- altered = M.setElem ts coords mat
|
||||||
in
|
-- in
|
||||||
if cur == ts || cur /= Offi
|
-- if cur == ts || cur /= Offi
|
||||||
then mat
|
-- then mat
|
||||||
else foldl (flood ts)
|
-- else foldl (flood ts)
|
||||||
altered
|
-- altered
|
||||||
[ (cr + 1, cc)
|
-- [ (cr + 1, cc)
|
||||||
, (cr - 1, cc)
|
-- , (cr - 1, cc)
|
||||||
, (cr, cc + 1)
|
-- , (cr, cc + 1)
|
||||||
, (cr, cc - 1)
|
-- , (cr, cc - 1)
|
||||||
]
|
-- ]
|
||||||
nearests = map (findNearestOffice input) (fcFacilities fc)
|
let nearests = map (findNearestOffice input) (fcFacilities fc)
|
||||||
in foldl (\(agen, acc) x ->
|
in foldl (\(agen, acc) x ->
|
||||||
let (numfac, ngen) = randomR (0 :: Int, 1 :: Int) agen
|
let (numfac, ngen) = randomR (0 :: Int, 1 :: Int) agen
|
||||||
facil = if numfac == 1 then Kitc else Toil
|
facil = if numfac == 1 then Kitc else Toil
|
||||||
in (ngen, flood facil acc x)
|
in (ngen, flood facil acc x)
|
||||||
) (gen, input) nearests
|
) (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
|
findNearestOffice
|
||||||
:: Matrix TileState
|
:: Matrix TileState
|
||||||
-> (V2 Int)
|
-> (V2 Int)
|
||||||
|
|
@ -347,66 +362,7 @@ findNearestOffice mat (V2 rrr ccc) =
|
||||||
|
|
||||||
buildDoorsGraph :: Matrix TileState -> IO [Graph]
|
buildDoorsGraph :: Matrix TileState -> IO [Graph]
|
||||||
buildDoorsGraph mat =
|
buildDoorsGraph mat =
|
||||||
let maxCol r c
|
weedOut $ buildGraph mat mat [GHall []] (2, 2)
|
||||||
| 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)
|
|
||||||
where
|
where
|
||||||
weedOut (hall@(GHall _):gs) = (hall :) <$> weedOut gs
|
weedOut (hall@(GHall _):gs) = (hall :) <$> weedOut gs
|
||||||
weedOut (g@(GRoom neighs _ _ _):gs) = do
|
weedOut (g@(GRoom neighs _ _ _):gs) = do
|
||||||
|
|
@ -417,6 +373,74 @@ buildDoorsGraph mat =
|
||||||
return (g { neighbs = nneigh } : rest)
|
return (g { neighbs = nneigh } : rest)
|
||||||
weedOut [] = return []
|
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] -> M.Matrix TileState -> IO [Graph]
|
||||||
assignClearance graph imat =
|
assignClearance graph imat =
|
||||||
foldM doAssignClearance [] graph
|
foldM doAssignClearance [] graph
|
||||||
|
|
@ -527,90 +551,92 @@ findNeighbor (dir, _) bnds ingraph
|
||||||
|
|
||||||
buildDoors :: Matrix TileState -> [Graph] -> IO (Matrix TileState)
|
buildDoors :: Matrix TileState -> [Graph] -> IO (Matrix TileState)
|
||||||
buildDoors = foldM placeDoors
|
buildDoors = foldM placeDoors
|
||||||
where
|
|
||||||
placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState)
|
placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState)
|
||||||
placeDoors amat (GHall conns) =
|
placeDoors amat (GHall conns) =
|
||||||
foldM placeDoors amat conns
|
foldM placeDoors amat conns
|
||||||
placeDoors amat (GRoom neighs bs _ _) =
|
placeDoors amat (GRoom neighs bs _ _) =
|
||||||
if Hall `elem` map snd neighs
|
if Hall `elem` map snd neighs
|
||||||
then do
|
then do
|
||||||
let halls = filter ((== Hall) . snd) neighs
|
let halls = filter ((== Hall) . snd) neighs
|
||||||
idx <- randomRIO (0, length halls - 1)
|
idx <- randomRIO (0, length halls - 1)
|
||||||
let (dir, _) = halls !! idx
|
let (dir, _) = halls !! idx
|
||||||
case dir of
|
case dir of
|
||||||
North ->
|
North ->
|
||||||
inRow
|
inRow
|
||||||
amat
|
amat
|
||||||
(fst (matmin bs) - 1)
|
(fst (matmin bs) - 1)
|
||||||
(snd (matmin bs), snd (matmax bs))
|
(snd (matmin bs), snd (matmax bs))
|
||||||
South ->
|
South ->
|
||||||
inRow
|
inRow
|
||||||
amat
|
amat
|
||||||
(fst (matmax bs) + 1)
|
(fst (matmax bs) + 1)
|
||||||
(snd (matmin bs), snd (matmax bs))
|
(snd (matmin bs), snd (matmax bs))
|
||||||
West ->
|
West ->
|
||||||
inCol
|
inCol
|
||||||
amat
|
amat
|
||||||
(fst (matmin bs), fst (matmax bs))
|
(fst (matmin bs), fst (matmax bs))
|
||||||
(snd (matmin bs) - 1)
|
(snd (matmin bs) - 1)
|
||||||
East ->
|
East ->
|
||||||
inCol
|
inCol
|
||||||
amat
|
amat
|
||||||
(fst (matmin bs), fst (matmax bs))
|
(fst (matmin bs), fst (matmax bs))
|
||||||
(snd (matmax bs) + 1)
|
(snd (matmax bs) + 1)
|
||||||
else do
|
else do
|
||||||
idx <- randomRIO (0, length neighs - 1)
|
idx <- randomRIO (0, length neighs - 1)
|
||||||
let (dir, _) = neighs !! idx
|
let (dir, _) = neighs !! idx
|
||||||
case dir of
|
case dir of
|
||||||
North ->
|
North ->
|
||||||
inRow
|
inRow
|
||||||
amat
|
amat
|
||||||
(fst (matmin bs) - 1)
|
(fst (matmin bs) - 1)
|
||||||
(snd (matmin bs), snd (matmax bs))
|
(snd (matmin bs), snd (matmax bs))
|
||||||
South ->
|
South ->
|
||||||
inRow
|
inRow
|
||||||
amat
|
amat
|
||||||
(fst (matmax bs) + 1)
|
(fst (matmax bs) + 1)
|
||||||
(snd (matmin bs), snd (matmax bs))
|
(snd (matmin bs), snd (matmax bs))
|
||||||
West ->
|
West ->
|
||||||
inCol
|
inCol
|
||||||
amat
|
amat
|
||||||
(fst (matmin bs), fst (matmax bs))
|
(fst (matmin bs), fst (matmax bs))
|
||||||
(snd (matmin bs) - 1)
|
(snd (matmin bs) - 1)
|
||||||
East ->
|
East ->
|
||||||
inCol
|
inCol
|
||||||
amat
|
amat
|
||||||
(fst (matmin bs), fst (matmax bs))
|
(fst (matmin bs), fst (matmax bs))
|
||||||
(snd (matmax bs) + 1)
|
(snd (matmax bs) + 1)
|
||||||
inRow :: Matrix TileState -> Int -> (Int, Int) -> IO (Matrix TileState)
|
|
||||||
inRow mat row cols = do
|
inRow :: Matrix TileState -> Int -> (Int, Int) -> IO (Matrix TileState)
|
||||||
col <- randomRIO cols
|
inRow mat row cols = do
|
||||||
let tile = mat M.! (row, col)
|
col <- randomRIO cols
|
||||||
if tile == Wall
|
let tile = mat M.! (row, col)
|
||||||
&& length (filter
|
if tile == Wall
|
||||||
(== Wall)
|
&& length (filter
|
||||||
(M.toList (M.submatrix (row - 1) (row + 1) col col mat)))
|
(== Wall)
|
||||||
== 1
|
(M.toList (M.submatrix (row - 1) (row + 1) col col mat)))
|
||||||
then
|
== 1
|
||||||
if Door `elem` M.toList (uncurry (M.submatrix row row) cols mat)
|
then
|
||||||
then return mat
|
if Door `elem` M.toList (uncurry (M.submatrix row row) cols mat)
|
||||||
else
|
then return mat
|
||||||
return $ M.setElem Door (row, col) mat
|
else
|
||||||
else
|
return $ M.setElem Door (row, col) mat
|
||||||
inRow mat row cols
|
else
|
||||||
inCol :: Matrix TileState -> (Int, Int) -> Int -> IO (Matrix TileState)
|
inRow mat row cols
|
||||||
inCol mat rows col = do
|
|
||||||
row <- randomRIO rows
|
inCol :: Matrix TileState -> (Int, Int) -> Int -> IO (Matrix TileState)
|
||||||
let tile = mat M.! (row, col)
|
inCol mat rows col = do
|
||||||
if tile == Wall
|
row <- randomRIO rows
|
||||||
&& length (filter
|
let tile = mat M.! (row, col)
|
||||||
(== Wall)
|
if tile == Wall
|
||||||
(M.toList (M.submatrix row row (col - 1) (col + 1) mat)))
|
&& length (filter
|
||||||
== 1
|
(== Wall)
|
||||||
then
|
(M.toList (M.submatrix row row (col - 1) (col + 1) mat)))
|
||||||
if Door `elem` M.toList (uncurry M.submatrix rows col col mat)
|
== 1
|
||||||
then return mat
|
then
|
||||||
else
|
if Door `elem` M.toList (uncurry M.submatrix rows col col mat)
|
||||||
return $ M.setElem Door (row, col) mat
|
then return mat
|
||||||
else
|
else
|
||||||
inCol mat rows col
|
return $ M.setElem Door (row, col) mat
|
||||||
|
else
|
||||||
|
inCol mat rows col
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue