npc now walk

src/Interior.hs

@@ -19,6 +19,7 @@ import Util
 import Types.Interior
 import Types.Map
 import Types.UserData
+import Types.ReachPoint
 
 placeInteriorIO
   :: Matrix TileState

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

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

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
     }

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

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)

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)

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

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

tracer-game.cabal

@@ -21,6 +21,7 @@ executable tracer-game
                      , Types.UserData
                      , Types.Map
                      , Types.Interior
+                     , Types.ReachPoint
                      , StateMachine
                      , Floorplan
                      , Interior