placing doors works now
This commit is contained in:
nek0
parent
f09bcfd87e
commit
713bc1adf2
1 changed files with 160 additions and 96 deletions
252
src/Floorplan.hs
252
src/Floorplan.hs
|
|
@ -3,7 +3,9 @@ module Floorplan where
|
||||||
import Data.Matrix (Matrix(..))
|
import Data.Matrix (Matrix(..))
|
||||||
import qualified Data.Matrix as M
|
import qualified Data.Matrix as M
|
||||||
import qualified Data.Vector as V
|
import qualified Data.Vector as V
|
||||||
import Data.Maybe (isJust)
|
import Data.Maybe
|
||||||
|
|
||||||
|
import Control.Monad (foldM)
|
||||||
|
|
||||||
import System.Random
|
import System.Random
|
||||||
|
|
||||||
|
|
@ -46,18 +48,17 @@ data Boundaries = Boundaries
|
||||||
buildHallFloorIO :: FloorConfig -> IO (Matrix TileState)
|
buildHallFloorIO :: FloorConfig -> IO (Matrix TileState)
|
||||||
buildHallFloorIO fc = do
|
buildHallFloorIO fc = do
|
||||||
rand <- newStdGen
|
rand <- newStdGen
|
||||||
return $ buildHallFloor fc rand
|
|
||||||
|
|
||||||
buildHallFloor :: FloorConfig -> StdGen -> Matrix TileState
|
|
||||||
buildHallFloor fc gen =
|
|
||||||
let empty = emptyFloor fc
|
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
|
(g2, withIW) = buildInnerWalls g1 withElv
|
||||||
withOW = buildOuterWalls withIW
|
withOW = buildOuterWalls withIW
|
||||||
closed = closeOffices withOW
|
closed = closeOffices withOW
|
||||||
(g3, doors) = buildDoors g2 closed
|
doorgraph = buildDoorsGraph closed
|
||||||
(g4, facils) = buildFacilities g3 fc (trace "doors finished" doors)
|
traceIO "built graph"
|
||||||
in facils
|
doors <- buildDoors closed doorgraph
|
||||||
|
traceIO "built doors"
|
||||||
|
let (g4, facils) = buildFacilities g2 fc doors
|
||||||
|
return facils
|
||||||
|
|
||||||
emptyFloor :: FloorConfig -> Matrix TileState
|
emptyFloor :: FloorConfig -> Matrix TileState
|
||||||
emptyFloor fc =
|
emptyFloor fc =
|
||||||
|
|
@ -312,8 +313,8 @@ findNearestOffice mat (rrr, ccc) =
|
||||||
else acc
|
else acc
|
||||||
) (fst $ head inlist) inlist
|
) (fst $ head inlist) inlist
|
||||||
|
|
||||||
buildDoors :: StdGen -> Matrix TileState -> (StdGen, Matrix TileState)
|
buildDoorsGraph :: Matrix TileState -> [Graph]
|
||||||
buildDoors rand mat =
|
buildDoorsGraph mat =
|
||||||
let maxRow r c
|
let maxRow r c
|
||||||
| M.safeGet (r + 1) c mat == Just Offi = maxRow (r + 1) c
|
| M.safeGet (r + 1) c mat == Just Offi = maxRow (r + 1) c
|
||||||
| otherwise = r
|
| otherwise = r
|
||||||
|
|
@ -332,95 +333,158 @@ buildDoors rand mat =
|
||||||
Nothing
|
Nothing
|
||||||
| otherwise =
|
| otherwise =
|
||||||
Just fg
|
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 =
|
| bc > ncols amat - 1 =
|
||||||
buildGraph amat rnd (br + 1, 1)
|
buildGraph amat root (br + 1, 1)
|
||||||
| br > nrows amat - 1 =
|
| br > nrows amat - 1 =
|
||||||
(rnd, amat)
|
root
|
||||||
| M.safeGet br bc amat == Just Offi =
|
| M.safeGet br bc amat == Just Offi =
|
||||||
let b = Boundaries (minRow br bc, minCol br bc) (maxRow br bc, maxCol br bc)
|
let flood acc fcoord@(fr, fc) =
|
||||||
neighs =
|
let ncoords = [] ++
|
||||||
[ (North, M.safeGet (minRow br bc - 2) bc amat)
|
(if (fr + 1, fc) `notElem` acc &&
|
||||||
, (South, M.safeGet (maxRow br bc + 2) bc amat)
|
M.safeGet (fr + 1) fc amat == Just Offi
|
||||||
, (East, M.safeGet br (minCol br bc - 2) amat)
|
then [(fr + 1, fc)]
|
||||||
, (West, M.safeGet br (maxCol br bc + 2) amat)
|
else []) ++
|
||||||
]
|
(if (fr - 1, fc) `notElem` acc &&
|
||||||
(namat, rnd2) =
|
M.safeGet (fr - 1) fc amat == Just Offi
|
||||||
if Just Hall `elem` map snd neighs
|
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
|
then
|
||||||
let halls = filter ((== Just Hall) . snd) neighs
|
let nroot = GHall
|
||||||
(rh, r1) = randomR (0, length halls - 1) rnd
|
{ connects = connects (head root) ++ [GRoom neighs b]
|
||||||
(dir, _) = halls !! rh
|
} : tail root
|
||||||
(dp , r2)
|
in buildGraph amat nroot (br, 1 + snd (matmax b))
|
||||||
| 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
|
else
|
||||||
( if amat M.! dp == Hall || amat M.! dp == Offi
|
let nroot = root ++
|
||||||
then amat
|
[GRoom neighs b]
|
||||||
else M.setElem Door dp amat
|
in buildGraph amat nroot (br, 1 + snd (matmax b))
|
||||||
, 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)
|
|
||||||
| otherwise =
|
| otherwise =
|
||||||
buildGraph amat rnd (br, maxCol br (bc + 1))
|
buildGraph amat root (br, maxCol br (bc + 1))
|
||||||
in foldl (\(aar, aam) c -> buildGraph aam aar c) (rand, mat) matcoord
|
in buildGraph mat [GHall []] (2, 2)
|
||||||
|
|
||||||
data GraphDirection = North | South | East | West
|
data GraphDirection = North | South | East | West
|
||||||
deriving (Eq)
|
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
|
||||||
|
|
|
||||||
Loading…
Reference in a new issue