251 lines
8 KiB
Haskell
251 lines
8 KiB
Haskell
|
module Floorplan where
|
||
|
|
|
||
|
|
import Data.Matrix (Matrix(..))
|
||
|
|
import qualified Data.Matrix as M
|
||
|
|
import Data.Foldable (find)
|
||
|
|
import Data.Maybe (fromMaybe)
|
||
|
|
|
||
|
|
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)
|
||
|
|
} deriving (Show)
|
||
|
|
|
||
|
|
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)
|
||
|
|
(g2, withIW) = buildInnerWalls g1 withElv
|
||
|
|
withOW = buildOuterWalls withIW
|
||
|
|
closed = closeOffices withOW
|
||
|
|
in closed
|
||
|
|
|
||
|
|
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)
|
||
|
|
buildElevator fc (gen, emptyFloor) =
|
||
|
|
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)
|
||
|
|
(foldl (\acc coord -> M.setElem Wall coord acc) emptyFloor (boxCoord 2))
|
||
|
|
(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
|
||
|
|
elPos = elevator fc
|
||
|
|
doHalls rand bounds cross wmax mat =
|
||
|
|
let (rnd, gen) = next rand
|
||
|
|
in 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.5 && wmax - 1 > 2
|
||
|
|
then doHalls g3 nbs (row, col) (wmax -1) nmat
|
||
|
|
else (g3, nmat)
|
||
|
|
) (rand, mat) bounds
|
||
|
|
|
||
|
|
boundSize :: Boundaries -> Int
|
||
|
|
boundSize (Boundaries min max) =
|
||
|
|
(fst max - fst min) * (snd max - snd min)
|
||
|
|
|
||
|
|
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 =
|
||
|
|
let hs = foldl (\acc a -> if a == Hall then acc + 1 else acc) 0 mat
|
||
|
|
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 (row, maxRow) gn
|
||
|
|
(cc, g2) = randomR (col, maxCol) g1
|
||
|
|
(nngen, nnmat) = doCross
|
||
|
|
g2
|
||
|
|
(cr, cc)
|
||
|
|
(Boundaries coord (maxRow, maxCol))
|
||
|
|
mat
|
||
|
|
doCross
|
||
|
|
:: StdGen
|
||
|
|
-> (Int, Int)
|
||
|
|
-> Boundaries
|
||
|
|
-> Matrix TileState
|
||
|
|
-> (StdGen, Matrix TileState)
|
||
|
|
doCross gen coord@(xr, xc) b imat =
|
||
|
|
let nbs = map (\(min, max) -> Boundaries min max) bounds
|
||
|
|
bounds =
|
||
|
|
[ (matmin b, coord)
|
||
|
|
, ((fst (matmin b), col), (row, snd (matmax b)))
|
||
|
|
, ((row, snd (matmin b)), (fst (matmax b), col))
|
||
|
|
, (coord, matmax b)
|
||
|
|
]
|
||
|
|
(ngen, crosses) = foldl
|
||
|
|
(\(agen, acc) (minb, maxb) ->
|
||
|
|
let (fc, g1) = randomR (fst minb, fst maxb) agen
|
||
|
|
(fr, g2) = randomR (snd minb, snd maxb) g1
|
||
|
|
in (g2, acc ++ [(fc, fr)])
|
||
|
|
) (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)]
|
||
|
|
in if trace ("bs: " ++ show (boundSize b)) (boundSize b) >= 16
|
||
|
|
then foldl
|
||
|
|
(\(agen, amat) (cr, nb) -> doCross agen cr nb amat)
|
||
|
|
(ngen, omat)
|
||
|
|
(zip crosses nbs)
|
||
|
|
else trace
|
||
|
|
("built cross at " ++ show coord ++ " within " ++ show b)
|
||
|
|
(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
|