tracer/src/Floorplan.hs

501 lines
16 KiB
Haskell
Raw Normal View History

2018-02-13 23:54:40 +00:00
module Floorplan where
import Data.Matrix (Matrix(..))
import qualified Data.Matrix as M
2018-02-15 18:42:07 +00:00
import qualified Data.Vector as V
2018-02-16 20:19:15 +00:00
import Data.Maybe
import Control.Monad (foldM)
2018-02-13 23:54:40 +00:00
import System.Random
import Debug.Trace
data TileState
= Wall
| Wind
| Door
| Hall
| Offi
| Toil
| Kitc
| Elev
| Unde
deriving (Eq)
instance Show TileState where
show Wall = "#"
show Wind = "~"
show Door = "+"
show Hall = "_"
show Offi = "."
show Toil = "o"
show Kitc = "k"
show Elev = "x"
show Unde = " "
data FloorConfig = FloorConfig
{ elevator :: (Int, Int)
, facilities :: [(Int, Int)]
, size :: (Int, Int)
} deriving (Show)
data Boundaries = Boundaries
{ matmin :: (Int, Int)
, matmax :: (Int, Int)
2018-02-16 21:16:28 +00:00
} deriving (Show, Eq)
2018-02-13 23:54:40 +00:00
buildHallFloorIO :: FloorConfig -> IO (Matrix TileState)
buildHallFloorIO fc = do
rand <- newStdGen
2018-02-15 18:42:07 +00:00
let empty = emptyFloor fc
2018-02-16 20:19:15 +00:00
(g1, withElv) = buildElevator fc (placeHalls rand fc empty)
2018-02-15 18:42:07 +00:00
(g2, withIW) = buildInnerWalls g1 withElv
withOW = buildOuterWalls withIW
closed = closeOffices withOW
2018-02-16 20:19:15 +00:00
doorgraph = buildDoorsGraph closed
traceIO "built graph"
doors <- buildDoors closed doorgraph
traceIO "built doors"
let (g4, facils) = buildFacilities g2 fc doors
return facils
2018-02-13 23:54:40 +00:00
emptyFloor :: FloorConfig -> Matrix TileState
emptyFloor fc =
let (rows, cols) = size fc
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-02-13 23:54:40 +00:00
let (row, col) = elevator fc
boxCoord x = (,) <$> [row - x .. row + x] <*> [col - x .. col + x]
buildShaft = foldl
(\acc coord -> M.setElem (replaceTile (acc M.! coord) Hall) coord acc)
2018-02-15 18:42:07 +00:00
(foldl (\acc coord -> M.setElem Wall coord acc) empty (boxCoord 2))
2018-02-13 23:54:40 +00:00
(boxCoord 5)
elvDoor = M.setElem Door (row + 2, col) buildShaft
in (gen, foldl (\acc coord -> M.setElem Elev coord acc) elvDoor (boxCoord 1))
placeHalls
:: StdGen
-> FloorConfig
-> Matrix TileState
-> (StdGen, Matrix TileState)
placeHalls rng fc input =
doHalls rng
[(Boundaries (1,1) (nrows input, ncols input))]
(elevator fc) 5 input
where
doHalls rand bounds cross wmax mat =
2018-02-15 18:42:07 +00:00
foldl (\(agen, amat) b ->
let (row, g1) = randomR (fst (matmin b), fst (matmax b)) agen
(col, g2) = randomR (snd (matmin b), snd (matmax b)) g1
(nw, g3) = randomR (2, wmax) g2
(nbs, nmat) = buildHall cross nw b amat
in
if hallRatio nmat < 0.175 && wmax - 1 > 2
then doHalls g3 nbs (row, col) (wmax -1) nmat
else (g3, nmat)
) (rand, mat) bounds
2018-02-13 23:54:40 +00:00
boundSize :: Boundaries -> Int
2018-02-15 18:42:07 +00:00
boundSize (Boundaries mi ma) =
(fst ma - fst mi) * (snd ma - snd mi)
2018-02-13 23:54:40 +00:00
buildHall
:: (Int, Int)
-> Int
-> Boundaries
-> Matrix TileState
-> ([Boundaries], Matrix TileState)
buildHall coord@(row, col) width bounds mat =
let vertHalls = foldl (\acc c -> M.mapCol
(\r cur -> if r >= fst (matmin bounds) && r <= fst (matmax bounds)
then replaceTile cur Hall
else cur
) c acc)
mat
[col - (width `div` 2) .. col + (width `div` 2)]
horzHalls = foldl (\acc r -> M.mapRow
(\c cur -> if c >= snd (matmin bounds) && c <= snd (matmax bounds)
then replaceTile cur Hall
else cur
) r acc)
vertHalls
[row - (width `div` 2) .. row + (width `div` 2)]
in ( [ Boundaries (matmin bounds) coord
, Boundaries (fst (matmin bounds), col) (row, snd (matmax bounds))
, Boundaries (row, snd (matmin bounds)) (fst (matmax bounds), col)
, Boundaries coord (matmax bounds)
]
, 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 =
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
2018-02-14 15:45:12 +00:00
(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
2018-02-14 17:32:05 +00:00
(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
)
2018-02-13 23:54:40 +00:00
doCross
:: StdGen
-> (Int, Int)
-> Boundaries
-> Matrix TileState
-> (StdGen, Matrix TileState)
2018-02-15 18:42:07 +00:00
doCross gen cd@(xr, xc) b imat =
let nbs = map (\(mi, ma) -> Boundaries mi ma) bounds
2018-02-13 23:54:40 +00:00
bounds =
2018-02-15 18:42:07 +00:00
[ (matmin b, cd)
2018-02-13 23:54:40 +00:00
, ((fst (matmin b), col), (row, snd (matmax b)))
, ((row, snd (matmin b)), (fst (matmax b), col))
2018-02-15 18:42:07 +00:00
, (cd, matmax b)
2018-02-13 23:54:40 +00:00
]
(ngen, crosses) = foldl
(\(agen, acc) (minb, maxb) ->
2018-02-15 18:42:07 +00:00
let (fc, gg1) = randomR (fst minb, fst maxb) agen
(fr, gg2) = randomR (snd minb, snd maxb) gg1
in (gg2, acc ++ [(fc, fr)])
2018-02-13 23:54:40 +00:00
) (gen, []) bounds
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)]
2018-02-14 17:32:05 +00:00
in if boundSize b >= 16
2018-02-13 23:54:40 +00:00
then foldl
2018-02-15 18:42:07 +00:00
(\(agen, amat) (acr, nb) -> doCross agen acr nb amat)
2018-02-13 23:54:40 +00:00
(ngen, omat)
(zip crosses nbs)
2018-02-14 17:32:05 +00:00
else
2018-02-13 23:54:40 +00:00
(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 any (== Hall) (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
(\amat r -> M.mapRow (\_ _ -> Wall) r amat)
input
[ 1
, nrows input
]
vert =
foldl
(\amat c -> M.mapCol (\_ _ -> Wall) c amat)
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 =
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 (\acc cs -> flood ts acc cs)
altered
[ (cr + 1, cc)
, (cr - 1, cc)
, (cr, cc + 1)
, (cr, cc - 1)
]
nearests = map (findNearestOffice input) (facilities 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]
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
2018-02-16 20:19:15 +00:00
buildDoorsGraph :: Matrix TileState -> [Graph]
buildDoorsGraph mat =
2018-02-15 18:42:07 +00:00
let maxRow r c
| M.safeGet (r + 1) c mat == Just Offi = maxRow (r + 1) c
| otherwise = r
maxCol r c
| M.safeGet r (c + 1) mat == Just Offi = maxCol r (c + 1)
| otherwise = c
minRow r c
| M.safeGet (r + 1) c mat == Just Offi = minRow (r + 1) c
| otherwise = r
minCol r c
| M.safeGet r (c + 1) mat == Just Offi = minCol r (c + 1)
| otherwise = c
matcoord = (,) <$> [2 .. nrows mat - 1] <*> [2 .. ncols mat - 1]
inbounds (qr, qc) fg
| fg == Hall =
Nothing
| otherwise =
Just fg
2018-02-16 20:19:15 +00:00
buildGraph :: Matrix TileState -> [Graph] -> (Int, Int) -> [Graph]
buildGraph amat root coord@(br, bc)
2018-02-15 18:42:07 +00:00
| bc > ncols amat - 1 =
2018-02-16 20:19:15 +00:00
buildGraph amat root (br + 1, 1)
2018-02-15 18:42:07 +00:00
| br > nrows amat - 1 =
2018-02-16 20:19:15 +00:00
root
2018-02-15 18:42:07 +00:00
| M.safeGet br bc amat == Just Offi =
2018-02-16 20:19:15 +00:00
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
2018-02-16 21:16:28 +00:00
let nroot =
if GRoom neighs b `notElem` connects (head root)
then
GHall
{ connects = connects (head root) ++ [GRoom neighs b]
} : tail root
else root
2018-02-16 20:19:15 +00:00
in buildGraph amat nroot (br, 1 + snd (matmax b))
else
let nroot = root ++
2018-02-16 21:16:28 +00:00
if GRoom neighs b `elem` root
then []
else [GRoom neighs b]
2018-02-16 20:19:15 +00:00
in buildGraph amat nroot (br, 1 + snd (matmax b))
2018-02-15 18:42:07 +00:00
| otherwise =
2018-02-16 20:19:15 +00:00
buildGraph amat root (br, maxCol br (bc + 1))
in buildGraph mat [GHall []] (2, 2)
2018-02-15 18:42:07 +00:00
data GraphDirection = North | South | East | West
2018-02-16 21:16:28 +00:00
deriving (Show, Eq)
2018-02-16 20:19:15 +00:00
data Graph
= GHall
{ connects :: [Graph]
}
| GRoom
{ neighbs :: [(GraphDirection, TileState)]
, bounds :: Boundaries
}
2018-02-16 21:16:28 +00:00
deriving (Show, Eq)
2018-02-16 20:19:15 +00:00
buildDoors :: Matrix TileState -> [Graph] -> IO (Matrix TileState)
2018-02-16 21:16:28 +00:00
buildDoors input graph = do
traceIO ("graph: " ++ show (tail graph))
2018-02-16 20:19:15 +00:00
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
2018-02-16 21:16:28 +00:00
traceIO "door in Hall"
2018-02-16 20:19:15 +00:00
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
2018-02-16 21:16:28 +00:00
traceIO "door in Office"
2018-02-16 20:19:15 +00:00
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
2018-02-16 21:16:28 +00:00
traceIO ("placing door: " ++ show (row, col))
2018-02-16 20:19:15 +00:00
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
2018-02-16 21:16:28 +00:00
traceIO ("placing door: " ++ show (row, col))
2018-02-16 20:19:15 +00:00
return $ M.setElem Door (row, col) mat
else
inCol mat rows col