diff --git a/src/MainGame/WorldMap.hs b/src/MainGame/WorldMap.hs index 5a12cc0..5a7155e 100644 --- a/src/MainGame/WorldMap.hs +++ b/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 diff --git a/src/NPC.hs b/src/NPC.hs index 28ad51d..a7903c3 100644 --- a/src/NPC.hs +++ b/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,137 +62,129 @@ 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 rot' <- query rot - let mdir = + 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 - let nttl = ttl - dt - if nttl > 0 + npcState' <- query npcMoveState + case npcState' of + NPCStanding ttl future -> do + let nttl = ttl - dt + if nttl > 0 + then + return $ (Nothing, unchanged + { npcMoveState = Set $ NPCStanding nttl future + , vel = Set $ V2 0 0 + }) + else do + mpath <- liftIO $ tryTakeMVar future + case mpath of + Just path -> + return $ (Nothing, unchanged + { npcMoveState = Set $ NPCWalking path + }) + Nothing -> + return $ (Nothing, unchanged + { npcMoveState = Set $ NPCStanding 1 future + }) + NPCWalking path -> do + pos' <- query 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 $ (Nothing, unchanged - { npcMoveState = Set $ NPCStanding nttl future - , vel = Set $ V2 0 0 + { npcMoveState = Set $ NPCWalking (tail path) }) - else do - mpath <- liftIO $ tryTakeMVar future - case mpath of - Just path -> - return $ (Nothing, unchanged - { npcMoveState = Set $ NPCWalking path - }) - Nothing -> - return $ (Nothing, unchanged - { npcMoveState = Set $ NPCStanding 1 future - }) - NPCWalking path -> do - pos' <- query 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 + else + return $ (Nothing, unchanged + { vel = Set $ (* 2) <$> signorm (itarget - pos') + }) + else do + future <- liftIO $ newEmptyMVar + stat <- query anim + _ <- liftIO $ forkIO $ + getPath (fmap floor pos') future rp imgmat posbounds + e <- queryEnt + let mdir = + (pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp) + accessibles = fromMaybe [] $ lookup e eaccess + case accessibles of + [] -> do + ttl <- liftIO $ randomRIO (5, 30) return $ (Nothing, unchanged - { npcMoveState = Set $ NPCWalking (tail path) - }) - else - return $ (Nothing, unchanged - { vel = Set $ (* 2) <$> signorm (itarget - pos') - }) - else do - future <- liftIO $ newEmptyMVar - stat <- query anim - rot' <- query rot - pos' <- query pos - _ <- liftIO $ forkIO $ - getPath (fmap floor pos') future rp imgmat posbounds - let mdir = - (pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp) - -- ttl <- liftIO $ randomRIO (5, 30) - -- 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) - 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 - } + { 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 } - }) - objects -> do - liftIO $ logIO Debug ("applicable objects: " ++ show objects) - rind <- liftIO $ randomRIO (0, length objects - 1) - npcent <- queryEnt - let (oent, _, _) = objects !! rind - return (Just (oent, npcent), unchanged - { rot = Set $ fromMaybe rot' mdir - , anim = Set stat - { asId = (asId stat) - { aiDirection = fromMaybe rot' mdir - } + } + }) + objects -> do + liftIO $ logIO Debug ("applicable objects: " ++ show objects) + rind <- liftIO $ randomRIO (0, length objects - 1) + npcent <- queryEnt + let (oent, _, _) = objects !! rind + return (Just (oent, npcent, future), unchanged + { rot = Set $ fromMaybe rot' mdir + , anim = Set stat + { asId = (asId stat) + { aiDirection = fromMaybe rot' mdir } - }) - mapM_ (\smoent -> maybe (return()) (\(oent, npcent) -> do - [(t, s)] <- efor (anEnt 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 - with objType - with objState - otyp <- query objType - ostat <- query objState - 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 - ) npcs + } + , vel = Set $ V2 0 0 + })) + 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 + Just (nt, ns) <- runQueryT oent $ do + with objType + with objState + otyp <- query objType + ostat <- query objState + return (otyp, ostat) + emap (anEnt npcent) $ do + let ttl = actionTime nt ns + return unchanged + { npcMoveState = Set $ NPCStanding ttl future + } + ) moent -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, _)) -> - fmap floor p + delta == fmap floor npos - ) candidates + mapM (\(e, pos) -> + return + ( e + , filter (\(_, p, (delta, _)) -> + fmap floor p + delta == fmap floor pos + ) candidates + ) + ) npcposs getPath :: V2 Int diff --git a/src/Object.hs b/src/Object.hs index e746494..6469c26 100644 --- a/src/Object.hs +++ b/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