nek0/tracer
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Merge pull request #3 from nek0/axe

Browse source 
Axe
This commit is contained in:
rys ostrovid 2019-03-29 15:59:34 +01:00 committed by GitHub
commit 6d051f6c5e
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
1 changed files with 224 additions and 216 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

440
src/Floorplan.hs
View file

@ -122,10 +122,8 @@ placeHalls rng fc input =
(fst (matmin b) + 10, fst (matmax b) - 10) agen (fst (matmin b) + 10, fst (matmax b) - 10) agen
(col, g2) = randomR (col, g2) = randomR
(snd (matmin b) + 10, snd (matmax b) - 10) g1 (snd (matmin b) + 10, snd (matmax b) - 10) g1
-- (nw, g3) = randomR (2, wmax) g2
(nbs, nmat) = buildHall cross 3 b amat (nbs, nmat) = buildHall cross 3 b amat
in in
-- if hallRatio nmat < 0.33 && wmax - 1 >= 2
if wmax - 1 >= 3 && if wmax - 1 >= 3 &&
all (\(Boundaries (minr, minc) (maxr, maxc)) -> all (\(Boundaries (minr, minc) (maxr, maxc)) ->
maxr - minr > 3 && maxc - minc > 3) nbs maxr - minr > 3 && maxc - minc > 3) nbs
@ -174,58 +172,59 @@ hallRatio mat =
buildInnerWalls :: StdGen -> Matrix TileState -> (StdGen, Matrix TileState) buildInnerWalls :: StdGen -> Matrix TileState -> (StdGen, Matrix TileState)
buildInnerWalls rng input = buildInnerWalls rng input =
let floodSearchReplace let tups mat = (,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]
:: 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
( 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
(nngen, nnmat) =
if (cr - 2 > row && cr + 2 < maxRow)
&& (cc - 2 > col && cc + 2 < maxCol)
then
doCross
g2
(cr, cc)
coord
(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
)
in (nngen, nnmat)
| otherwise = (gn, 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)
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
( 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
(nngen, nnmat) =
if (cr - 2 > row && cr + 2 < maxRow)
&& (cc - 2 > col && cc + 2 < maxCol)
then
doCross
g2
(cr, cc)
coord
(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
)
in (nngen, nnmat)
| otherwise = (gn, mat)
doCross doCross
:: RandomGen t :: RandomGen t
=> t => t
@ -310,26 +309,27 @@ buildFacilities
-> Matrix TileState -> Matrix TileState
-> (StdGen, Matrix TileState) -> (StdGen, Matrix TileState)
buildFacilities gen fc input = buildFacilities gen fc input =
let flood ts mat coords@(cr, cc) = let nearests = map (findNearestOffice input) (fcFacilities fc)
let cur = mat M.! coords
altered = M.setElem ts coords mat
in
if cur == ts || cur /= Offi
then mat
else foldl (flood ts)
altered
[ (cr + 1, cc)
, (cr - 1, cc)
, (cr, cc + 1)
, (cr, cc - 1)
]
nearests = map (findNearestOffice input) (fcFacilities fc)
in foldl (\(agen, acc) x -> in foldl (\(agen, acc) x ->
let (numfac, ngen) = randomR (0 :: Int, 1 :: Int) agen let (numfac, ngen) = randomR (0 :: Int, 1 :: Int) agen
facil = if numfac == 1 then Kitc else Toil facil = if numfac == 1 then Kitc else Toil
in (ngen, flood facil acc x) in (ngen, facilFlood facil acc x)
) (gen, input) nearests ) (gen, input) nearests
facilFlood 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 (facilFlood ts)
altered
[ (cr + 1, cc)
, (cr - 1, cc)
, (cr, cc + 1)
, (cr, cc - 1)
]
findNearestOffice findNearestOffice
:: Matrix TileState :: Matrix TileState
-> (V2 Int) -> (V2 Int)
@ -347,66 +347,7 @@ findNearestOffice mat (V2 rrr ccc) =
buildDoorsGraph :: Matrix TileState -> IO [Graph] buildDoorsGraph :: Matrix TileState -> IO [Graph]
buildDoorsGraph mat = buildDoorsGraph mat =
let maxCol r c weedOut $ buildGraph mat mat [GHall []] (2, 2)
| M.safeGet r (c + 1) mat == Just Offi = maxCol r (c + 1)
| otherwise = c
buildGraph :: Matrix TileState -> [Graph] -> (Int, Int) -> [Graph]
buildGraph amat root coord@(br, bc)
| bc > ncols amat - 1 =
buildGraph amat root (br + 1, 1)
| br > nrows amat - 1 =
root
| M.safeGet br bc amat == Just Offi =
let flood acc (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] coord
b = Boundaries
(minimum (map fst roomcoords), minimum (map snd roomcoords))
(maximum (map fst roomcoords), maximum (map snd roomcoords))
neighs = map (\(a, bx) -> (a, fromJust bx)) (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)
, (West, M.safeGet (fst (matmin b)) (snd (matmin b) - 2) amat)
, (East, M.safeGet (fst (matmin b)) (snd (matmax b) + 2) amat)
])
in
if Hall `elem` map snd neighs
then
let nroot =
if GRoom neighs b 0 Offi `notElem` connects (head root)
then
GHall
{ connects = connects (head root) ++
[GRoom neighs b 0 Offi]
} : tail root
else root
in buildGraph amat nroot (br, 1 + snd (matmax b))
else
let nroot = root ++
if GRoom neighs b 0 Offi `elem` root
then []
else [GRoom neighs b 0 Offi]
in buildGraph amat nroot (br, 1 + snd (matmax b))
| otherwise =
buildGraph amat root (br, maxCol br (bc + 1))
in weedOut $ buildGraph mat [GHall []] (2, 2)
where where
weedOut (hall@(GHall _):gs) = (hall :) <$> weedOut gs weedOut (hall@(GHall _):gs) = (hall :) <$> weedOut gs
weedOut (g@(GRoom neighs _ _ _):gs) = do weedOut (g@(GRoom neighs _ _ _):gs) = do
@ -417,6 +358,74 @@ buildDoorsGraph mat =
return (g { neighbs = nneigh } : rest) return (g { neighbs = nneigh } : rest)
weedOut [] = return [] weedOut [] = return []
buildGraph
:: Matrix TileState
-> Matrix TileState
-> [Graph]
-> (Int, Int)
-> [Graph]
buildGraph amat mat root coord@(br, bc)
| bc > ncols amat - 1 =
buildGraph amat mat root (br + 1, 1)
| br > nrows amat - 1 =
root
| M.safeGet br bc amat == Just Offi =
let roomcoords = flood amat [coord] coord
b = Boundaries
(minimum (map fst roomcoords), minimum (map snd roomcoords))
(maximum (map fst roomcoords), maximum (map snd roomcoords))
neighs = map (\(a, bx) -> (a, fromJust bx)) (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)
, (West, M.safeGet (fst (matmin b)) (snd (matmin b) - 2) amat)
, (East, M.safeGet (fst (matmin b)) (snd (matmax b) + 2) amat)
])
in
if Hall `elem` map snd neighs
then
let nroot =
if GRoom neighs b 0 Offi `notElem` connects (head root)
then
GHall
{ connects = connects (head root) ++
[GRoom neighs b 0 Offi]
} : tail root
else root
in buildGraph amat mat nroot (br, 1 + snd (matmax b))
else
let nroot = root ++
if GRoom neighs b 0 Offi `elem` root
then []
else [GRoom neighs b 0 Offi]
in buildGraph amat mat nroot (br, 1 + snd (matmax b))
| otherwise =
buildGraph amat mat root (br, maxCol br (bc + 1))
where
maxCol r c
| M.safeGet r (c + 1) mat == Just Offi = maxCol r (c + 1)
| otherwise = c
flood amat acc (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 amat) (acc ++ ncoords) ncoords
assignClearance :: [Graph] -> M.Matrix TileState -> IO [Graph] assignClearance :: [Graph] -> M.Matrix TileState -> IO [Graph]
assignClearance graph imat = assignClearance graph imat =
foldM doAssignClearance [] graph foldM doAssignClearance [] graph
@ -519,98 +528,97 @@ findNeighbor (dir, _) bnds ingraph
in in
case filtered of case filtered of
[a@(GRoom _ _ _ _)] -> Just a [a@(GRoom _ _ _ _)] -> Just a
-- if ts == neighTile row col
-- then Just a
-- else error "findNeighbor: Query Result does not match"
[] -> Nothing [] -> Nothing
_ -> error "findNeighbor: Non-singleton filter result" _ -> error "findNeighbor: Non-singleton filter result"
buildDoors :: Matrix TileState -> [Graph] -> IO (Matrix TileState) buildDoors :: Matrix TileState -> [Graph] -> IO (Matrix TileState)
buildDoors = foldM placeDoors buildDoors = foldM placeDoors
where
placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState) placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState)
placeDoors amat (GHall conns) = placeDoors amat (GHall conns) =
foldM placeDoors amat conns foldM placeDoors amat conns
placeDoors amat (GRoom neighs bs _ _) = placeDoors amat (GRoom neighs bs _ _) =
if Hall `elem` map snd neighs if Hall `elem` map snd neighs
then do then do
let halls = filter ((== Hall) . snd) neighs let halls = filter ((== Hall) . snd) neighs
idx <- randomRIO (0, length halls - 1) idx <- randomRIO (0, length halls - 1)
let (dir, _) = halls !! idx let (dir, _) = halls !! idx
case dir of case dir of
North -> North ->
inRow inRow
amat amat
(fst (matmin bs) - 1) (fst (matmin bs) - 1)
(snd (matmin bs), snd (matmax bs)) (snd (matmin bs), snd (matmax bs))
South -> South ->
inRow inRow
amat amat
(fst (matmax bs) + 1) (fst (matmax bs) + 1)
(snd (matmin bs), snd (matmax bs)) (snd (matmin bs), snd (matmax bs))
West -> West ->
inCol inCol
amat amat
(fst (matmin bs), fst (matmax bs)) (fst (matmin bs), fst (matmax bs))
(snd (matmin bs) - 1) (snd (matmin bs) - 1)
East -> East ->
inCol inCol
amat amat
(fst (matmin bs), fst (matmax bs)) (fst (matmin bs), fst (matmax bs))
(snd (matmax bs) + 1) (snd (matmax bs) + 1)
else do else do
idx <- randomRIO (0, length neighs - 1) idx <- randomRIO (0, length neighs - 1)
let (dir, _) = neighs !! idx let (dir, _) = neighs !! idx
case dir of case dir of
North -> North ->
inRow inRow
amat amat
(fst (matmin bs) - 1) (fst (matmin bs) - 1)
(snd (matmin bs), snd (matmax bs)) (snd (matmin bs), snd (matmax bs))
South -> South ->
inRow inRow
amat amat
(fst (matmax bs) + 1) (fst (matmax bs) + 1)
(snd (matmin bs), snd (matmax bs)) (snd (matmin bs), snd (matmax bs))
West -> West ->
inCol inCol
amat amat
(fst (matmin bs), fst (matmax bs)) (fst (matmin bs), fst (matmax bs))
(snd (matmin bs) - 1) (snd (matmin bs) - 1)
East -> East ->
inCol inCol
amat amat
(fst (matmin bs), fst (matmax bs)) (fst (matmin bs), fst (matmax bs))
(snd (matmax bs) + 1) (snd (matmax bs) + 1)
inRow :: Matrix TileState -> Int -> (Int, Int) -> IO (Matrix TileState)
inRow mat row cols = do inRow :: Matrix TileState -> Int -> (Int, Int) -> IO (Matrix TileState)
col <- randomRIO cols inRow mat row cols = do
let tile = mat M.! (row, col) col <- randomRIO cols
if tile == Wall let tile = mat M.! (row, col)
&& length (filter if tile == Wall
(== Wall) && length (filter
(M.toList (M.submatrix (row - 1) (row + 1) col col mat))) (== Wall)
== 1 (M.toList (M.submatrix (row - 1) (row + 1) col col mat)))
then == 1
if Door `elem` M.toList (uncurry (M.submatrix row row) cols mat) then
then return mat if Door `elem` M.toList (uncurry (M.submatrix row row) cols mat)
else then return mat
return $ M.setElem Door (row, col) mat else
else return $ M.setElem Door (row, col) mat
inRow mat row cols else
inCol :: Matrix TileState -> (Int, Int) -> Int -> IO (Matrix TileState) inRow mat row cols
inCol mat rows col = do
row <- randomRIO rows inCol :: Matrix TileState -> (Int, Int) -> Int -> IO (Matrix TileState)
let tile = mat M.! (row, col) inCol mat rows col = do
if tile == Wall row <- randomRIO rows
&& length (filter let tile = mat M.! (row, col)
(== Wall) if tile == Wall
(M.toList (M.submatrix row row (col - 1) (col + 1) mat))) && length (filter
== 1 (== Wall)
then (M.toList (M.submatrix row row (col - 1) (col + 1) mat)))
if Door `elem` M.toList (uncurry M.submatrix rows col col mat) == 1
then return mat then
else if Door `elem` M.toList (uncurry M.submatrix rows col col mat)
return $ M.setElem Door (row, col) mat then return mat
else else
inCol mat rows col return $ M.setElem Door (row, col) mat
else
inCol mat rows col