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)
-> 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)

135
src/NPC.hs
View file

@ -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

43
src/Object.hs
View file

@ -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

1
src/Types/Entity.hs
View file

@ -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
}

1
src/Types/ObjClass.hs
View file

@ -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