diff --git a/src/Interior.hs b/src/Interior.hs index e2f5056..80ab58b 100644 --- a/src/Interior.hs +++ b/src/Interior.hs @@ -19,6 +19,7 @@ import Util import Types.Interior import Types.Map import Types.UserData +import Types.ReachPoint placeInteriorIO :: Matrix TileState diff --git a/src/NPC.hs b/src/NPC.hs index 842dfb8..d649ef2 100644 --- a/src/NPC.hs +++ b/src/NPC.hs @@ -5,6 +5,8 @@ import Affection as A import qualified Data.Matrix as M import Data.Ecstasy as E +import Control.Monad.IO.Class (MonadIO(..)) + import Linear import System.Random @@ -19,6 +21,7 @@ import Util import Types.UserData import Types.Interior import Types.Map +import Types.ReachPoint drawNPCs :: Context @@ -47,11 +50,12 @@ drawNPCs ctx npcposs prow pcol row col = do placeNPCs :: M.Matrix (Maybe ImgId) + -> M.Matrix TileState -> [ReachPoint] -> [Graph] -> Int -> Affection UserData [V2 Double] -placeNPCs imgmat rp gr count = +placeNPCs imgmat tilemat rp gr count = doPlace 1 [] where doPlace :: Int -> [V2 Double] -> Affection UserData [V2 Double] @@ -61,13 +65,77 @@ placeNPCs imgmat rp gr count = r <- liftIO $ randomRIO (1, M.nrows imgmat) c <- liftIO $ randomRIO (1, M.ncols imgmat) if null (imgObstacle $ imgmat M.! (r, c)) && - isReachable imgmat [V2 r c] (exits r c) + tilemat M.! (r, c) == Hall then doPlace (nr + 1) ((V2 (fromIntegral r) (fromIntegral c)) : acc) - else doPlace nr acc + else do + i <- liftIO $ randomRIO (0, length nonexits - 1) + doPlace + (nr + 1) + ((fmap fromIntegral $ pointCoord (nonexits !! i)) : acc) else return acc applRooms row col = - filter (\r -> graphIsRoom r && inBounds (V2 row col) (bounds r)) gr - exits row col= concatMap (\b -> - filter (\p -> pointType p == RoomExit && inBounds (pointCoord p) b) rp - ) (map bounds (applRooms row col)) + (filter (\r -> graphIsRoom r && inBounds (V2 row col) (bounds r)) gr) + nonexits = + filter + (\p -> + pointType p /= RoomExit + ) + rp + +updateNPCs + :: MonadIO m + => M.Matrix (Maybe ImgId) + -> [ReachPoint] + -> Double + -> SystemT Entity m () +updateNPCs imgmat rp dt = + emap $ do + with npcState + with vel + with pos + npcState' <- E.get npcState + case npcState' of + NPCStanding ttl -> do + let nttl = ttl - dt + if nttl > 0 + then + return $ defEntity' + { npcState = Set $ NPCStanding nttl + , vel = Set $ V2 0 0 + } + else do + pos' <- E.get pos + path <- liftIO $ getPath (fmap floor pos') + return $ defEntity' + { npcState = Set $ NPCWalking path + } + NPCWalking path -> do + pos' <- E.get pos + if not (null path) + then do + let itarget = V2 0.5 0.5 + (fromIntegral <$> head path) :: V2 Double + if distance pos' itarget < 0.1 + then + return $ defEntity' + { npcState = Set $ NPCWalking (tail path) + } + else + return $ defEntity' + { vel = Set $ (* 0.5) <$> signorm (itarget - pos') + } + else do + ttl <- liftIO $ randomRIO (5, 30) + return $ defEntity' + { npcState = Set $ NPCStanding ttl + } + where + getPath pos' = do + let seekRP = filter (\p -> pointType p /= RoomExit) rp + ntargeti <- randomRIO (0, length seekRP - 1) + let ntarget = pointCoord (seekRP !! ntargeti) + path = astarAppl imgmat ntarget pos' + logIO A.Debug ("seeking path from " ++ show pos' ++ " to " ++ show ntarget) + case path of + Nothing -> getPath pos' + Just p -> return p diff --git a/src/Navigation.hs b/src/Navigation.hs index 13b6c38..48ced5c 100644 --- a/src/Navigation.hs +++ b/src/Navigation.hs @@ -4,7 +4,6 @@ import Affection as A import Data.Matrix as M import qualified Data.HashSet as HS -import Data.Graph.AStar import Data.Maybe (isJust) import Linear @@ -14,28 +13,13 @@ import Linear import Types.Map import Types.UserData import Types.Interior +import Types.ReachPoint +import Util isReachable :: Matrix (Maybe ImgId) -> [V2 Int] -> [ReachPoint] -> Bool isReachable imgmat reaches exits = - let astarAppl ex rc = aStar - (naviGraph imgmat) - (\a b -> distance (fmap fromIntegral a) (fmap fromIntegral b)) - (\a -> distance (fmap fromIntegral ex) (fmap fromIntegral a)) - (== ex) - rc - result = + let result = (concatMap - (\exit -> map (astarAppl exit) reaches) + (\exit -> map (astarAppl imgmat exit) reaches) (map pointCoord exits)) in all isJust result - -naviGraph :: Matrix (Maybe ImgId) -> V2 Int -> HS.HashSet (V2 Int) -naviGraph imgmat (V2 r c) = - let list = foldl - (\acc (or, oc) -> if null (imgObstacle $ imgmat M.! (r + or, c + oc)) - then if or == 0 && oc == 0 then acc else V2 (r + or) (c + oc): acc - else acc - ) - [] - [(0, 1), (0, -1), (1, 0), (-1, 0)] - in HS.fromList list diff --git a/src/Test.hs b/src/Test.hs index 7ea5380..e7acbcd 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -17,6 +17,8 @@ import Data.Matrix as M import Data.Ecstasy as E import Data.Maybe +import System.Random (randomRIO) + import Linear import Foreign.C.Types (CFloat(..)) @@ -50,7 +52,8 @@ loadMap = do ((,) <$> [1 .. nrows mat] <*> [1 .. ncols mat]) -- liftIO $ A.logIO A.Debug (show exits) (inter, rps) <- liftIO $ placeInteriorIO mat imgmat exits gr - npcposs <- placeNPCs inter rps gr 10 + let nnex = length (Prelude.filter (\p -> pointType p == RoomExit) rps) + npcposs <- placeNPCs inter mat rps gr nnex (nws, _) <- yieldSystemT (worldState ud) $ do void $ newEntity $ defEntity { pos = Just (V2 20.5 20.5) @@ -58,10 +61,11 @@ loadMap = do , player = Just () } void $ mapM_ (\(V2 nr nc) -> do + ttl <- liftIO $ randomRIO (5, 30) newEntity $ defEntity - { pos = Just (V2 (nr + 0.5) (nc + 0.5)) - , vel = Just (V2 0 0) - , npc = Just () + { pos = Just (V2 (nr + 0.5) (nc + 0.5)) + , vel = Just (V2 0 0) + , npcState = Just (NPCStanding ttl) } ) npcposs uu <- partSubscribe m movePlayer @@ -74,6 +78,7 @@ loadMap = do (\a -> if a == Just ImgEmpty then Nothing else a) (M.toList inter) , initCoords = (0, 500) + , reachPoints = rps } , uuid = [uu] } @@ -118,11 +123,13 @@ drawMap = do (_, playerPos) <- yieldSystemT (worldState ud) $ do efor $ \_ -> do with player + with pos pos' <- E.get pos pure pos' (_, npcposs) <- yieldSystemT (worldState ud) $ do efor $ \_ -> do - with npc + with npcState + with pos pos' <- E.get pos pure pos' let V2 pr pc = head playerPos @@ -196,6 +203,13 @@ updateMap dt = do ) } return ent + updateNPCs + (imgMat $ stateData ud) + (Prelude.filter + (\p -> pointType p /= RoomExit) + (reachPoints $ stateData ud) + ) + dt putAffection ud { worldState = nws } diff --git a/src/Types.hs b/src/Types.hs index f5247d5..6a02934 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -5,3 +5,4 @@ module Types import Types.UserData as T import Types.Map as T import Types.Interior as T +import Types.ReachPoint as T diff --git a/src/Types/Interior.hs b/src/Types/Interior.hs index cb110fc..0647068 100644 --- a/src/Types/Interior.hs +++ b/src/Types/Interior.hs @@ -8,6 +8,7 @@ import Linear.V2 import Types.Map import Types.UserData +import Types.ReachPoint data Cluster = ClusterBox1 @@ -98,14 +99,3 @@ instance Size Cluster where size c = let mat = clusterMat c in fromIntegral ((nrows mat) * (ncols mat)) - -data ReachPoint = ReachPoint - { pointType :: PointType - , pointCoord :: V2 Int - } - deriving (Show) - -data PointType - = RoomExit - | Table - deriving (Eq, Show) diff --git a/src/Types/ReachPoint.hs b/src/Types/ReachPoint.hs new file mode 100644 index 0000000..97024e4 --- /dev/null +++ b/src/Types/ReachPoint.hs @@ -0,0 +1,14 @@ +module Types.ReachPoint where + +import Linear (V2(..)) + +data ReachPoint = ReachPoint + { pointType :: PointType + , pointCoord :: V2 Int + } + deriving (Show) + +data PointType + = RoomExit + | Table + deriving (Eq, Show) diff --git a/src/Types/UserData.hs b/src/Types/UserData.hs index 96f1bf4..263aa9b 100644 --- a/src/Types/UserData.hs +++ b/src/Types/UserData.hs @@ -15,6 +15,7 @@ import Data.Matrix import Data.Ecstasy import Types.Map +import Types.ReachPoint data UserData = UserData { state :: State @@ -34,9 +35,10 @@ data State data StateData = None | MenuData - { mapMat :: Matrix TileState - , initCoords :: (Int, Int) - , imgMat :: Matrix (Maybe ImgId) + { mapMat :: Matrix TileState + , initCoords :: (Int, Int) + , imgMat :: Matrix (Maybe ImgId) + , reachPoints :: [ReachPoint] } data ImgId @@ -148,11 +150,18 @@ data Entity f = Entity , rot :: Component f 'Field Direction , obstacle :: Component f 'Field (Boundaries Double) , player :: Component f 'Unique () - , npc :: Component f 'Field () - , npcPath :: Component f 'Field (Maybe [V2 Int]) + , npcState :: Component f 'Field NPCState } deriving (Generic) +data NPCState + = NPCWalking + { npcWalkPath :: [V2 Int] + } + | NPCStanding + { npcStandTime :: Double + } + data Subsystems = Subsystems { subWindow :: Window , subMouse :: Mouse diff --git a/src/Util.hs b/src/Util.hs index 0f792ff..2cf69c8 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -3,6 +3,8 @@ module Util where import Affection as A import Data.Matrix as M +import qualified Data.HashSet as HS +import Data.Graph.AStar import qualified SDL import qualified Graphics.Rendering.OpenGL as GL hiding (get) @@ -120,3 +122,22 @@ relativizeMouseCoords (V2 ix iy) = do inBounds :: V2 Int -> Boundaries Int -> Bool inBounds (V2 r c) (Boundaries (minr, minc) (maxr, maxc)) = (r >= minr && r <= maxr) && (c >= minc && c <= maxc) + +astarAppl :: Matrix (Maybe ImgId) -> V2 Int -> V2 Int -> Maybe [V2 Int] +astarAppl imgmat target start = aStar + (naviGraph imgmat) + (\a b -> distance (fmap fromIntegral a) (fmap fromIntegral b)) + (\a -> distance (fmap fromIntegral target) (fmap fromIntegral a)) + (== target) + start + +naviGraph :: Matrix (Maybe ImgId) -> V2 Int -> HS.HashSet (V2 Int) +naviGraph imgmat (V2 r c) = + let list = foldl + (\acc (or, oc) -> if null (imgObstacle $ imgmat M.! (r + or, c + oc)) + then if or == 0 && oc == 0 then acc else V2 (r + or) (c + oc): acc + else acc + ) + [] + [(0, 1), (0, -1), (1, 0), (-1, 0)] + in HS.fromList list diff --git a/tracer-game.cabal b/tracer-game.cabal index 585e46b..2e497fc 100644 --- a/tracer-game.cabal +++ b/tracer-game.cabal @@ -21,6 +21,7 @@ executable tracer-game , Types.UserData , Types.Map , Types.Interior + , Types.ReachPoint , StateMachine , Floorplan , Interior