working on acces clearance

This commit is contained in:
nek0 2019-02-07 05:23:44 +01:00
parent 89db07cb0a
commit 33a8e496bb
4 changed files with 99 additions and 15 deletions

View file

@ -12,6 +12,10 @@ import Control.Concurrent.MVar
import System.Random import System.Random
-- internal imports
import Util
import Types.Map import Types.Map
buildHallFloorIO buildHallFloorIO
@ -58,14 +62,19 @@ buildHallFloorIO fc progress increment = do
doors <- buildDoors closed doorgraph doors <- buildDoors closed doorgraph
modifyMVar_ progress (return . (\(p, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Build doors" , "Built doors"
))) )))
let (_, facils) = buildFacilities g2 fc doors let (_, facils) = buildFacilities g2 fc doors
modifyMVar_ progress (return . (\(p, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Build facilities" , "Built facilities"
))) )))
return (facils, doorgraph) accessGraph <- assignClearance doorgraph facils
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Assigned room clearances"
)))
return (facils, accessGraph)
emptyFloor :: FloorConfig -> Matrix TileState emptyFloor :: FloorConfig -> Matrix TileState
emptyFloor fc = emptyFloor fc =
@ -130,7 +139,7 @@ buildHall
-> Boundaries Int -> Boundaries Int
-> Matrix TileState -> Matrix TileState
-> ([Boundaries Int], Matrix TileState) -> ([Boundaries Int], Matrix TileState)
buildHall coord@(V2 row col) width bs mat = buildHall (V2 row col) width bs mat =
let vertHalls = foldl (flip (M.mapCol let vertHalls = foldl (flip (M.mapCol
(\r cur -> if r >= fst (matmin bs) && r <= fst (matmax bs) (\r cur -> if r >= fst (matmin bs) && r <= fst (matmax bs)
then replaceTile cur Hall then replaceTile cur Hall
@ -377,30 +386,103 @@ buildDoorsGraph mat =
if Hall `elem` map snd neighs if Hall `elem` map snd neighs
then then
let nroot = let nroot =
if GRoom neighs b `notElem` connects (head root) if GRoom neighs b 0 Offi `notElem` connects (head root)
then then
GHall GHall
{ connects = connects (head root) ++ [GRoom neighs b] { connects = connects (head root) ++
[GRoom neighs b 0 Offi]
} : tail root } : tail root
else root else root
in buildGraph amat nroot (br, 1 + snd (matmax b)) in buildGraph amat nroot (br, 1 + snd (matmax b))
else else
let nroot = root ++ let nroot = root ++
if GRoom neighs b `elem` root if GRoom neighs b 0 Offi `elem` root
then [] then []
else [GRoom neighs b] else [GRoom neighs b 0 Offi]
in buildGraph amat nroot (br, 1 + snd (matmax b)) in buildGraph amat nroot (br, 1 + snd (matmax b))
| otherwise = | otherwise =
buildGraph amat root (br, maxCol br (bc + 1)) buildGraph amat root (br, maxCol br (bc + 1))
in buildGraph mat [GHall []] (2, 2) in buildGraph mat [GHall []] (2, 2)
assignClearance :: [Graph] -> M.Matrix TileState -> IO [Graph]
assignClearance graph imat =
mapM doAssignClearance graph
where
doAssignClearance (GHall hgs) = do
arooms <- mapM doAssignClearance hgs
return (GHall arooms)
doAssignClearance s@(GRoom _ _ _ _) = error (show s)
doAssignClearance gr@(GRoom neighs bnds _ _)
| all ((/= Offi) . flip actualRoomType imat . bounds) (
filter graphIsRoom (catMaybes $ map (\g -> findNeighbor g bnds imat graph) neighs)) &&
actualRoomType bnds imat == Offi = do
aroom <- doRandomAssign gr
return aroom
| all ((== Offi) . flip actualRoomType imat . bounds) (
filter graphIsRoom (catMaybes $ map (\g -> findNeighbor g bnds imat graph) neighs)) &&
actualRoomType bnds imat == Offi = do
aroom <- doBoundedAssign gr
(minimum $ map
(\n -> fromMaybe 0 (clearance <$> (\g -> findNeighbor g bnds imat graph) n))
neighs
)
return aroom
actualRoomType :: Boundaries Int -> M.Matrix TileState -> TileState
actualRoomType (Boundaries (minrow, mincol) (maxrow, maxcol)) imat =
let row = minrow + ((maxrow - minrow) `div` 2)
col = mincol + ((maxcol - mincol) `div` 2)
in imat M.! (row, col)
doRandomAssign :: Graph -> IO Graph
doRandomAssign g = do
c <- randomRIO (0, 4)
return g
{ clearance = c
}
doBoundedAssign :: Graph -> Word -> IO Graph
doBoundedAssign g b = do
c <- randomRIO (b, 4)
return g
{ clearance = c
}
findNeighbor :: (GraphDirection, TileState) -> Boundaries Int -> M.Matrix TileState -> [Graph] -> Maybe Graph
findNeighbor (dir, _) bnds imat ingraph
| dir == North =
let row = fst (matmin bnds) - 2
col = snd (matmin bnds) + (snd (matmax bnds) - snd (matmin bnds) `div` 2)
in postprocess row col
| dir == East =
let row = fst (matmin bnds) + (fst (matmax bnds) - fst (matmin bnds) `div` 2)
col = snd (matmin bnds) - 2
in postprocess row col
| dir == South =
let row = fst (matmax bnds) + 2
col = snd (matmin bnds) + (snd (matmax bnds) - snd (matmin bnds) `div` 2)
in postprocess row col
| dir == West =
let row = fst (matmin bnds) + (fst (matmax bnds) - fst (matmin bnds) `div` 2)
col = snd (matmax bnds) + 2
in postprocess row col
where
neighTile row col = imat M.! (row, col)
postprocess row col =
case filter (inBounds (V2 row col) . bounds) (filter graphIsRoom ingraph) of
[a@(GRoom _ _ _ ts)] -> if ts == neighTile row col
then Just a
else error "findNeighbor: Query Result dies not match"
[] -> Nothing
_ -> 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 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

View file

@ -41,7 +41,7 @@ traverseGraph
-> (StdGen, (Matrix (Maybe ImgId), [ReachPoint])) -> (StdGen, (Matrix (Maybe ImgId), [ReachPoint]))
traverseGraph imat acc (GHall sub) = traverseGraph imat acc (GHall sub) =
foldl (traverseGraph imat) acc sub foldl (traverseGraph imat) acc sub
traverseGraph imat (rng, putt) (GRoom _ bnds) = traverseGraph imat (rng, putt) (GRoom _ bnds _ clearance) =
let applicable = let applicable =
L.sortBy (\b a -> size (a, (ph, pw), rng) `compare` size (b, (ph, pw), rng)) ( L.sortBy (\b a -> size (a, (ph, pw), rng) `compare` size (b, (ph, pw), rng)) (
L.filter L.filter

View file

@ -101,7 +101,7 @@ loadMapFork
-> MVar (Float, T.Text) -> MVar (Float, T.Text)
-> IO () -> IO ()
loadMapFork ud ad future progress = do loadMapFork ud ad future progress = do
let loadSteps = 21 let loadSteps = 22
increment = 1 / loadSteps increment = 1 / loadSteps
fc = FloorConfig fc = FloorConfig
(V2 10 10) (V2 10 10)
@ -111,7 +111,7 @@ loadMapFork ud ad future progress = do
( p + increment ( p + increment
, "Building floor" , "Building floor"
))) )))
(mat, gr) <- buildHallFloorIO fc progress increment -- 10 increments inside (mat, gr) <- buildHallFloorIO fc progress increment -- 11 increments inside
modifyMVar_ progress (return . (\(p, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Converting to images" , "Converting to images"

View file

@ -53,13 +53,15 @@ data Graph
{ connects :: [Graph] { connects :: [Graph]
} }
| GRoom | GRoom
{ neighbs :: [(GraphDirection, TileState)] { neighbs :: [(GraphDirection, TileState)]
, bounds :: Boundaries Int , bounds :: Boundaries Int
, clearance :: Word
, roomType :: TileState
} }
deriving (Show, Eq) deriving (Show, Eq)
graphIsRoom :: Graph -> Bool graphIsRoom :: Graph -> Bool
graphIsRoom (GRoom _ _) = True graphIsRoom (GRoom _ _ _ _) = True
graphIsRoom _ = False graphIsRoom _ = False
class Size a where class Size a where