placing doors works now

This commit is contained in:
nek0 2018-02-16 21:19:15 +01:00
parent f09bcfd87e
commit 713bc1adf2

View file

@ -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