it runs again, but correctness is questionable

src/Floorplan.hs

@@ -1,9 +1,12 @@
 module Floorplan where
 
+import Affection as A
+
 import Data.Matrix (Matrix(..))
 import qualified Data.Matrix as M
 import qualified Data.Text as T
 import Data.Maybe
+import Data.List (intersect)
 
 import Linear (V2(..))
 
@@ -69,12 +72,14 @@ buildHallFloorIO fc progress increment = do
     ( p + increment
     , "Built facilities"
     )))
-  -- accessGraph <- assignClearance doorgraph facils
+  accessGraph <- assignClearance doorgraph facils
   modifyMVar_ progress (return . (\(p, _) ->
     ( p + increment
     , "Assigned room clearances"
     )))
-  return (facils, doorgraph)
+  A.logIO A.Debug ("length accessGraph: " ++ show (length accessGraph))
+  A.logIO A.Debug ("length doorgraph: " ++ show (length doorgraph))
+  return (facils, accessGraph)
 
 emptyFloor :: FloorConfig -> Matrix TileState
 emptyFloor fc =
@@ -415,21 +420,42 @@ buildDoorsGraph mat =
 
 assignClearance :: [Graph] -> M.Matrix TileState -> IO [Graph]
 assignClearance graph imat =
-  mapM doAssignClearance graph
+  foldM doAssignClearance [] graph
   where
-    doAssignClearance (GHall conns) =
+    doAssignClearance acc (GHall conns) = do
-      GHall <$> mapM (reassign True) conns
+      ret <- GHall <$> foldM (\acc a -> do
-    doAssignClearance room =
+        res <- reassign True acc a
-      reassign False room
+        return (acc ++ [res])
-    reassign p room@(GRoom ns b c t) =
+        ) [] conns
+      return (ret : acc)
+    doAssignClearance acc room = do
+      ret <- reassign False acc room
+      return (acc ++ [ret])
+    reassign :: Bool -> [Graph] -> Graph -> IO Graph
+    reassign p acc room@(GRoom ns b c t) =
       if p
       then do
         if actualRoomType b imat == Offi
-        then doRandomAssign room
+        then do
+          ret <- doRandomAssign room
+          return ret
         else return room
       else do
-        let neigh = findNeighbor (head ns) b imat graph
+        if actualRoomType b imat == Offi
-        
+        then do
+          let neigh =
+                catMaybes
+                  (map
+                    (\n -> findNeighbor n b imat onlyrooms)
+                    nonhalls
+                    )
+              onlyrooms = connects (head acc) ++ tail acc
+              nonhalls = ns -- filter ((/= Hall) . snd) ns
+          ret <- if null neigh
+            then doRandomAssign room
+            else doBoundedAssign room (clearance $ head neigh)
+          return ret
+        else return room
 
 actualRoomType :: Boundaries Int -> M.Matrix TileState -> TileState
 actualRoomType (Boundaries (minrow, mincol) (maxrow, maxcol)) imat =
@@ -441,7 +467,7 @@ doRandomAssign :: Graph -> IO Graph
 doRandomAssign g = do
   c <- randomRIO (0, 4)
   return g
