lets hack it to pieces
This commit is contained in:
parent
9cdec48044
commit
e206062dfc
1 changed files with 61 additions and 59 deletions
120
src/Floorplan.hs
120
src/Floorplan.hs
|
|
@ -6,7 +6,6 @@ import Data.Matrix (Matrix(..))
|
|||
import qualified Data.Matrix as M
|
||||
import qualified Data.Text as T
|
||||
import Data.Maybe
|
||||
import Data.List (intersect)
|
||||
|
||||
import Linear (V2(..))
|
||||
|
||||
|
|
@ -134,10 +133,6 @@ placeHalls rng fc input =
|
|||
else (g2, nmat)
|
||||
) (rand, mat) bs
|
||||
|
||||
boundSize :: Boundaries Int -> Int
|
||||
boundSize (Boundaries mi ma) =
|
||||
(fst ma - fst mi) * (snd ma - snd mi)
|
||||
|
||||
buildHall
|
||||
:: (V2 Int)
|
||||
-> Int
|
||||
|
|
@ -211,6 +206,7 @@ buildInnerWalls rng input =
|
|||
doCross
|
||||
g2
|
||||
(cr, cc)
|
||||
coord
|
||||
(Boundaries coord (maxRow, maxCol))
|
||||
mat
|
||||
else
|
||||
|
|
@ -224,56 +220,59 @@ buildInnerWalls rng input =
|
|||
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)
|
||||
|
||||
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)
|
||||
|
||||
closeOffices :: Matrix TileState -> Matrix TileState
|
||||
closeOffices input =
|
||||
let tups mat = (,) <$> [2 .. nrows mat - 1] <*> [2 .. ncols mat - 1]
|
||||
|
|
@ -423,16 +422,16 @@ assignClearance graph imat =
|
|||
foldM doAssignClearance [] graph
|
||||
where
|
||||
doAssignClearance acc (GHall conns) = do
|
||||
ret <- GHall <$> foldM (\acc a -> do
|
||||
res <- reassign True acc a
|
||||
return (acc ++ [res])
|
||||
ret <- GHall <$> foldM (\facc a -> do
|
||||
res <- reassign True facc a
|
||||
return (facc ++ [res])
|
||||
) [] conns
|
||||
return (ret : acc)
|
||||
doAssignClearance acc room = do
|
||||
ret <- reassign False acc room
|
||||
return (acc ++ [ret])
|
||||
reassign :: Bool -> [Graph] -> Graph -> IO Graph
|
||||
reassign p acc room@(GRoom ns b c t) =
|
||||
reassign p acc room@(GRoom ns b _ _) =
|
||||
if p
|
||||
then do
|
||||
if actualRoomType b imat == Offi
|
||||
|
|
@ -440,7 +439,7 @@ assignClearance graph imat =
|
|||
let neigh = filter (all ((/= Hall) . snd) . neighbs) $
|
||||
catMaybes
|
||||
(map
|
||||
(\n -> findNeighbor n b imat onlyrooms)
|
||||
(\n -> findNeighbor n b onlyrooms)
|
||||
nonhalls
|
||||
)
|
||||
onlyrooms = tail graph
|
||||
|
|
@ -458,7 +457,7 @@ assignClearance graph imat =
|
|||
let neigh =
|
||||
catMaybes
|
||||
(map
|
||||
(\n -> findNeighbor n b imat onlyrooms)
|
||||
(\n -> findNeighbor n b onlyrooms)
|
||||
nonhalls
|
||||
)
|
||||
onlyrooms = connects (head acc)
|
||||
|
|
@ -490,8 +489,12 @@ doBoundedAssign g b = do
|
|||
{ clearance = c
|
||||
}
|
||||
|
||||
findNeighbor :: (GraphDirection, TileState) -> Boundaries Int -> M.Matrix TileState -> [Graph] -> Maybe Graph
|
||||
findNeighbor (dir, _) bnds imat ingraph
|
||||
findNeighbor
|
||||
:: (GraphDirection, TileState)
|
||||
-> Boundaries Int
|
||||
-> [Graph]
|
||||
-> Maybe Graph
|
||||
findNeighbor (dir, _) bnds ingraph
|
||||
| dir == North =
|
||||
let row = fst (matmin bnds) - 2
|
||||
col = snd (matmin bnds) + ((snd (matmax bnds) - snd (matmin bnds)) `div` 2)
|
||||
|
|
@ -509,14 +512,13 @@ findNeighbor (dir, _) bnds imat ingraph
|
|||
col = snd (matmin bnds) - 2
|
||||
in postprocess row col
|
||||
where
|
||||
neighTile row col = imat M.! (row, col)
|
||||
postprocess row col =
|
||||
let filtered = filter
|
||||
(inBounds (V2 row col) . bounds)
|
||||
ingraph
|
||||
in
|
||||
case filtered of
|
||||
[a@(GRoom _ _ _ ts)] -> Just a
|
||||
[a@(GRoom _ _ _ _)] -> Just a
|
||||
-- if ts == neighTile row col
|
||||
-- then Just a
|
||||
-- else error "findNeighbor: Query Result does not match"
|
||||
|
|
|
|||
Loading…
Reference in a new issue