diff --git a/src/Floorplan.hs b/src/Floorplan.hs index c2b66e7..712478d 100644 --- a/src/Floorplan.hs +++ b/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) = - GHall <$> mapM (reassign True) conns - doAssignClearance room = - reassign False room - reassign p room@(GRoom ns b c t) = + doAssignClearance acc (GHall conns) = do + ret <- GHall <$> foldM (\acc a -> do + res <- reassign True acc a + return (acc ++ [res]) + ) [] 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 - col = snd (matmin bnds) + (snd (matmax bnds) - snd (matmin bnds) `div` 2) + let row = fst (matmin bnds) - 1 + 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 + let row = fst (matmin bnds) + ((fst (matmax bnds) - fst (matmin bnds)) `div` 2) + col = snd (matmax bnds) + 1 in postprocess row col | dir == South = - let row = fst (matmax bnds) + 2 - col = snd (matmin bnds) + (snd (matmax bnds) - snd (matmin bnds) `div` 2) + let row = fst (matmax bnds) + 1 + 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 + let row = fst (matmin bnds) + ((fst (matmax bnds) - fst (matmin bnds)) `div` 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 - [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" + let filtered = filter + (inBounds (V2 row col) . bounds) + ingraph + in + case A.log A.Debug ("filtered: " ++ show filtered) filtered of + [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 diff --git a/src/MainGame/WorldMap.hs b/src/MainGame/WorldMap.hs index cce32ff..df72362 100644 --- a/src/MainGame/WorldMap.hs +++ b/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]) - , npcWorkplace = Just crp + , npcMoveState = Just (NPCWalking [pointCoord cpr]) + , npcWorkplace = Just cpr , npcActionState = Just ASWork , npcStats = Just stats + , npcClearanceLvl = Just (clearance room) , anim = Just $ AnimState (AnimId "jdoem" "standing" SE) 0 0 } ) computers diff --git a/src/Types/Entity.hs b/src/Types/Entity.hs index d661578..12c28fb 100644 --- a/src/Types/Entity.hs +++ b/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 diff --git a/src/Types/Map.hs b/src/Types/Map.hs index 4ca81c2..efe0c12 100644 --- a/src/Types/Map.hs +++ b/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