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
|
|
|
|
import Data.Maybe (isJust)
|
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)
|
|
|
|
} deriving (Show)
|
|
|
|
|
|
|
|
buildHallFloorIO :: FloorConfig -> IO (Matrix TileState)
|
|
|
|
buildHallFloorIO fc = do
|
|
|
|
rand <- newStdGen
|
|
|
|
return $ buildHallFloor fc rand
|
|
|
|
|
|
|
|
buildHallFloor :: FloorConfig -> StdGen -> Matrix TileState
|
|
|
|
buildHallFloor fc gen =
|
2018-02-15 18:42:07 +00:00
|
|
|
let empty = emptyFloor fc
|
|
|
|
(g1, withElv) = buildElevator fc (placeHalls gen fc empty)
|
|
|
|
(g2, withIW) = buildInnerWalls g1 withElv
|
|
|
|
withOW = buildOuterWalls withIW
|
|
|
|
closed = closeOffices withOW
|
|
|
|
(g3, doors) = buildDoors g2 closed
|
|
|
|
(g4, facils) = buildFacilities g3 fc (trace "doors finished" doors)
|
|
|
|
in 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
|
|
|
|
|
|
|
buildDoors :: StdGen -> Matrix TileState -> (StdGen, Matrix TileState)
|
|
|
|
buildDoors rand mat =
|
|
|
|
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
|
|
|
|
buildGraph amat rnd coord@(br, bc)
|
|
|
|
| bc > ncols amat - 1 =
|
|
|
|
buildGraph amat rnd (br + 1, 1)
|
|
|
|
| br > nrows amat - 1 =
|
|
|
|
(rnd, amat)
|
|
|
|
| M.safeGet br bc amat == Just Offi =
|
|
|
|
let b = Boundaries (minRow br bc, minCol br bc) (maxRow br bc, maxCol br bc)
|
|
|
|
neighs =
|
|
|
|
[ (North, M.safeGet (minRow br bc - 2) bc amat)
|
|
|
|
, (South, M.safeGet (maxRow br bc + 2) bc amat)
|
|
|
|
, (East, M.safeGet br (minCol br bc - 2) amat)
|
|
|
|
, (West, M.safeGet br (maxCol br bc + 2) amat)
|
|
|
|
]
|
|
|
|
(namat, rnd2) =
|
|
|
|
if Just Hall `elem` map snd neighs
|
|
|
|
then
|
|
|
|
let halls = filter ((== Just Hall) . snd) neighs
|
|
|
|
(rh, r1) = randomR (0, length halls - 1) rnd
|
|
|
|
(dir, _) = halls !! rh
|
|
|
|
(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
|
|
|
|
)
|
|
|
|
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 =
|
|
|
|
buildGraph amat rnd (br, maxCol br (bc + 1))
|
|
|
|
in foldl (\(aar, aam) c -> buildGraph aam aar c) (rand, mat) matcoord
|
|
|
|
|
|
|
|
data GraphDirection = North | South | East | West
|
|
|
|
deriving (Eq)
|