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
-- internal imports
import Util
import Types.Map
buildHallFloorIO
@ -58,14 +62,19 @@ buildHallFloorIO fc progress increment = do
doors <- buildDoors closed doorgraph
modifyMVar_ progress (return . (\(p, _) ->
( p + increment
, "Build doors"
, "Built doors"
)))
let (_, facils) = buildFacilities g2 fc doors
modifyMVar_ progress (return . (\(p, _) ->
( 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 fc =
@ -130,7 +139,7 @@ buildHall
-> 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
(\r cur -> if r >= fst (matmin bs) && r <= fst (matmax bs)
then replaceTile cur Hall
@ -377,30 +386,103 @@ buildDoorsGraph mat =
if Hall `elem` map snd neighs
then
let nroot =
if GRoom neighs b `notElem` connects (head root)
if GRoom neighs b 0 Offi `notElem` connects (head root)
then
GHall
{ connects = connects (head root) ++ [GRoom neighs b]
{ 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 `elem` root
if GRoom neighs b 0 Offi `elem` root
then []
else [GRoom neighs b]
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 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 = foldM placeDoors
where
placeDoors :: Matrix TileState -> Graph -> IO (Matrix TileState)
placeDoors amat (GHall conns) =
foldM placeDoors amat conns
placeDoors amat (GRoom neighs bs) =
placeDoors amat (GRoom neighs bs _ _) =
if Hall `elem` map snd neighs
then do
let halls = filter ((== Hall) . snd) neighs

View file

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

View file

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

View file

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