484 lines
16 KiB
Haskell
484 lines
16 KiB
Haskell
module Floorplan where
|
|
|
|
import Data.Matrix (Matrix(..))
|
|
import qualified Data.Matrix as M
|
|
import qualified Data.Text as T
|
|
import Data.Maybe
|
|
|
|
import Control.Monad (foldM)
|
|
import Control.Concurrent.MVar
|
|
|
|
import System.Random
|
|
|
|
import Types.Map
|
|
|
|
buildHallFloorIO
|
|
:: FloorConfig
|
|
-> MVar (Float, T.Text)
|
|
-> Float
|
|
-> IO (Matrix TileState, [Graph])
|
|
buildHallFloorIO fc progress increment = do
|
|
rand <- newStdGen
|
|
modifyMVar_ progress (return . (\(p, _) ->
|
|
( p + increment
|
|
, "New RNG"
|
|
)))
|
|
let empty = emptyFloor fc
|
|
modifyMVar_ progress (return . (\(p, _) ->
|
|
( p + increment
|
|
, "Built empty floor"
|
|
)))
|
|
let (g1, withElv) = buildElevator fc (placeHalls rand fc empty)
|
|
modifyMVar_ progress (return . (\(p, _) ->
|
|
( p + increment
|
|
, "Placed Elevator"
|
|
)))
|
|
let (g2, withIW) = buildInnerWalls g1 withElv
|
|
modifyMVar_ progress (return . (\(p, _) ->
|
|
( p + increment
|
|
, "Built inner walls"
|
|
)))
|
|
let withOW = buildOuterWalls withIW
|
|
modifyMVar_ progress (return . (\(p, _) ->
|
|
( p + increment
|
|
, "built outer walls"
|
|
)))
|
|
let closed = closeOffices withOW
|
|
modifyMVar_ progress (return . (\(p, _) ->
|
|
( p + increment
|
|
, "Closed offices"
|
|
)))
|
|
let doorgraph = buildDoorsGraph closed
|
|
modifyMVar_ progress (return . (\(p, _) ->
|
|
( p + increment
|
|
, "Doorgraph"
|
|
)))
|
|
doors <- buildDoors closed doorgraph
|
|
modifyMVar_ progress (return . (\(p, _) ->
|
|
( p + increment
|
|
, "Build doors"
|
|
)))
|
|
let (_, facils) = buildFacilities g2 fc doors
|
|
modifyMVar_ progress (return . (\(p, _) ->
|
|
( p + increment
|
|
, "Build facilities"
|
|
)))
|
|
return (facils, doorgraph)
|
|
|
|
emptyFloor :: FloorConfig -> Matrix TileState
|
|
emptyFloor fc =
|
|
let (rows, cols) = fcSize fc
|
|
in M.matrix rows cols (const Unde)
|
|
|
|
buildElevator
|
|
:: FloorConfig
|
|
-> (StdGen, Matrix TileState)
|
|
-> (StdGen, Matrix TileState)
|
|
buildElevator fc (gen, empty) =
|
|
let (row, col) = fcElevator fc
|
|
boxCoord x = (,) <$> [row - x .. row + x] <*> [col - x .. col + x]
|
|
buildShaft = foldl
|
|
(\acc coord -> M.setElem (replaceTile (acc M.! coord) Hall) coord acc)
|
|
(foldl (flip $ M.setElem Wall) empty (boxCoord 2))
|
|
(boxCoord 5)
|
|
elvDoor = M.setElem Door (row + 2, col) buildShaft
|
|
in (gen, foldl ( flip $ M.setElem Elev) elvDoor (boxCoord 1))
|
|
|
|
placeHalls
|
|
:: StdGen
|
|
-> FloorConfig
|
|
-> Matrix TileState
|
|
-> (StdGen, Matrix TileState)
|
|
placeHalls rng fc input =
|
|
doHalls rng
|
|
[Boundaries (1,1) (nrows input, ncols input)]
|
|
(fcElevator fc) 5 input
|
|
where
|
|
doHalls
|
|
:: StdGen
|
|
-> [Boundaries Int]
|
|
-> (Int , Int)
|
|
-> Int
|
|
-> Matrix TileState
|
|
-> (StdGen, Matrix TileState)
|
|
doHalls rand bs cross wmax mat =
|
|
foldl (\(agen, amat) b ->
|
|
let (row, g1) = randomR
|
|
(fst (matmin b) + 10, fst (matmax b) - 10) agen
|
|
(col, g2) = randomR
|
|
(snd (matmin b) + 10, snd (matmax b) - 10) g1
|
|
-- (nw, g3) = randomR (2, wmax) g2
|
|
(nbs, nmat) = buildHall cross 3 b amat
|
|
in
|
|
-- if hallRatio nmat < 0.33 && wmax - 1 >= 2
|
|
if wmax - 1 >= 3 &&
|
|
all (\(Boundaries (minr, minc) (maxr, maxc)) ->
|
|
maxr - minr > 3 && maxc - minc > 3) nbs
|
|
then doHalls g2 nbs (row, col) (wmax -1) nmat
|
|
else (g2, nmat)
|
|
) (rand, mat) bs
|
|
|
|
boundSize :: Boundaries Int -> Int
|
|
boundSize (Boundaries mi ma) =
|
|
(fst ma - fst mi) * (snd ma - snd mi)
|
|
|
|
buildHall
|
|
:: (Int, Int)
|
|
-> Int
|
|
-> Boundaries Int
|
|
-> Matrix TileState
|
|
-> ([Boundaries Int], Matrix TileState)
|
|
buildHall coord@(row, col) width bs mat =
|
|
let vertHalls = foldl (flip (M.mapCol
|
|
(\r cur -> if r >= fst (matmin bs) && r <= fst (matmax bs)
|
|
then replaceTile cur Hall
|
|
else cur
|
|
)))
|
|
mat
|
|
[col - (width `div` 2) .. col + (width `div` 2)]
|
|
horzHalls = foldl (flip ( M.mapRow
|
|
(\c cur -> if c >= snd (matmin bs) && c <= snd (matmax bs)
|
|
then replaceTile cur Hall
|
|
else cur
|
|
)))
|
|
vertHalls
|
|
[row - (width `div` 2) .. row + (width `div` 2)]
|
|
in ( [ Boundaries (matmin bs) coord
|
|
, Boundaries (fst (matmin bs), col) (row, snd (matmax bs))
|
|
, Boundaries (row, snd (matmin bs)) (fst (matmax bs), col)
|
|
, Boundaries coord (matmax bs)
|
|
]
|
|
, horzHalls
|
|
)
|
|
|
|
replaceTile :: TileState -> TileState -> TileState
|
|
replaceTile cur new
|
|
| cur == Unde = new
|
|
| otherwise = cur
|
|
|
|
hallRatio :: Matrix TileState -> Double
|
|
hallRatio mat =
|
|
let hs = foldl (\acc a -> if a == Hall then acc + 1 else acc) 0 mat :: Int
|
|
in fromIntegral hs / fromIntegral (nrows mat * ncols mat)
|
|
|
|
buildInnerWalls :: StdGen -> Matrix TileState -> (StdGen, Matrix TileState)
|
|
buildInnerWalls rng input =
|
|
let 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)
|
|
(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
|
|
)
|
|
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)
|
|
|
|
closeOffices :: Matrix TileState -> Matrix TileState
|
|
closeOffices input =
|
|
let tups mat = (,) <$> [2 .. nrows mat - 1] <*> [2 .. ncols mat - 1]
|
|
isNeighbor (row, col) =
|
|
let subm = M.submatrix (row -1) (row + 1) (col - 1) (col + 1) input
|
|
in Hall `elem` (M.toList subm)
|
|
in foldl (\acc coord ->
|
|
if input M.! coord == Offi && isNeighbor coord
|
|
then M.setElem Wall coord acc
|
|
else acc
|
|
) input (tups input)
|
|
|
|
buildOuterWalls :: Matrix TileState -> Matrix TileState
|
|
buildOuterWalls input =
|
|
let horz :: Matrix TileState
|
|
horz =
|
|
foldl
|
|
(flip $ M.mapRow (\_ _ -> Wall))
|
|
input
|
|
[ 1
|
|
, nrows input
|
|
]
|
|
vert =
|
|
foldl
|
|
(flip $ M.mapCol (\_ _ -> Wall))
|
|
horz
|
|
[ 1
|
|
, ncols horz
|
|
]
|
|
in vert
|
|
|
|
buildFacilities
|
|
:: StdGen
|
|
-> FloorConfig
|
|
-> Matrix TileState
|
|
-> (StdGen, Matrix TileState)
|
|
buildFacilities gen fc input =
|
|
let flood 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)
|
|
]
|
|
nearests = map (findNearestOffice input) (fcFacilities fc)
|
|
in foldl (\(agen, acc) x ->
|
|
let (numfac, ngen) = randomR (0 :: Int, 1 :: Int) agen
|
|
facil = if numfac == 1 then Kitc else Toil
|
|
in (ngen, flood facil acc x)
|
|
) (gen, input) nearests
|
|
|
|
findNearestOffice
|
|
:: Matrix TileState
|
|
-> (Int, Int)
|
|
-> (Int, Int)
|
|
findNearestOffice mat (rrr, ccc) =
|
|
let matcoord = (,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]
|
|
distance :: (Int, Int) -> Int
|
|
distance (ar, ac) = (ar - rrr) ^ (2 :: Int) + (ac - ccc) ^ (2 :: Int)
|
|
inlist = zip matcoord (M.toList mat)
|
|
in foldl (\acc (xc, ts) ->
|
|
if ts == Offi && distance acc > distance xc
|
|
then xc
|
|
else acc
|
|
) (fst $ head inlist) inlist
|
|
|
|
buildDoorsGraph :: Matrix TileState -> [Graph]
|
|
buildDoorsGraph mat =
|
|
let maxCol r c
|
|
| 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)
|
|
, (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 =
|
|
if GRoom neighs b `notElem` connects (head root)
|
|
then
|
|
GHall
|
|
{ connects = connects (head root) ++ [GRoom neighs b]
|
|
} : tail root
|
|
else root
|
|
in buildGraph amat nroot (br, 1 + snd (matmax b))
|
|
else
|
|
let nroot = root ++
|
|
if GRoom neighs b `elem` root
|
|
then []
|
|
else [GRoom neighs b]
|
|
in buildGraph amat nroot (br, 1 + snd (matmax b))
|
|
| otherwise =
|
|
buildGraph amat root (br, maxCol br (bc + 1))
|
|
in buildGraph mat [GHall []] (2, 2)
|
|
|
|
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 bs) =
|
|
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 bs) - 1)
|
|
(snd (matmin bs), snd (matmax bs))
|
|
South ->
|
|
inRow
|
|
amat
|
|
(fst (matmax bs) + 1)
|
|
(snd (matmin bs), snd (matmax bs))
|
|
East ->
|
|
inCol
|
|
amat
|
|
(fst (matmin bs), fst (matmax bs))
|
|
(snd (matmin bs) - 1)
|
|
West ->
|
|
inCol
|
|
amat
|
|
(fst (matmin bs), fst (matmax bs))
|
|
(snd (matmax bs) + 1)
|
|
else do
|
|
idx <- randomRIO (0, length neighs - 1)
|
|
let (dir, _) = neighs !! idx
|
|
case dir of
|
|
North ->
|
|
inRow
|
|
amat
|
|
(fst (matmin bs) - 1)
|
|
(snd (matmin bs), snd (matmax bs))
|
|
South ->
|
|
inRow
|
|
amat
|
|
(fst (matmax bs) + 1)
|
|
(snd (matmin bs), snd (matmax bs))
|
|
East ->
|
|
inCol
|
|
amat
|
|
(fst (matmin bs), fst (matmax bs))
|
|
(snd (matmin bs) - 1)
|
|
West ->
|
|
inCol
|
|
amat
|
|
(fst (matmin bs), fst (matmax bs))
|
|
(snd (matmax bs) + 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 (uncurry (M.submatrix row row) cols mat)
|
|
then return mat
|
|
else
|
|
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 (uncurry M.submatrix rows col col mat)
|
|
then return mat
|
|
else
|
|
return $ M.setElem Door (row, col) mat
|
|
else
|
|
inCol mat rows col
|