nek0/tracer
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

optimization in logic and performance

Browse source
This commit is contained in:
nek0 2018-09-13 00:51:22 +02:00
parent 51cb19aaac
commit 8a50d3ca73
5 changed files with 112 additions and 117 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

49
src/MainGame/WorldMap.hs
View file

@ -81,12 +81,12 @@ loadMapFork
-> MVar (Float, T.Text) -> MVar (Float, T.Text)
-> IO () -> IO ()
loadMapFork ud ad future progress = do loadMapFork ud ad future progress = do
let loadSteps = 22 let loadSteps = 21
increment = 1 / loadSteps increment = 1 / loadSteps
fc = FloorConfig fc = FloorConfig
(V2 10 10) (V2 10 10)
[(V2 5 5), (V2 5 20)] [(V2 5 5), (V2 5 20)]
(40, 40) (50, 40)
modifyMVar_ progress (return . (\(p, _) -> modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Building floor" , "Building floor"
@ -163,20 +163,12 @@ loadMapFork ud ad future progress = do
, objType = Just ObjToilet , objType = Just ObjToilet
} }
) (A.log A.Debug ("number of toilets: " ++ show (length toilets)) toilets) ) (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, _) -> liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Preparing MindMap graph" , "Preparing MindMap graph"
))) )))
(mmintmat, mmgraph) <- liftIO $ buildFloorMap . springField <$> (mmintmat, mmgraph) <- liftIO $ buildFloorMap . springField <$>
buildMindMap (length npcposs) 2 buildMindMap (length computers) 2
liftIO $ modifyMVar_ progress (return . (\(p, _) -> liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Unfolding and Converting MindMap to images" , "Unfolding and Converting MindMap to images"
@ -203,21 +195,20 @@ loadMapFork ud ad future progress = do
, rot = Just SE , rot = Just SE
, anim = Just $ AnimState (AnimId "intruder" "standing" SE) 0 0 , 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, _) -> liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Registering NPCs into WorldState" , "Registering NPCs into WorldState"
))) )))
posbounds <- efor allEnts $ do -- posbounds <- efor allEnts $ do
with pos -- with pos
with obstacle -- with obstacle
pos' <- query pos -- pos' <- query pos
bnds <- query obstacle -- bnds <- query obstacle
return (pos', bnds) -- return (pos', bnds)
mapM_ (\(crp, npcpos@(V2 nr nc)) -> do mapM_ (\crp -> do
fact <- liftIO $ randomRIO (0.5, 1.5) fact <- liftIO $ randomRIO (0.5, 1.5)
fut <- liftIO newEmptyMVar -- fut <- liftIO newEmptyMVar
_ <- liftIO $ forkIO $
getPathTo (fmap floor npcpos) fut (pointCoord crp) inter posbounds
stats <- liftIO $ NPCStats stats <- liftIO $ NPCStats
<$> (randomRIO (0, 1)) <$> (randomRIO (0, 1))
<*> (randomRIO (0, 1)) <*> (randomRIO (0, 1))
@ -226,23 +217,25 @@ loadMapFork ud ad future progress = do
<*> (randomRIO (0, 1)) <*> (randomRIO (0, 1))
<*> (randomRIO (0, 1)) <*> (randomRIO (0, 1))
void $ createEntity $ newEntity void $ createEntity $ newEntity
{ pos = Just (fmap (+ 0.5) npcpos) { pos = Just (fmap ((+ 0.5) . fromIntegral) (pointCoord crp))
, vel = Just (V2 0 0) , vel = Just (V2 0 0)
, velFact = Just fact , velFact = Just fact
, rot = Just SE , rot = Just SE
, npcMoveState = Just (NPCStanding 0 fut) , npcMoveState = Just (NPCWalking [pointCoord crp])
, npcWorkplace = Just crp , npcWorkplace = Just crp
, npcActionState = Just ASWork , npcActionState = Just ASWork
, npcStats = Just stats , npcStats = Just stats
, anim = Just $ AnimState (AnimId "jdoem" "standing" SE) 0 0 , anim = Just $ AnimState (AnimId "jdoem" "standing" SE) 0 0
} }
) (zip computers npcposs) ) computers
liftIO $ modifyMVar_ progress (return . (\(p, _) -> liftIO $ modifyMVar_ progress (return . (\(p, _) ->
( p + increment ( p + increment
, "Handing over" , "Handing over"
))) )))
return mmimgmat return mmimgmat
)) ad )) ad
-- nstate <- evalStateT
-- (runState $ yieldSystemT nws (updateNPCs mmimgmat nws rps 0)) ad
putMVar future (nws, MainData putMVar future (nws, MainData
{ mapMat = mat { mapMat = mat
, imgMat = M.fromList (nrows inter) (ncols inter) $ , imgMat = M.fromList (nrows inter) (ncols inter) $
@ -303,13 +296,14 @@ playerInteract (MsgMouseButton _ _ SDL.Pressed _ SDL.ButtonRight _ m) = do
return $ unchanged return $ unchanged
{ rot = Set $ fromMaybe rot' ndir { rot = Set $ fromMaybe rot' ndir
} }
[(ppos, pdir)] <- efor allEnts $ do [(ppos, pdir, pent)] <- efor allEnts $ do
with player with player
with pos with pos
with rot with rot
pos' <- query pos pos' <- query pos
rot' <- query rot rot' <- query rot
return (pos', rot') ent <- queryEnt
return (pos', rot', ent)
mrelEnts <- efor allEnts $ do mrelEnts <- efor allEnts $ do
with pos with pos
with objAccess 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 ("relEnts: " ++ show relEnts)
-- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc)) -- liftIO $ A.logIO A.Debug ("dV2: " ++ show (V2 dr dc))
mapM_ (\(t, s, e) -> mapM_ (\(t, s, e) ->
setEntity e =<< objectTransition t s True e setEntity e =<< objectTransition t s True e (Just pent)
) relEnts ) relEnts
putAffection ud putAffection ud
{ worldState = nws { worldState = nws
@ -735,6 +729,7 @@ updateMap dt = do
) tses ) tses
(nws2, _) <- yieldSystemT nws $ updateNPCs (nws2, _) <- yieldSystemT nws $ updateNPCs
(imgMat $ stateData ud) (imgMat $ stateData ud)
nws
(Prelude.filter (Prelude.filter
(\p -> pointType p /= RoomExit) (\p -> pointType p /= RoomExit)
(reachPoints $ stateData ud) (reachPoints $ stateData ud)

131
src/NPC.hs
View file

@ -10,6 +10,7 @@ import Data.Maybe
import Data.List (find) import Data.List (find)
import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Trans (lift)
import Control.Concurrent.MVar import Control.Concurrent.MVar
import Control.Concurrent (forkIO) import Control.Concurrent (forkIO)
@ -25,61 +26,28 @@ import Types
import Object () import Object ()
placeNPCs getPosBounds
:: M.Matrix (Maybe ImgId) :: SystemT
-> M.Matrix TileState Entity
-> [ReachPoint] (AffectionState (AffectionData UserData) IO)
-> Int [(V2 Double, Boundaries Double)]
-> IO [V2 Double] getPosBounds = do
placeNPCs imgmat tilemat rp count = efor allEnts $ do
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
with pos with pos
with obstacle with obstacle
pos' <- query pos pos' <- query pos
bnds <- query obstacle bnds <- query obstacle
return (pos', bnds) return (pos', bnds)
npcposs <- efor allEnts $ do
with pos updateNPCs
with npcMoveState :: M.Matrix (Maybe ImgId)
with vel -> SystemState Entity (AffectionState (AffectionData UserData) IO)
with rot -> [ReachPoint]
with anim -> Double
pos' <- query pos -> SystemT Entity (AffectionState (AffectionData UserData) IO) ()
e <- queryEnt updateNPCs imgmat ws rp dt = do
return (e, pos') updateStats dt
eaccess <- getObjects npcposs posbounds <- getPosBounds
moent <- catMaybes <$> eover allEnts (do moent <- catMaybes <$> eover allEnts (do
with pos with pos
with npcMoveState with npcMoveState
@ -99,7 +67,7 @@ updateNPCs imgmat rp dt = do
then then
return (Nothing, unchanged return (Nothing, unchanged
{ npcMoveState = Set $ NPCStanding nttl future { npcMoveState = Set $ NPCStanding nttl future
, vel = Set $ V2 0 0 -- , vel = Set $ V2 0 0
}) })
else do else do
mpath <- liftIO $ tryTakeMVar future mpath <- liftIO $ tryTakeMVar future
@ -146,7 +114,8 @@ updateNPCs imgmat rp dt = do
stat <- query anim stat <- query anim
as <- query npcActionState as <- query npcActionState
targetRPs <- case as of targetRPs <- case as of
ASWork -> (: []) <$> query npcWorkplace ASWork -> (: filter (\p -> pointType p == Copier) rp)
<$> query npcWorkplace
ASToilet -> do ASToilet -> do
let seekRP = filter (\p -> pointType p == Toilet) rp let seekRP = filter (\p -> pointType p == Toilet) rp
if null seekRP if null seekRP
@ -166,10 +135,10 @@ updateNPCs imgmat rp dt = do
return $ filter (\p -> pointType p /= RoomExit) rp return $ filter (\p -> pointType p /= RoomExit) rp
_ <- liftIO $ forkIO $ _ <- liftIO $ forkIO $
getPath (fmap floor pos') future targetRPs imgmat posbounds getPath (fmap floor pos') future targetRPs imgmat posbounds
e <- queryEnt
let mdir = let mdir =
pointDir <$> find (\a -> pointCoord a == fmap floor pos') rp 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 case accessibles of
[] -> do [] -> do
ttl <- liftIO $ randomRIO (5, 30) ttl <- liftIO $ randomRIO (5, 30)
@ -197,21 +166,38 @@ updateNPCs imgmat rp dt = do
, vel = Set $ V2 0 0 , vel = Set $ V2 0 0
})) }))
mapM_ (\(oent, npcent, future) -> do mapM_ (\(oent, npcent, future) -> do
Just (t, s) <- runQueryT oent $ do [mts] <- efor (anEnt oent) $ do
with objType with objType
with objState with objState
moub <- queryMaybe objUsedBy
otyp <- query objType otyp <- query objType
ostat <- query objState ostat <- query objState
return (otyp, ostat) case moub of
setEntity oent =<< objectTransition t s False oent Nothing -> return $ Just (otyp, ostat)
Just (nt, ns) <- runQueryT oent $ do 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 objType
with objState with objState
moub <- queryMaybe objUsedBy
otyp <- query objType otyp <- query objType
ostat <- query objState 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 emap (anEnt npcent) $ do
let ttl = actionTime nt ns let ttl = case mntns of
Just (nt, ns) -> actionTime nt ns
Nothing -> 1
return unchanged return unchanged
{ npcMoveState = Set $ NPCStanding ttl future { npcMoveState = Set $ NPCStanding ttl future
} }
@ -256,11 +242,11 @@ updateStats dt =
| statBladder nstat > 0.9 = ASToilet | statBladder nstat > 0.9 = ASToilet
| otherwise = as | otherwise = as
getObjects getObject
:: (Monad m, Traversable t, RealFrac a1) :: (MonadIO m, RealFrac a1)
=> t (a2, V2 a1) => V2 a1
-> SystemT Entity m (t (a2, [(Ent, V2 Double, (V2 Int, Direction))])) -> SystemT Entity m [(Ent, V2 Double, (V2 Int, Direction))]
getObjects npcposs = do getObject npos = do
candidates <- efor allEnts $ do candidates <- efor allEnts $ do
with pos with pos
with objType with objType
@ -270,14 +256,11 @@ getObjects npcposs = do
oacc <- query objAccess oacc <- query objAccess
ent <- queryEnt ent <- queryEnt
return (ent, pos', oacc) return (ent, pos', oacc)
mapM (\(e, npos) -> liftIO $ logIO A.Verbose ("candidates: " ++ show candidates)
return return $
( e filter (\(_, p, (delta, _)) ->
, filter (\(_, p, (delta, _)) ->
fmap floor p + delta == fmap floor npos fmap floor p + delta == fmap floor npos
) candidates ) candidates
)
) npcposs
getPath getPath
:: V2 Int :: V2 Int
@ -293,7 +276,10 @@ getPath pos' mvar rp imgmat posbounds = do
path = astarAppl imgmat posbounds ntarget pos' path = astarAppl imgmat posbounds ntarget pos'
logIO A.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show ntarget) logIO A.Verbose ("seeking path from " ++ show pos' ++ " to " ++ show ntarget)
case path of 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 Just p -> putMVar mvar p
getPathTo getPathTo
@ -309,5 +295,4 @@ getPathTo pos' mvar target imgmat posbounds = do
case path of case path of
Nothing -> do Nothing -> do
logIO A.Error ("No path from " ++ show pos' ++ " to " ++ show target) logIO A.Error ("No path from " ++ show pos' ++ " to " ++ show target)
putMVar mvar [pos']
Just p -> putMVar mvar p Just p -> putMVar mvar p

43
src/Object.hs
View file

@ -34,10 +34,13 @@ instance ObjectAction ObjType ObjState where
case mttl of case mttl of
Nothing -> return False Nothing -> return False
Just ttl -> return (ttl < 0) 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 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 player
with vel with vel
query vel query vel
@ -54,7 +57,7 @@ instance ObjectAction ObjType ObjState where
return unchanged return unchanged
{ objStateTime = Set (ttl - dt) { objStateTime = Set (ttl - dt)
} }
trans <- efor (anEnt ent) $ do [trans] <- efor (anEnt ent) $ do
mttl <- queryMaybe objStateTime mttl <- queryMaybe objStateTime
case mttl of case mttl of
Nothing -> return Nothing Nothing -> return Nothing
@ -63,16 +66,19 @@ instance ObjectAction ObjType ObjState where
if ttl < 0 if ttl < 0
then then
return (Just pa) 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) then return (Just pa)
else return Nothing else return Nothing
maybe maybe
(return ()) (return ())
(\tpa -> setEntity ent =<< objectTransition t s tpa ent) (\tpa -> setEntity ent =<< objectTransition t s tpa ent Nothing)
(head trans) trans
objectAction dt t@ObjComputer s@"hack" ent = do 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 player
with vel with vel
query vel query vel
@ -93,19 +99,19 @@ instance ObjectAction ObjType ObjState where
case mttl of case mttl of
Nothing -> return Nothing Nothing -> return Nothing
Just ttl -> do Just ttl -> do
if (ttl < 0) || vl `dot` vl > 0 if (ttl < 0) || (not (null vls) && head vls `dot` head vls > 0)
then do then do
tpa <- query objPlayerActivated tpa <- query objPlayerActivated
return (Just tpa) return (Just tpa)
else return Nothing else return Nothing
maybe maybe
(return ()) (return ())
(\tpa -> setEntity ent =<< objectTransition t s tpa ent) (\tpa -> setEntity ent =<< objectTransition t s tpa ent Nothing)
trans trans
objectAction _ _ _ _ = return () objectAction _ _ _ _ = return ()
objectTransition ObjCopier "idle" playerActivated ent = do objectTransition ObjCopier "idle" playerActivated ent (Just aent) = do
[e] <- efor (anEnt ent) $ do [e] <- efor (anEnt ent) $ do
let nstat = AnimState let nstat = AnimState
(AnimId "copier" "copy" N) (AnimId "copier" "copy" N)
@ -113,12 +119,13 @@ instance ObjectAction ObjType ObjState where
0 0
return unchanged return unchanged
{ objState = Set "copying" { objState = Set "copying"
, objUsedBy = Set aent
, objPlayerActivated = Set playerActivated , objPlayerActivated = Set playerActivated
, anim = Set nstat , anim = Set nstat
} }
return e return e
objectTransition ObjCopier "copying" _ ent = do objectTransition ObjCopier "copying" _ ent _ = do
[e] <- efor (anEnt ent) $ do [e] <- efor (anEnt ent) $ do
ttl <- query objStateTime ttl <- query objStateTime
if ttl < 0 if ttl < 0
@ -132,11 +139,12 @@ instance ObjectAction ObjType ObjState where
, objState = Set "idle" , objState = Set "idle"
, objStateTime = Unset , objStateTime = Unset
, objPlayerActivated = Unset , objPlayerActivated = Unset
, objUsedBy = Unset
} }
else return unchanged else return unchanged
return e return e
objectTransition ObjComputer "off" pa ent = do objectTransition ObjComputer "off" pa ent (Just aent) = do
[e] <- efor (anEnt ent) $ do [e] <- efor (anEnt ent) $ do
solved <- queryMaybe objSolved solved <- queryMaybe objSolved
if pa if pa
@ -150,6 +158,7 @@ instance ObjectAction ObjType ObjState where
{ anim = Set nstat { anim = Set nstat
, objState = Set "hack" , objState = Set "hack"
, objPlayerActivated = Set True , objPlayerActivated = Set True
, objUsedBy = Set aent
} }
else do else do
let nstat = AnimState let nstat = AnimState
@ -160,6 +169,7 @@ instance ObjectAction ObjType ObjState where
{ anim = Set nstat { anim = Set nstat
, objState = Set "on" , objState = Set "on"
, objPlayerActivated = Set True , objPlayerActivated = Set True
, objUsedBy = Set aent
} }
else do else do
let nstat = AnimState let nstat = AnimState
@ -170,10 +180,11 @@ instance ObjectAction ObjType ObjState where
{ anim = Set nstat { anim = Set nstat
, objState = Set "on" , objState = Set "on"
, objPlayerActivated = Set False , objPlayerActivated = Set False
, objUsedBy = Set aent
} }
return e return e
objectTransition ObjComputer "on" _ ent = do objectTransition ObjComputer "on" _ ent _ = do
[e] <- efor (anEnt ent) $ do [e] <- efor (anEnt ent) $ do
let nstat = AnimState let nstat = AnimState
(AnimId "computer" "off" N) (AnimId "computer" "off" N)
@ -184,10 +195,11 @@ instance ObjectAction ObjType ObjState where
, objState = Set "off" , objState = Set "off"
, objPlayerActivated = Unset , objPlayerActivated = Unset
, objStateTime = Unset , objStateTime = Unset
, objUsedBy = Unset
} }
return e return e
objectTransition ObjComputer "hack" pa ent = objectTransition ObjComputer "hack" pa ent _ =
if pa if pa
then do then do
[e] <- efor (anEnt ent) $ do [e] <- efor (anEnt ent) $ do
@ -201,12 +213,13 @@ instance ObjectAction ObjType ObjState where
, objState = Set "off" , objState = Set "off"
, objPlayerActivated = Unset , objPlayerActivated = Unset
, objStateTime = Unset , objStateTime = Unset
, objUsedBy = Unset
, objSolved = if pa then Set (ost < 0) else Keep , objSolved = if pa then Set (ost < 0) else Keep
} }
return e return e
else return unchanged else return unchanged
objectTransition _ _ _ _ = return unchanged objectTransition _ _ _ _ _ = return unchanged
instance ActionTime ObjType ObjState where instance ActionTime ObjType ObjState where
actionTime ObjCopier "copying" = 5 actionTime ObjCopier "copying" = 5

1
src/Types/Entity.hs
View file

@ -30,6 +30,7 @@ data Entity f = Entity
, objType :: Component f 'Field ObjType , objType :: Component f 'Field ObjType
, objState :: Component f 'Field ObjState , objState :: Component f 'Field ObjState
, objStateTime :: Component f 'Field Double , objStateTime :: Component f 'Field Double
, objUsedBy :: Component f 'Field Ent
, objPlayerActivated :: Component f 'Field Bool , objPlayerActivated :: Component f 'Field Bool
, objSolved :: Component f 'Field Bool , objSolved :: Component f 'Field Bool
} }

1
src/Types/ObjClass.hs
View file

@ -23,6 +23,7 @@ class ObjectAction otype ostate where
-> ostate -> ostate
-> Bool -> Bool
-> Ent -> Ent
-> Maybe Ent
-> SystemT Entity (AffectionState (AffectionData UserData) IO) (Entity 'SetterOf) -> SystemT Entity (AffectionState (AffectionData UserData) IO) (Entity 'SetterOf)
class ActionTime otype ostate where class ActionTime otype ostate where