Merge branch 'npcperform'

src/MainGame/WorldMap.hs

@@ -102,7 +102,7 @@ loadMapFork ud ad future progress = do
   _ <- liftIO $ swapMVar progress (13 / loadSteps, "Placing NPCs")
   logIO A.Debug ("number of reachpoints: " ++ show (length rps))
   let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps
-  npcposs <- placeNPCs inter mat rps 20 -- (length $ filter (\a -> pointType a == Table) nnex)
+  npcposs <- placeNPCs inter mat rps 40 -- (length $ filter (\a -> pointType a == Table) nnex)
   _ <- liftIO $ swapMVar progress (14 / loadSteps, "Preparing MindMap graph")
   A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs)
   !(mmintmat, mmgraph) <- buildFloorMap . springField <$>
@@ -675,13 +675,6 @@ updateMap dt = do
               }
         -- liftIO $ A.logIO A.Debug ("player position: " ++ show (pos' + colldpos))
         return ent
-      updateNPCs
-        (imgMat $ stateData ud)
-        (Prelude.filter
-          (\p -> pointType p /= RoomExit)
-          (reachPoints $ stateData ud)
-          )
-        dt
       tses <- efor allEnts $ do
           with objType
           with objState
@@ -692,8 +685,16 @@ updateMap dt = do
       mapM_ (\(t, s, e) ->
         objectAction dt t s e
         ) tses
+    (nws2, _) <- yieldSystemT nws $ updateNPCs
+      (imgMat $ stateData ud)
+      (Prelude.filter
+        (\p -> pointType p /= RoomExit)
+        (reachPoints $ stateData ud)
+        )
+      dt
+      nws
     putAffection ud
-      { worldState = nws
+      { worldState = nws2
       }
 
 checkBoundsCollision2

src/NPC.hs

@@ -6,9 +6,10 @@ import Affection as A
 
 import qualified Data.Matrix as M
 import Data.Ecstasy as E
-import Data.Maybe (fromMaybe)
+import Data.Maybe
 import Data.List (find)
 
+import Control.Monad.Trans
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Concurrent.MVar
 import Control.Concurrent (forkIO)
@@ -61,18 +62,29 @@ updateNPCs
   :: M.Matrix (Maybe ImgId)
   -> [ReachPoint]
   -> Double
+  -> SystemState Entity (AffectionState (AffectionData UserData) IO)
   -> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
-updateNPCs imgmat rp dt = do
+updateNPCs imgmat rp dt ws = do
   posbounds <- efor allEnts $ do
     with pos
     with obstacle
     pos' <- query pos
     bnds <- query obstacle
     return (pos', bnds)
-  npcs <- efor allEnts $ do
+  npcposs <- efor allEnts $ do
+    with pos
     with npcMoveState
     with vel
+    with rot
+    with anim
+    pos' <- query pos
+    e <- queryEnt
+    return (e, pos')
+  eaccess <- getObjects npcposs
+  moent <- catMaybes <$> (eover allEnts $ do
     with pos
+    with npcMoveState
+    with vel
     with rot
     with anim
     pos' <- query pos
@@ -80,10 +92,6 @@ updateNPCs imgmat rp dt = do
     let mdir =
           (pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp)
     e <- queryEnt
-    return (e, pos', rot', mdir)
-  mapM_ (\(e, pos', rot', mdir) -> do
-    accessibles <- getObjects pos'
-    moent <- eover (anEnt e) $ do
     npcState' <- query npcMoveState
     case npcState' of
       NPCStanding ttl future -> do
@@ -122,23 +130,12 @@ updateNPCs imgmat rp dt = do
         else do
           future <- liftIO $ newEmptyMVar
           stat <- query anim
-            rot' <- query rot
-            pos' <- query pos
           _ <- liftIO $ forkIO $
             getPath (fmap floor pos') future rp imgmat posbounds
+          e <- queryEnt
           let mdir = 
                 (pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp)
-            -- ttl <- liftIO $ randomRIO (5, 30)
+              accessibles = fromMaybe [] $ lookup e eaccess
-            -- return $ (Nothing, unchanged
-            --   { npcMoveState = Set $ NPCStanding ttl future
-            --   , vel      = Set $ V2 0 0
-            --   , rot      = Set $ fromMaybe rot' mdir
-            --   , anim     = Set stat
-            --     { asId = (asId stat)
-            --       { aiDirection = fromMaybe rot' mdir
-            --       }
-            --     }
-            --   })
           case accessibles of
             [] -> do
               ttl <- liftIO $ randomRIO (5, 30)
@@ -157,23 +154,24 @@ updateNPCs imgmat rp dt = do
               rind <- liftIO $ randomRIO (0, length objects - 1)
               npcent <- queryEnt
               let (oent, _, _) = objects !! rind
-                return (Just (oent, npcent), unchanged
+              return (Just (oent, npcent, future), unchanged
                 { rot      = Set $ fromMaybe rot' mdir
                 , anim     = Set stat
                   { asId = (asId stat)
                     { aiDirection = fromMaybe rot' mdir
                     }
                   }
-                  })
+                , vel = Set $ V2 0 0
-    mapM_ (\smoent -> maybe (return()) (\(oent, npcent) -> do
+                }))
-      [(t, s)] <- efor (anEnt oent) $ do
+  mapM_ (\(oent, npcent, future) -> do
+    Just (t, s) <- runQueryT oent $ do
       with objType
       with objState
       otyp <- query objType
       ostat <- query objState
       return (otyp, ostat)
     setEntity oent =<< objectTransition t s False oent
-      [(nt, ns)] <- efor (anEnt oent) $ do
+    Just (nt, ns) <- runQueryT oent $ do
       with objType
       with objState
       otyp <- query objType
@@ -181,17 +179,12 @@ updateNPCs imgmat rp dt = do
       return (otyp, ostat)
     emap (anEnt npcent) $ do
       let ttl = actionTime nt ns
-        future <- liftIO $ newEmptyMVar
-        _ <- liftIO $ forkIO $
-          getPath (fmap floor pos') future rp imgmat posbounds
       return unchanged
         { npcMoveState = Set $ NPCStanding ttl future
-          , vel = Set $ V2 0 0
         }
-      ) smoent) moent
+    ) moent
-    ) npcs
 
-getObjects npos = do
+getObjects npcposs = do
   candidates <- efor allEnts $ do
     with pos
     with objType
@@ -201,9 +194,14 @@ getObjects npos = do
     oacc <- query objAccess
     ent <- queryEnt
     return (ent, pos', oacc)
-  return $ filter (\(_, p, (delta, _)) ->
+  mapM (\(e, pos) ->
-    fmap floor p + delta == fmap floor npos
+    return
+      ( e
+      , filter (\(_, p, (delta, _)) ->
+        fmap floor p + delta == fmap floor pos
         ) candidates
+      )
+    ) npcposs
 
 getPath
   :: V2 Int

src/Object.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE FlexibleInstances #-}
 module Object where
 
-import Affection
+import Affection as A
 
 import Control.Monad (when)
 
@@ -67,4 +67,4 @@ instance ObjectAction ObjType ObjState where
 instance ActionTime ObjType ObjState where
   actionTime ObjCopier "copying" = 5
 
-  actionTime o s = error (show o ++ ": " ++ s ++ ": has not time")
+  actionTime o s = A.log Error (show o ++ ": " ++ s ++ ": has not time") 0