lets hack it to pieces

This commit is contained in:
nek0 2019-03-28 21:00:44 +01:00
parent 9cdec48044
commit e206062dfc

View file

@ -6,7 +6,6 @@ import Data.Matrix (Matrix(..))
import qualified Data.Matrix as M import qualified Data.Matrix as M
import qualified Data.Text as T import qualified Data.Text as T
import Data.Maybe import Data.Maybe
import Data.List (intersect)
import Linear (V2(..)) import Linear (V2(..))
@ -134,10 +133,6 @@ placeHalls rng fc input =
else (g2, nmat) else (g2, nmat)
) (rand, mat) bs ) (rand, mat) bs
boundSize :: Boundaries Int -> Int
boundSize (Boundaries mi ma) =
(fst ma - fst mi) * (snd ma - snd mi)
buildHall buildHall
:: (V2 Int) :: (V2 Int)
-> Int -> Int
@ -211,6 +206,7 @@ buildInnerWalls rng input =
doCross doCross
g2 g2
(cr, cc) (cr, cc)
coord
(Boundaries coord (maxRow, maxCol)) (Boundaries coord (maxRow, maxCol))
mat mat
else else
@ -224,56 +220,59 @@ buildInnerWalls rng input =
M.setElem (replaceTile (acc M.! coords) Offi) coords acc M.setElem (replaceTile (acc M.! coords) Offi) coords acc
) mat btups ) 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) in (nngen, nnmat)
| otherwise = (gn, mat) | otherwise = (gn, mat)
tups mat = (,) <$> [1 .. nrows mat] <*> [1 .. ncols mat] tups mat = (,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]
in foldl (\(agen, amat) cds -> floodSearchReplace agen cds amat) in foldl (\(agen, amat) cds -> floodSearchReplace agen cds amat)
(rng, input) (tups input) (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 :: Matrix TileState -> Matrix TileState
closeOffices input = closeOffices input =
let tups mat = (,) <$> [2 .. nrows mat - 1] <*> [2 .. ncols mat - 1] let tups mat = (,) <$> [2 .. nrows mat - 1] <*> [2 .. ncols mat - 1]
@ -423,16 +422,16 @@ assignClearance graph imat =
foldM doAssignClearance [] graph foldM doAssignClearance [] graph
where where
doAssignClearance acc (GHall conns) = do doAssignClearance acc (GHall conns) = do
ret <- GHall <$> foldM (\acc a -> do ret <- GHall <$> foldM (\facc a -> do
res <- reassign True acc a res <- reassign True facc a
return (acc ++ [res]) return (facc ++ [res])
) [] conns ) [] conns
return (ret : acc) return (ret : acc)
doAssignClearance acc room = do doAssignClearance acc room = do
ret <- reassign False acc room ret <- reassign False acc room
return (acc ++ [ret]) return (acc ++ [ret])
reassign :: Bool -> [Graph] -> Graph -> IO Graph reassign :: Bool -> [Graph] -> Graph -> IO Graph
reassign p acc room@(GRoom ns b c t) = reassign p acc room@(GRoom ns b _ _) =
if p if p
then do then do
if actualRoomType b imat == Offi if actualRoomType b imat == Offi
@ -440,7 +439,7 @@ assignClearance graph imat =
let neigh = filter (all ((/= Hall) . snd) . neighbs) $ let neigh = filter (all ((/= Hall) . snd) . neighbs) $
catMaybes catMaybes
(map (map
(\n -> findNeighbor n b imat onlyrooms) (\n -> findNeighbor n b onlyrooms)
nonhalls nonhalls
) )
onlyrooms = tail graph onlyrooms = tail graph
@ -458,7 +457,7 @@ assignClearance graph imat =
let neigh = let neigh =
catMaybes catMaybes
(map (map
(\n -> findNeighbor n b imat onlyrooms) (\n -> findNeighbor n b onlyrooms)
nonhalls nonhalls
) )
onlyrooms = connects (head acc) onlyrooms = connects (head acc)
@ -490,8 +489,12 @@ doBoundedAssign g b = do
{ clearance = c { clearance = c
} }
findNeighbor :: (GraphDirection, TileState) -> Boundaries Int -> M.Matrix TileState -> [Graph] -> Maybe Graph findNeighbor
findNeighbor (dir, _) bnds imat ingraph :: (GraphDirection, TileState)
-> Boundaries Int
-> [Graph]
-> Maybe Graph
findNeighbor (dir, _) bnds ingraph
| dir == North = | dir == North =
let row = fst (matmin bnds) - 2 let row = fst (matmin bnds) - 2
col = snd (matmin bnds) + ((snd (matmax bnds) - snd (matmin bnds)) `div` 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 col = snd (matmin bnds) - 2
in postprocess row col in postprocess row col
where where
neighTile row col = imat M.! (row, col)
postprocess row col = postprocess row col =
let filtered = filter let filtered = filter
(inBounds (V2 row col) . bounds) (inBounds (V2 row col) . bounds)
ingraph ingraph
in in
case filtered of case filtered of
[a@(GRoom _ _ _ ts)] -> Just a [a@(GRoom _ _ _ _)] -> Just a
-- if ts == neighTile row col -- if ts == neighTile row col
-- then Just a -- then Just a
-- else error "findNeighbor: Query Result does not match" -- else error "findNeighbor: Query Result does not match"