-    { clearance = if actualRoomType c
+    { clearance = c
     }
 
 doBoundedAssign :: Graph -> Word -> IO Graph
@@ -454,30 +480,35 @@ doBoundedAssign g b = do
 findNeighbor :: (GraphDirection, TileState) -> Boundaries Int -> M.Matrix TileState -> [Graph] -> Maybe Graph
 findNeighbor (dir, _) bnds imat ingraph
   | dir == North =
-    let row = fst (matmin bnds) - 2
+    let row = fst (matmin bnds) - 1
-        col = snd (matmin bnds) + (snd (matmax bnds) - snd (matmin bnds) `div` 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)
+    let row = fst (matmin bnds) + ((fst (matmax bnds) - fst (matmin bnds)) `div` 2)
-        col = snd (matmin bnds) - 2
+        col = snd (matmax bnds) + 1
     in  postprocess row col
   | dir == South =
-    let row = fst (matmax bnds) + 2
+    let row = fst (matmax bnds) + 1
-        col = snd (matmin bnds) + (snd (matmax bnds) - snd (matmin bnds) `div` 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)
+    let row = fst (matmin bnds) + ((fst (matmax bnds) - fst (matmin bnds)) `div` 2)
-        col = snd (matmax bnds) + 2
+        col = snd (matmin bnds) - 1
     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
+      let filtered = filter
-        [a@(GRoom _ _ _ ts)] -> if ts == neighTile row col
+            (inBounds (V2 row col) . bounds)
-          then Just a
+            ingraph
-          else error "findNeighbor: Query Result dies not match"
+      in
-        []                   -> Nothing
+        case A.log A.Debug ("filtered: " ++ show filtered) filtered of
-        _                    -> error "findNeighbor: Non-singleton filter result"
+          [a@(GRoom _ _ _ ts)] -> Just a
+                                  -- if ts == neighTile row col
+                                  -- then Just a
+                                  -- else error "findNeighbor: Query Result does not match"
+          []                   -> Nothing
+          _                    -> error "findNeighbor: Non-singleton filter result"
 
 buildDoors :: Matrix TileState -> [Graph] -> IO (Matrix TileState)
 buildDoors = foldM placeDoors

src/MainGame/WorldMap.hs

@@ -221,7 +221,7 @@ loadMapFork ud ad future progress = do
       ( p + increment
       , "Registering NPCs into WorldState"
       )))
-    mapM_ (\crp -> do
+    mapM_ (\cpr -> do
       fact <- liftIO $ randomRIO (0.5, 1.5)
       -- fut <- liftIO newEmptyMVar
       stats <- liftIO $ NPCStats
@@ -231,15 +231,21 @@ loadMapFork ud ad future progress = do
         <*> (randomRIO (0, 1))
         <*> (randomRIO (0, 1))
         <*> (randomRIO (0, 1))
+      let room = head
+            (Prelude.filter
+              ((inBounds $ pointCoord cpr) . bounds)
+              (Types.connects (head gr) ++ tail gr)
+              )
       void $ createEntity $ newEntity
-        { pos            = Just (fmap ((+ 0.5) . fromIntegral) (pointCoord crp))
+        { pos            = Just (fmap ((+ 0.5) . fromIntegral) (pointCoord cpr))
         , vel            = Just (V2 0 0)
         , velFact        = Just fact
         , rot            = Just SE
-        , npcMoveState   = Just (NPCWalking [pointCoord crp])
+        , npcMoveState   = Just (NPCWalking [pointCoord cpr])
-        , npcWorkplace   = Just crp
+        , npcWorkplace   = Just cpr
         , npcActionState = Just ASWork
         , npcStats       = Just stats
+        , npcClearanceLvl = Just (clearance room)
         , anim           = Just $ AnimState (AnimId "jdoem" "standing" SE) 0 0
         }
       ) computers

src/Types/Entity.hs

@@ -26,7 +26,7 @@ data Entity f = Entity
   , npcWorkplace       :: Component f 'Field ReachPoint
   , npcActionState     :: Component f 'Field NPCActionState
   , npcStats           :: Component f 'Field NPCStats
-  , npcClearanceLvl    :: Component f 'Field Int
+  , npcClearanceLvl    :: Component f 'Field Word
   , anim               :: Component f 'Field AnimState
   , objAccess          :: Component f 'Field ((V2 Int), Direction)
   , objType            :: Component f 'Field ObjType

src/Types/Map.hs

@@ -58,7 +58,12 @@ data Graph
     , clearance :: Word
     , roomType  :: TileState
     }
-  deriving (Show, Eq)
+  deriving (Show)
+
+instance Eq Graph where
+  (GHall la) == (GHall lb) = la == lb
+  (GRoom na ba _ _) == (GRoom nb bb _ _) = na == nb && ba == bb
+  _ == _ = False
 
 graphIsRoom :: Graph -> Bool
 graphIsRoom (GRoom _ _ _ _) = True