tracer/src/Floorplan.hs

636 lines
19 KiB
Haskell
Raw Normal View History

2018-02-13 23:54:40 +00:00
module Floorplan where
import Affection as A
2018-02-13 23:54:40 +00:00
import Data.Matrix (Matrix(..))
import qualified Data.Matrix as M
2018-07-19 02:51:07 +00:00
import qualified Data.Text as T
2018-02-16 20:19:15 +00:00
import Data.Maybe
2019-10-20 08:53:53 +00:00
import qualified Data.Vector as V
2018-02-16 20:19:15 +00:00
2018-09-08 12:05:07 +00:00
import Linear (V2(..))
2018-02-16 20:19:15 +00:00
import Control.Monad (foldM)
import Control.Concurrent.MVar
2018-02-13 23:54:40 +00:00
import System.Random
2019-02-07 04:23:44 +00:00
-- internal imports
import Util
import Types.Map
2018-02-13 23:54:40 +00:00
buildHallFloorIO
:: FloorConfig
2018-07-19 02:51:07 +00:00
-> MVar (Float, T.Text)
-> Float
2019-10-20 08:53:53 +00:00
-> IO (Matrix TileState, V.Vector Graph)
buildHallFloorIO fc progress increment = do
2018-02-13 23:54:40 +00:00
rand <- newStdGen
2018-07-19 02:51:07 +00:00
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "New RNG"
)))
2018-02-15 18:42:07 +00:00
let empty = emptyFloor fc
2018-07-19 02:51:07 +00:00
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Built empty floor"
)))
let (g1, withElv) = buildElevator fc (placeHalls rand fc empty)
2018-07-19 02:51:07 +00:00
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Placed Elevator"
)))
let (g2, withIW) = buildInnerWalls g1 withElv
2018-07-19 02:51:07 +00:00
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Built inner walls"
)))
let withOW = buildOuterWalls withIW
2018-07-19 02:51:07 +00:00
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "built outer walls"
)))
let closed = closeOffices withOW
2018-07-19 02:51:07 +00:00
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Closed offices"
)))
2019-02-07 05:15:21 +00:00
doorgraph <- buildDoorsGraph closed
2018-07-19 02:51:07 +00:00
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Doorgraph"
)))
2018-02-16 20:19:15 +00:00
doors <- buildDoors closed doorgraph
2018-07-19 02:51:07 +00:00
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
2019-02-07 04:23:44 +00:00
, "Built doors"
2018-07-19 02:51:07 +00:00
)))
2018-02-18 02:11:41 +00:00
let (_, facils) = buildFacilities g2 fc doors
2018-07-19 02:51:07 +00:00
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
2019-02-07 04:23:44 +00:00
, "Built facilities"
)))
accessGraph <- assignClearance doorgraph facils
2019-02-07 04:23:44 +00:00
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Assigned room clearances"
2018-07-19 02:51:07 +00:00
)))
A.logIO A.Debug ("length accessGraph: " ++ show (length accessGraph))
A.logIO A.Debug ("length doorgraph: " ++ show (length doorgraph))
return (facils, accessGraph)
2018-02-13 23:54:40 +00:00
emptyFloor :: FloorConfig -> Matrix TileState
emptyFloor fc =
2018-03-03 16:03:17 +00:00
let (rows, cols) = fcSize fc
2018-02-13 23:54:40 +00:00
in M.matrix rows cols (const Unde)
buildElevator
:: FloorConfig
-> (StdGen, Matrix TileState)
-> (StdGen, Matrix TileState)
2018-02-15 18:42:07 +00:00
buildElevator fc (gen, empty) =
2018-09-08 12:05:07 +00:00
let (V2 row col) = fcElevator fc
2018-02-13 23:54:40 +00:00
boxCoord x = (,) <$> [row - x .. row + x] <*> [col - x .. col + x]
buildShaft = foldl
(\acc coord -> M.setElem (replaceTile (acc M.! coord) Hall) coord acc)
2019-02-02 20:25:22 +00:00
(foldl (flip $ M.setElem Wall) empty (boxCoord 1))
(boxCoord 3)
elvDoor = M.setElem Door (row + 1, col) buildShaft
in (gen, foldl ( flip $ M.setElem Elev) elvDoor (boxCoord 0))
2018-02-13 23:54:40 +00:00
placeHalls
:: StdGen
-> FloorConfig
-> Matrix TileState
-> (StdGen, Matrix TileState)
placeHalls rng fc input =
doHalls rng
2018-02-28 20:30:59 +00:00
[Boundaries (1,1) (nrows input, ncols input)]
2018-03-03 16:03:17 +00:00
(fcElevator fc) 5 input
2018-02-13 23:54:40 +00:00
where
2018-07-03 14:19:27 +00:00
doHalls
:: StdGen
-> [Boundaries Int]
2018-09-08 12:05:07 +00:00
-> (V2 Int)
2018-07-03 14:19:27 +00:00
-> Int
-> Matrix TileState
-> (StdGen, Matrix TileState)
2018-02-18 02:11:41 +00:00
doHalls rand bs cross wmax mat =
2018-02-15 18:42:07 +00:00
foldl (\(agen, amat) b ->
2018-03-25 18:35:07 +00:00
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
(nbs, nmat) = buildHall cross 3 b amat
2018-02-15 18:42:07 +00:00
in
2018-08-01 15:54:49 +00:00
if wmax - 1 >= 3 &&
all (\(Boundaries (minr, minc) (maxr, maxc)) ->
maxr - minr > 3 && maxc - minc > 3) nbs
2018-09-08 12:05:07 +00:00
then doHalls g2 nbs (V2 row col) (wmax -1) nmat
2018-03-25 18:35:07 +00:00
else (g2, nmat)
2018-02-18 02:11:41 +00:00
) (rand, mat) bs
2018-02-13 23:54:40 +00:00
buildHall
2018-09-08 12:05:07 +00:00
:: (V2 Int)
2018-02-13 23:54:40 +00:00
-> Int
2018-03-03 16:03:17 +00:00
-> Boundaries Int
2018-02-13 23:54:40 +00:00
-> Matrix TileState
2018-03-03 16:03:17 +00:00
-> ([Boundaries Int], Matrix TileState)
2019-02-07 04:23:44 +00:00
buildHall (V2 row col) width bs mat =
2018-02-28 20:30:59 +00:00
let vertHalls = foldl (flip (M.mapCol
2018-02-18 02:11:41 +00:00
(\r cur -> if r >= fst (matmin bs) && r <= fst (matmax bs)
2018-02-13 23:54:40 +00:00
then replaceTile cur Hall
else cur
2018-02-28 20:30:59 +00:00
)))
2018-02-13 23:54:40 +00:00
mat
[col - (width `div` 2) .. col + (width `div` 2)]
2018-02-28 20:30:59 +00:00
horzHalls = foldl (flip ( M.mapRow
2018-02-18 02:11:41 +00:00
(\c cur -> if c >= snd (matmin bs) && c <= snd (matmax bs)
2018-02-13 23:54:40 +00:00
then replaceTile cur Hall
else cur
2018-02-28 20:30:59 +00:00
)))
2018-02-13 23:54:40 +00:00
vertHalls
[row - (width `div` 2) .. row + (width `div` 2)]
2018-09-08 12:05:07 +00:00
in ( [ Boundaries (matmin bs) (row, col)
2018-02-18 02:11:41 +00:00
, Boundaries (fst (matmin bs), col) (row, snd (matmax bs))
, Boundaries (row, snd (matmin bs)) (fst (matmax bs), col)
2018-09-08 12:05:07 +00:00
, Boundaries (row, col) (matmax bs)
2018-02-13 23:54:40 +00:00
]
, horzHalls
)
replaceTile :: TileState -> TileState -> TileState
replaceTile cur new
| cur == Unde = new
| otherwise = cur
hallRatio :: Matrix TileState -> Double
hallRatio mat =
2018-02-15 18:42:07 +00:00
let hs = foldl (\acc a -> if a == Hall then acc + 1 else acc) 0 mat :: Int
2018-02-13 23:54:40 +00:00
in fromIntegral hs / fromIntegral (nrows mat * ncols mat)
buildInnerWalls :: StdGen -> Matrix TileState -> (StdGen, Matrix TileState)
buildInnerWalls rng input =
2019-03-29 11:30:47 +00:00
let tups mat = (,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]
2018-02-13 23:54:40 +00:00
in foldl (\(agen, amat) cds -> floodSearchReplace agen cds amat)
(rng, input) (tups input)
2019-03-29 11:30:47 +00:00
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)
2019-03-28 20:00:44 +00:00
doCross
:: RandomGen t
=> t
-> (Int, Int)
-> (Int, Int)
-> Boundaries Int
-> Matrix TileState
-> (t, Matrix TileState)
doCross gen cd@(xr, xc) coord@(row, col) 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 size b >= 16
then foldl
(\(agen, amat) (acr, nb) -> doCross agen acr coord nb amat)
(ngen, omat)
(zip crosses nbs)
else
(gen, omat)
2018-02-13 23:54:40 +00:00
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
2018-09-02 08:44:33 +00:00
in Hall `elem` M.toList subm
2018-02-13 23:54:40 +00:00
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
2018-02-28 20:30:59 +00:00
(flip $ M.mapRow (\_ _ -> Wall))
2018-02-13 23:54:40 +00:00
input
[ 1
, nrows input
]
vert =
foldl
2018-02-28 20:30:59 +00:00
(flip $ M.mapCol (\_ _ -> Wall))
2018-02-13 23:54:40 +00:00
horz
[ 1
, ncols horz
]
in vert
2018-02-15 02:50:51 +00:00
buildFacilities
:: StdGen
-> FloorConfig
-> Matrix TileState
-> (StdGen, Matrix TileState)
buildFacilities gen fc input =
2019-03-29 11:30:47 +00:00
let nearests = map (findNearestOffice input) (fcFacilities fc)
2018-02-28 20:30:59 +00:00
in foldl (\(agen, acc) x ->
2018-02-15 02:50:51 +00:00
let (numfac, ngen) = randomR (0 :: Int, 1 :: Int) agen
facil = if numfac == 1 then Kitc else Toil
2019-03-29 14:56:34 +00:00
in (ngen, facilFlood facil acc x)
2018-02-28 20:30:59 +00:00
) (gen, input) nearests
2018-02-15 02:50:51 +00:00
2019-03-29 11:30:47 +00:00
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
2019-03-29 14:56:34 +00:00
else foldl (facilFlood ts)
2019-03-29 11:30:47 +00:00
altered
[ (cr + 1, cc)
, (cr - 1, cc)
, (cr, cc + 1)
, (cr, cc - 1)
]
2018-02-15 02:50:51 +00:00
findNearestOffice
:: Matrix TileState
2018-09-08 12:05:07 +00:00
-> (V2 Int)
2018-02-15 02:50:51 +00:00
-> (Int, Int)
2018-09-08 12:05:07 +00:00
findNearestOffice mat (V2 rrr ccc) =
2018-02-15 02:50:51 +00:00
let matcoord = (,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]
2018-02-15 18:42:07 +00:00
distance :: (Int, Int) -> Int
distance (ar, ac) = (ar - rrr) ^ (2 :: Int) + (ac - ccc) ^ (2 :: Int)
2018-02-15 02:50:51 +00:00
inlist = zip matcoord (M.toList mat)
2018-02-15 18:42:07 +00:00
in foldl (\acc (xc, ts) ->
2018-02-15 02:50:51 +00:00
if ts == Offi && distance acc > distance xc
then xc
else acc
) (fst $ head inlist) inlist
2018-02-15 18:42:07 +00:00
2019-10-20 08:53:53 +00:00
buildDoorsGraph :: Matrix TileState -> IO (V.Vector Graph)
2018-02-16 20:19:15 +00:00
buildDoorsGraph mat =
2019-10-20 08:53:53 +00:00
weedOut (buildGraph mat mat (V.singleton (GHall V.empty)) (2, 2))
2019-02-07 05:15:21 +00:00
where
2019-10-20 08:53:53 +00:00
weedOut vect = if V.null vect
then
return V.empty
else
case V.head vect of
hall@(GHall _) ->
(hall `V.cons`) <$> weedOut (V.tail vect)
g@(GRoom neighs _ _ _) -> do
let filtered = V.filter ((== Offi) . snd) neighs
rand <- randomRIO (0, length filtered -1) :: IO Int
let nneigh = filtered V.! rand `V.cons` V.empty
rest <- weedOut (V.tail vect)
return (g { neighbs = nneigh } `V.cons` rest)
2018-02-15 18:42:07 +00:00
2019-03-29 11:30:47 +00:00
buildGraph
:: Matrix TileState
-> Matrix TileState
2019-10-20 08:53:53 +00:00
-> V.Vector Graph
2019-03-29 11:30:47 +00:00
-> (Int, Int)
2019-10-20 08:53:53 +00:00
-> V.Vector Graph
2019-03-29 11:30:47 +00:00
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))
2019-10-20 08:53:53 +00:00
neighs = V.map (\(a, bx) -> (a, fromJust bx)) (V.filter ((/=Nothing) . snd)
$ V.fromList
[ (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)
])
2019-03-29 11:30:47 +00:00
in
2019-10-20 08:53:53 +00:00
if Hall `V.elem` V.map snd neighs
2019-03-29 11:30:47 +00:00
then
let nroot =
2019-10-20 08:53:53 +00:00
if GRoom neighs b 0 Offi `V.notElem` connects (V.head root)
2019-03-29 11:30:47 +00:00
then
GHall
2019-10-20 08:53:53 +00:00
{ connects = connects (V.head root) `V.snoc`
GRoom neighs b 0 Offi
} `V.cons` V.tail root
2019-03-29 11:30:47 +00:00
else root
in buildGraph amat mat nroot (br, 1 + snd (matmax b))
else
2019-10-20 08:53:53 +00:00
let nroot = if GRoom neighs b 0 Offi `V.elem` root
then root
else root `V.snoc` GRoom neighs b 0 Offi
2019-03-29 11:30:47 +00:00
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
2019-10-20 08:53:53 +00:00
assignClearance :: V.Vector Graph -> M.Matrix TileState -> IO (V.Vector Graph)
2019-02-07 04:23:44 +00:00
assignClearance graph imat =
2019-10-20 08:53:53 +00:00
V.foldM doAssignClearance V.empty graph
2019-02-07 04:23:44 +00:00
where
doAssignClearance acc (GHall conns) = do
2019-10-20 08:53:53 +00:00
ret <- GHall <$> V.foldM (\facc a -> do
2019-03-28 20:00:44 +00:00
res <- reassign True facc a
2019-10-20 08:53:53 +00:00
return (facc `V.snoc` res)
) V.empty conns
return (ret `V.cons` acc)
doAssignClearance acc room = do
ret <- reassign False acc room
2019-10-20 08:53:53 +00:00
return (acc `V.snoc` ret)
reassign :: Bool -> V.Vector Graph -> Graph -> IO Graph
2019-03-28 20:00:44 +00:00
reassign p acc room@(GRoom ns b _ _) =
2019-02-07 05:15:21 +00:00
if p
then do
if actualRoomType b imat == Offi
then do
2019-10-20 08:53:53 +00:00
let neigh = V.filter (all ((/= Hall) . snd) . neighbs) $
V.fromList $ catMaybes $ V.toList $
(V.map
2019-03-28 20:00:44 +00:00
(\n -> findNeighbor n b onlyrooms)
2019-02-08 22:10:18 +00:00
nonhalls
)
2019-10-20 08:53:53 +00:00
onlyrooms = V.tail graph
2019-02-08 22:10:18 +00:00
nonhalls = ns -- filter ((/= Hall) . snd) ns
if not (null neigh) && any ((Offi /=) . flip actualRoomType imat . bounds) neigh
then
return room
else do
ret <- doRandomAssign room
return ret
2019-02-07 05:15:21 +00:00
else return room
else do
if actualRoomType b imat == Offi
then do
let neigh =
2019-10-20 08:53:53 +00:00
V.fromList $ catMaybes $ V.toList $
(V.map
2019-03-28 20:00:44 +00:00
(\n -> findNeighbor n b onlyrooms)
nonhalls
)
2019-10-20 08:53:53 +00:00
onlyrooms = connects (V.head acc)
nonhalls = ns -- filter ((/= Hall) . snd) ns
ret <- if null neigh
then doRandomAssign room
2019-10-20 08:53:53 +00:00
else doBoundedAssign room (clearance $ V.head neigh)
return ret
2019-02-08 22:10:18 +00:00
else
return room
2019-02-07 04:23:44 +00:00
actualRoomType :: Boundaries Int -> M.Matrix TileState -> TileState
actualRoomType (Boundaries (minrow, mincol) (maxrow, maxcol)) imat =
let row = minrow + ((maxrow - minrow) `div` 2)
col = mincol + ((maxcol - mincol) `div` 2)
in imat M.! (row, col)
doRandomAssign :: Graph -> IO Graph
doRandomAssign g = do
c <- randomRIO (0, 4)
return g
{ clearance = c
2019-02-07 04:23:44 +00:00
}
doBoundedAssign :: Graph -> Word -> IO Graph
doBoundedAssign g b = do
c <- randomRIO (b, 4)
return g
{ clearance = c
}
2019-03-28 20:00:44 +00:00
findNeighbor
:: (GraphDirection, TileState)
-> Boundaries Int
2019-10-20 08:53:53 +00:00
-> V.Vector Graph
2019-03-28 20:00:44 +00:00
-> Maybe Graph
findNeighbor (dir, _) bnds ingraph
2019-02-07 04:23:44 +00:00
| dir == North =
2019-02-08 21:02:19 +00:00
let row = fst (matmin bnds) - 2
col = snd (matmin bnds) + ((snd (matmax bnds) - snd (matmin bnds)) `div` 2)
2019-02-07 04:23:44 +00:00
in postprocess row col
| dir == East =
let row = fst (matmin bnds) + ((fst (matmax bnds) - fst (matmin bnds)) `div` 2)
2019-02-08 21:02:19 +00:00
col = snd (matmax bnds) + 2
2019-02-07 04:23:44 +00:00
in postprocess row col
| dir == South =
2019-02-08 21:02:19 +00:00
let row = fst (matmax bnds) + 2
col = snd (matmin bnds) + ((snd (matmax bnds) - snd (matmin bnds)) `div` 2)
2019-02-07 04:23:44 +00:00
in postprocess row col
| dir == West =
let row = fst (matmin bnds) + ((fst (matmax bnds) - fst (matmin bnds)) `div` 2)
2019-02-08 21:02:19 +00:00
col = snd (matmin bnds) - 2
2019-02-07 04:23:44 +00:00
in postprocess row col
where
postprocess row col =
2019-10-20 08:53:53 +00:00
let filtered = V.filter
(inBounds (V2 row col) . bounds)
ingraph
in
2019-10-20 08:53:53 +00:00
if V.null filtered
then Nothing
else if V.length filtered == 1
then
case V.head filtered of
a@(GRoom _ _ _ _) -> Just a
_ -> error "findNeighbor: Not a GRoom result"
else
error "findNeighbor: Non-Singleton filter result"
2019-02-07 04:23:44 +00:00
2019-10-20 08:53:53 +00:00
buildDoors :: Matrix TileState -> V.Vector Graph -> IO (Matrix TileState)
buildDoors = V.foldM placeDoors
2019-03-29 11:30:47 +00:00
placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState)
placeDoors amat (GHall conns) =
foldM placeDoors amat conns
placeDoors amat (GRoom neighs bs _ _) =
2019-10-20 08:53:53 +00:00
if Hall `V.elem` V.map snd neighs
2019-03-29 11:30:47 +00:00
then do
2019-10-20 08:53:53 +00:00
let halls = V.filter ((== Hall) . snd) neighs
2019-03-29 11:30:47 +00:00
idx <- randomRIO (0, length halls - 1)
2019-10-20 08:53:53 +00:00
let (dir, _) = halls V.! idx
2019-03-29 11:30:47 +00:00
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))
West ->
inCol
amat
(fst (matmin bs), fst (matmax bs))
(snd (matmin bs) - 1)
East ->
inCol
amat
(fst (matmin bs), fst (matmax bs))
(snd (matmax bs) + 1)
else do
idx <- randomRIO (0, length neighs - 1)
2019-10-20 08:53:53 +00:00
let (dir, _) = neighs V.! idx
2019-03-29 11:30:47 +00:00
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))
West ->
inCol
amat
(fst (matmin bs), fst (matmax bs))
(snd (matmin bs) - 1)
East ->
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