working on acces clearance

src/Floorplan.hs

@@ -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

src/Interior.hs

@@ -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

src/MainGame/WorldMap.hs

@@ -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"

src/Types/Map.hs

@@ -53,13 +53,15 @@ data Graph
     { connects :: [Graph]
     }
   | GRoom
-    { neighbs  :: [(GraphDirection, TileState)]
+    { neighbs   :: [(GraphDirection, TileState)]
-    , bounds   :: Boundaries Int
+    , 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