From b59b56690527e6eaa855bf4f87167a1c69871c54 Mon Sep 17 00:00:00 2001
From: nek0 <nek0@chelnok.de>
Date: Wed, 16 May 2018 16:23:23 +0200
Subject: [PATCH] fork pathseeking off into seperate thread

---
 src/NPC.hs            | 52 ++++++++++++++++++++++++++++---------------
 src/Test.hs           | 14 +++++++-----
 src/Types/UserData.hs |  5 ++++-
 3 files changed, 47 insertions(+), 24 deletions(-)

diff --git a/src/NPC.hs b/src/NPC.hs
index 5fd63f0..b603bbd 100644
--- a/src/NPC.hs
+++ b/src/NPC.hs
@@ -6,6 +6,8 @@ import qualified Data.Matrix as M
 import Data.Ecstasy as E
 
 import Control.Monad.IO.Class (MonadIO(..))
+import Control.Concurrent.MVar
+import Control.Concurrent (forkIO)
 
 import Linear
 
@@ -115,20 +117,25 @@ updateNPCs imgmat rp dt =
     with pos
     npcState' <- E.get npcState
     case npcState' of
-      NPCStanding ttl -> do
+      NPCStanding ttl future -> do
         let nttl = ttl - dt
         if nttl > 0
         then
           return $ defEntity'
-            { npcState = Set $ NPCStanding nttl
+            { npcState = Set $ NPCStanding nttl future
             , vel      = Set $ V2 0 0
             }
         else do
-          pos' <- E.get pos
-          path <- liftIO $ getPath (fmap floor pos')
-          return $ defEntity'
-            { npcState = Set $ NPCWalking path
-            }
+          mpath <- liftIO $ tryTakeMVar future
+          case mpath of
+            Just path ->
+              return $ defEntity'
+                { npcState = Set $ NPCWalking path
+                }
+            Nothing ->
+              return $ defEntity'
+                { npcState = Set $ NPCStanding 1 future
+                }
       NPCWalking path -> do
         pos' <- E.get pos
         if not (null path)
@@ -145,16 +152,25 @@ updateNPCs imgmat rp dt =
               }
         else do
           ttl <- liftIO $ randomRIO (5, 30)
+          future <- liftIO $ newEmptyMVar
+          _ <- liftIO $ forkIO $ getPath (fmap floor pos') future rp imgmat
           return $ defEntity'
-            { npcState = Set $ NPCStanding ttl
+            { npcState = Set $ NPCStanding ttl future
             }
-  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.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show ntarget)
-      case path of
-        Nothing -> getPath pos'
-        Just p  -> return p
+
+
+getPath
+  :: V2 Int
+  -> MVar [V2 Int]
+  -> [ReachPoint]
+  -> M.Matrix (Maybe ImgId)
+  -> IO ()
+getPath pos' mvar rp imgmat = 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.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show ntarget)
+  case path of
+    Nothing -> getPath pos' mvar rp imgmat
+    Just p  -> putMVar mvar p
diff --git a/src/Test.hs b/src/Test.hs
index 48cd435..a2d888d 100644
--- a/src/Test.hs
+++ b/src/Test.hs
@@ -9,6 +9,8 @@ import NanoVG hiding (V2(..))
 
 import Control.Monad (when, unless, void)
 import Control.Monad.IO.Class (liftIO)
+import Control.Concurrent.MVar
+import Control.Concurrent (forkIO)
 
 import Data.Map.Strict as Map
 import qualified Data.Set as S
@@ -53,23 +55,25 @@ loadMap = do
   -- liftIO $ A.logIO A.Debug (show exits)
   (inter, rps) <- liftIO $ placeInteriorIO mat imgmat exits gr
   liftIO $ logIO A.Debug ("number of reachpoints: " ++ show (length rps))
-  let nnex = length (Prelude.filter (\p -> pointType p /= RoomExit) rps)
-  liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show nnex
-  npcposs <- placeNPCs inter mat rps gr nnex
+  let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps
+  liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length nnex)
+  npcposs <- placeNPCs inter mat rps gr (length nnex)
   (nws, _) <- yieldSystemT (worldState ud) $ do
     void $ newEntity $ defEntity
       { pos = Just (V2 20.5 20.5)
       , vel = Just (V2 0 0)
       , player = Just ()
       }
-    void $ mapM_ (\(V2 nr nc) -> do
+    void $ mapM_ (\npcpos@(V2 nr nc) -> do
       -- ttl <- liftIO $ randomRIO (5, 30)
       fact <- liftIO $ randomRIO (0.5, 1.5)
+      future <- liftIO $ newEmptyMVar
+      _ <- liftIO $ forkIO $ getPath (fmap floor npcpos) future nnex inter
       newEntity $ defEntity
         { pos      = Just (V2 (nr + 0.5) (nc + 0.5))
         , vel      = Just (V2 0 0)
         , velFact = Just fact
-        , npcState = Just (NPCStanding 0)
+        , npcState = Just (NPCStanding 0 future)
         }
       ) npcposs
   uu <- partSubscribe m movePlayer
diff --git a/src/Types/UserData.hs b/src/Types/UserData.hs
index 172e0df..d279f40 100644
--- a/src/Types/UserData.hs
+++ b/src/Types/UserData.hs
@@ -14,6 +14,8 @@ import qualified Data.Text as T
 import Data.Matrix
 import Data.Ecstasy
 
+import Control.Concurrent.MVar
+
 import Types.Map
 import Types.ReachPoint
 
@@ -160,7 +162,8 @@ data NPCState
     { npcWalkPath :: [V2 Int]
     }
   | NPCStanding
-    { npcStandTime :: Double
+    { npcStandTime  :: Double
+    , npcFuturePath :: MVar [V2 Int]
     }
 
 data Subsystems = Subsystems