From 17bc05ad5e6b5edeaa10400853e95e172fde7596 Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 13 Sep 2018 00:51:22 +0200 Subject: [PATCH] optimization in logic and performance --- src/MainGame/WorldMap.hs | 51 +++++++-------- src/NPC.hs | 135 +++++++++++++++++---------------------- src/Object.hs | 43 ++++++++----- src/Types/Entity.hs | 1 + src/Types/ObjClass.hs | 1 + 5 files changed, 113 insertions(+), 118 deletions(-) diff --git a/src/MainGame/WorldMap.hs b/src/MainGame/WorldMap.hs index f2670a7..eafc77f 100644 --- a/src/MainGame/WorldMap.hs +++ b/src/MainGame/WorldMap.hs @@ -5,7 +5,7 @@ module MainGame.WorldMap where import Affection as A -import Algebra.Graph as AG +import Algebra.Graph as AG hiding (Context(..)) import qualified SDL import NanoVG hiding (V2(..)) @@ -81,12 +81,12 @@ loadMapFork -> MVar (Float, T.Text) -> IO () loadMapFork ud ad future progress = do - let loadSteps = 22 + let loadSteps = 21 increment = 1 / loadSteps fc = FloorConfig (V2 10 10) [(V2 5 5), (V2 5 20)] - (40, 40) + (50, 40) modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Building floor" @@ -163,20 +163,12 @@ loadMapFork ud ad future progress = do , objType = Just ObjToilet } ) (A.log A.Debug ("number of toilets: " ++ show (length toilets)) toilets) - liftIO $ modifyMVar_ progress (return . (\(p, _) -> - ( p + increment - , "Placing NPCs" - ))) - liftIO $ logIO A.Debug ("number of reachpoints: " ++ show (length rps)) - let nnex = Prelude.filter (\p -> pointType p /= RoomExit) rps - npcposs <- liftIO $ placeNPCs inter mat rps (length computers) - liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length npcposs) liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Preparing MindMap graph" ))) (mmintmat, mmgraph) <- liftIO $ buildFloorMap . springField <$> - buildMindMap (length npcposs) 2 + buildMindMap (length computers) 2 liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Unfolding and Converting MindMap to images" @@ -203,21 +195,20 @@ loadMapFork ud ad future progress = do , rot = Just SE , anim = Just $ AnimState (AnimId "intruder" "standing" SE) 0 0 } + liftIO $ A.logIO A.Debug $ "number of placed NPCs: " ++ show (length computers) liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Registering NPCs into WorldState" ))) - posbounds <- efor allEnts $ do - with pos - with obstacle - pos' <- query pos - bnds <- query obstacle - return (pos', bnds) - mapM_ (\(crp, npcpos@(V2 nr nc)) -> do + -- posbounds <- efor allEnts $ do + -- with pos + -- with obstacle + -- pos' <- query pos + -- bnds <- query obstacle + -- return (pos', bnds) + mapM_ (\crp -> do fact <- liftIO $ randomRIO (0.5, 1.5) - fut <- liftIO newEmptyMVar - _ <- liftIO $ forkIO $ - getPathTo (fmap floor npcpos) fut (pointCoord crp) inter posbounds + -- fut <- liftIO newEmptyMVar stats <- liftIO $ NPCStats <$> (randomRIO (0, 1)) <*> (randomRIO (0, 1)) @@ -226,23 +217,25 @@ loadMapFork ud ad future progress = do <*> (randomRIO (0, 1)) <*> (randomRIO (0, 1)) void $ createEntity $ newEntity - { pos = Just (fmap (+ 0.5) npcpos) + { pos = Just (fmap ((+ 0.5) . fromIntegral) (pointCoord crp)) , vel = Just (V2 0 0) , velFact = Just fact , rot = Just SE - , npcMoveState = Just (NPCStanding 0 fut) + , npcMoveState = Just (NPCWalking [pointCoord crp]) , npcWorkplace = Just crp , npcActionState = Just ASWork , npcStats = Just stats , anim = Just $ AnimState (AnimId "jdoem" "standing" SE) 0 0 } - ) (zip computers npcposs) + ) computers liftIO $ modifyMVar_ progress (return . (\(p, _) -> ( p + increment , "Handing over" ))) return mmimgmat )) ad + -- nstate <- evalStateT + -- (runState $ yieldSystemT nws (updateNPCs mmimgmat nws rps 0)) ad putMVar future (nws, MainData { mapMat = mat , imgMat = M.fromList (nrows inter) (ncols inter) $ @@ -303,13 +296,14 @@ playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do return $ unchanged { rot = Set $ fromMaybe rot' ndir } - [(ppos, pdir)] <- efor allEnts $ do + [(ppos, pdir, pent)] <- efor allEnts $ do with player with pos with rot pos' <- query pos rot' <- query rot - return (pos', rot') + ent <- queryEnt + return (pos', rot', ent) mrelEnts <- efor allEnts $ do with pos with objAccess @@ -330,7 +324,7 @@ playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do liftIO $ A.logIO A.Debug ("relEnts: " ++ show relEnts) -- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc)) mapM_ (\(t, s, e) -> - setEntity e =<< objectTransition t s True e + setEntity e =<< objectTransition t s True e (Just pent) ) relEnts putAffection ud { worldState = nws @@ -735,6 +729,7 @@ updateMap dt = do ) tses (nws2, _) <- yieldSystemT nws $ updateNPCs (imgMat $ stateData ud) + nws (Prelude.filter (\p -> pointType p /= RoomExit) (reachPoints $ stateData ud) diff --git a/src/NPC.hs b/src/NPC.hs index e9197c5..73477a3 100644 --- a/src/NPC.hs +++ b/src/NPC.hs @@ -10,6 +10,7 @@ import Data.Maybe import Data.List (find) import Control.Monad.IO.Class (MonadIO(..)) +import Control.Monad.Trans (lift) import Control.Concurrent.MVar import Control.Concurrent (forkIO) @@ -25,61 +26,28 @@ import Types import Object () -placeNPCs - :: M.Matrix (Maybe ImgId) - -> M.Matrix TileState - -> [ReachPoint] - -> Int - -> IO [V2 Double] -placeNPCs imgmat tilemat rp count = - doPlace 1 [] - where - doPlace :: Int -> [V2 Double] -> IO [V2 Double] - doPlace nr acc = - if nr <= count - then do - r <- randomRIO (1, M.nrows imgmat) - c <- randomRIO (1, M.ncols imgmat) - if null (maybe [] collisionObstacle $ imgmat M.! (r, c)) && - tilemat M.! (r, c) == Hall - then doPlace (nr + 1) (V2 (fromIntegral r) (fromIntegral c) : acc) - else do - i <- randomRIO (0, length nonexits - 1) - doPlace - (nr + 1) - (fmap fromIntegral (pointCoord (nonexits !! i)) : acc) - else - return acc - nonexits = - filter - (\p -> - pointType p /= RoomExit - ) - rp - -updateNPCs - :: M.Matrix (Maybe ImgId) - -> [ReachPoint] - -> Double - -> SystemT Entity (AffectionState (AffectionData UserData) IO) () -updateNPCs imgmat rp dt = do - updateStats dt - posbounds <- efor allEnts $ do +getPosBounds + :: SystemT + Entity + (AffectionState (AffectionData UserData) IO) + [(V2 Double, Boundaries Double)] +getPosBounds = do + efor allEnts $ do with pos with obstacle pos' <- query pos bnds <- query obstacle return (pos', bnds) - 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 + +updateNPCs + :: M.Matrix (Maybe ImgId) + -> SystemState Entity (AffectionState (AffectionData UserData) IO) + -> [ReachPoint] + -> Double + -> SystemT Entity (AffectionState (AffectionData UserData) IO) () +updateNPCs imgmat ws rp dt = do + updateStats dt + posbounds <- getPosBounds moent <- catMaybes <$> eover allEnts (do with pos with npcMoveState @@ -99,7 +67,7 @@ updateNPCs imgmat rp dt = do then return (Nothing, unchanged { npcMoveState = Set $ NPCStanding nttl future - , vel = Set $ V2 0 0 + -- , vel = Set $ V2 0 0 }) else do mpath <- liftIO $ tryTakeMVar future @@ -146,7 +114,8 @@ updateNPCs imgmat rp dt = do stat <- query anim as <- query npcActionState targetRPs <- case as of - ASWork -> (: []) <$> query npcWorkplace + ASWork -> (: filter (\p -> pointType p == Copier) rp) + <$> query npcWorkplace ASToilet -> do let seekRP = filter (\p -> pointType p == Toilet) rp if null seekRP @@ -166,10 +135,10 @@ updateNPCs imgmat rp dt = do return $ filter (\p -> pointType p /= RoomExit) rp _ <- liftIO $ forkIO $ getPath (fmap floor pos') future targetRPs imgmat posbounds - e <- queryEnt let mdir = pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp - accessibles = fromMaybe [] $ lookup e eaccess + (_, accessibles) <- lift $ yieldSystemT ws (getObject pos') + liftIO $ logIO A.Verbose ("accessibles: " ++ show accessibles) case accessibles of [] -> do ttl <- liftIO $ randomRIO (5, 30) @@ -197,21 +166,38 @@ updateNPCs imgmat rp dt = do , vel = Set $ V2 0 0 })) mapM_ (\(oent, npcent, future) -> do - Just (t, s) <- runQueryT oent $ do + [mts] <- efor (anEnt oent) $ do with objType with objState + moub <- queryMaybe objUsedBy otyp <- query objType ostat <- query objState - return (otyp, ostat) - setEntity oent =<< objectTransition t s False oent - Just (nt, ns) <- runQueryT oent $ do + case moub of + Nothing -> return $ Just (otyp, ostat) + Just uent -> if uent == npcent + then return $ Just (otyp, ostat) + else return Nothing + maybe + (return ()) + (\(t, s) -> + setEntity oent =<< objectTransition t s False oent (Just npcent) + ) + mts + [mntns] <- efor (anEnt oent) $ do with objType with objState + moub <- queryMaybe objUsedBy otyp <- query objType ostat <- query objState - return (otyp, ostat) + case moub of + Nothing -> return $ Just (otyp, ostat) + Just uent -> if uent == npcent + then return $ Just (otyp, ostat) + else return Nothing emap (anEnt npcent) $ do - let ttl = actionTime nt ns + let ttl = case mntns of + Just (nt, ns) -> actionTime nt ns + Nothing -> 1 return unchanged { npcMoveState = Set $ NPCStanding ttl future } @@ -256,11 +242,11 @@ updateStats dt = | statBladder nstat > 0.9 = ASToilet | otherwise = as -getObjects - :: (Monad m, Traversable t, RealFrac a1) - => t (a2, V2 a1) - -> SystemT Entity m (t (a2, [(Ent, V2 Double, (V2 Int, Direction))])) -getObjects npcposs = do +getObject + :: (MonadIO m, RealFrac a1) + => V2 a1 + -> SystemT Entity m [(Ent, V2 Double, (V2 Int, Direction))] +getObject npos = do candidates <- efor allEnts $ do with pos with objType @@ -270,14 +256,11 @@ getObjects npcposs = do oacc <- query objAccess ent <- queryEnt return (ent, pos', oacc) - mapM (\(e, npos) -> - return - ( e - , filter (\(_, p, (delta, _)) -> - fmap floor p + delta == fmap floor npos - ) candidates - ) - ) npcposs + liftIO $ logIO A.Verbose ("candidates: " ++ show candidates) + return $ + filter (\(_, p, (delta, _)) -> + fmap floor p + delta == fmap floor npos + ) candidates getPath :: V2 Int @@ -293,7 +276,10 @@ getPath pos' mvar rp imgmat posbounds = do path = astarAppl imgmat posbounds ntarget pos' logIO A.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show ntarget) case path of - Nothing -> getPath pos' mvar rp imgmat posbounds + Nothing -> do + logIO A.Error ("No path from " ++ show pos' ++ " to " ++ show ntarget) + putMVar mvar [] + -- getPath pos' mvar rp imgmat posbounds Just p -> putMVar mvar p getPathTo @@ -309,5 +295,4 @@ getPathTo pos' mvar target imgmat posbounds = do case path of Nothing -> do logIO A.Error ("No path from " ++ show pos' ++ " to " ++ show target) - putMVar mvar [pos'] Just p -> putMVar mvar p diff --git a/src/Object.hs b/src/Object.hs index 1295c1c..ccfbfdb 100644 --- a/src/Object.hs +++ b/src/Object.hs @@ -34,10 +34,13 @@ instance ObjectAction ObjType ObjState where case mttl of Nothing -> return False Just ttl -> return (ttl < 0) - when trans (setEntity ent =<< objectTransition t s False ent) + when trans (setEntity ent =<< objectTransition t s False ent Nothing) objectAction dt t@ObjComputer s@"on" ent = do - [vl] <- efor allEnts $ do + [pent] <- efor (anEnt ent) $ do + with objUsedBy + query objUsedBy + vls <- efor (anEnt pent) $ do with player with vel query vel @@ -54,7 +57,7 @@ instance ObjectAction ObjType ObjState where return unchanged { objStateTime = Set (ttl - dt) } - trans <- efor (anEnt ent) $ do + [trans] <- efor (anEnt ent) $ do mttl <- queryMaybe objStateTime case mttl of Nothing -> return Nothing @@ -63,16 +66,19 @@ instance ObjectAction ObjType ObjState where if ttl < 0 then return (Just pa) - else if pa && vl `dot` vl > 0 + else if not (null vls) && head vls `dot` head vls > 0 then return (Just pa) else return Nothing maybe (return ()) - (\tpa -> setEntity ent =<< objectTransition t s tpa ent) - (head trans) + (\tpa -> setEntity ent =<< objectTransition t s tpa ent Nothing) + trans objectAction dt t@ObjComputer s@"hack" ent = do - [vl] <- efor allEnts $ do + [aent] <- efor (anEnt ent) $ do + with objUsedBy + query objUsedBy + vls <- efor (anEnt aent) $ do with player with vel query vel @@ -93,19 +99,19 @@ instance ObjectAction ObjType ObjState where case mttl of Nothing -> return Nothing Just ttl -> do - if (ttl < 0) || vl `dot` vl > 0 + if (ttl < 0) || (not (null vls) && head vls `dot` head vls > 0) then do tpa <- query objPlayerActivated return (Just tpa) else return Nothing maybe (return ()) - (\tpa -> setEntity ent =<< objectTransition t s tpa ent) + (\tpa -> setEntity ent =<< objectTransition t s tpa ent Nothing) trans objectAction _ _ _ _ = return () - objectTransition ObjCopier "idle" playerActivated ent = do + objectTransition ObjCopier "idle" playerActivated ent (Just aent) = do [e] <- efor (anEnt ent) $ do let nstat = AnimState (AnimId "copier" "copy" N) @@ -113,12 +119,13 @@ instance ObjectAction ObjType ObjState where 0 return unchanged { objState = Set "copying" + , objUsedBy = Set aent , objPlayerActivated = Set playerActivated , anim = Set nstat } return e - objectTransition ObjCopier "copying" _ ent = do + objectTransition ObjCopier "copying" _ ent _ = do [e] <- efor (anEnt ent) $ do ttl <- query objStateTime if ttl < 0 @@ -132,11 +139,12 @@ instance ObjectAction ObjType ObjState where , objState = Set "idle" , objStateTime = Unset , objPlayerActivated = Unset + , objUsedBy = Unset } else return unchanged return e - objectTransition ObjComputer "off" pa ent = do + objectTransition ObjComputer "off" pa ent (Just aent) = do [e] <- efor (anEnt ent) $ do solved <- queryMaybe objSolved if pa @@ -150,6 +158,7 @@ instance ObjectAction ObjType ObjState where { anim = Set nstat , objState = Set "hack" , objPlayerActivated = Set True + , objUsedBy = Set aent } else do let nstat = AnimState @@ -160,6 +169,7 @@ instance ObjectAction ObjType ObjState where { anim = Set nstat , objState = Set "on" , objPlayerActivated = Set True + , objUsedBy = Set aent } else do let nstat = AnimState @@ -170,10 +180,11 @@ instance ObjectAction ObjType ObjState where { anim = Set nstat , objState = Set "on" , objPlayerActivated = Set False + , objUsedBy = Set aent } return e - objectTransition ObjComputer "on" _ ent = do + objectTransition ObjComputer "on" _ ent _ = do [e] <- efor (anEnt ent) $ do let nstat = AnimState (AnimId "computer" "off" N) @@ -184,10 +195,11 @@ instance ObjectAction ObjType ObjState where , objState = Set "off" , objPlayerActivated = Unset , objStateTime = Unset + , objUsedBy = Unset } return e - objectTransition ObjComputer "hack" pa ent = + objectTransition ObjComputer "hack" pa ent _ = if pa then do [e] <- efor (anEnt ent) $ do @@ -201,12 +213,13 @@ instance ObjectAction ObjType ObjState where , objState = Set "off" , objPlayerActivated = Unset , objStateTime = Unset + , objUsedBy = Unset , objSolved = if pa then Set (ost < 0) else Keep } return e else return unchanged - objectTransition _ _ _ _ = return unchanged + objectTransition _ _ _ _ _ = return unchanged instance ActionTime ObjType ObjState where actionTime ObjCopier "copying" = 5 diff --git a/src/Types/Entity.hs b/src/Types/Entity.hs index 610927f..d1d56a9 100644 --- a/src/Types/Entity.hs +++ b/src/Types/Entity.hs @@ -30,6 +30,7 @@ data Entity f = Entity , objType :: Component f 'Field ObjType , objState :: Component f 'Field ObjState , objStateTime :: Component f 'Field Double + , objUsedBy :: Component f 'Field Ent , objPlayerActivated :: Component f 'Field Bool , objSolved :: Component f 'Field Bool } diff --git a/src/Types/ObjClass.hs b/src/Types/ObjClass.hs index f97b745..3087250 100644 --- a/src/Types/ObjClass.hs +++ b/src/Types/ObjClass.hs @@ -23,6 +23,7 @@ class ObjectAction otype ostate where -> ostate -> Bool -> Ent + -> Maybe Ent -> SystemT Entity (AffectionState (AffectionData UserData) IO) (Entity 'SetterOf) class ActionTime otype ostate where