diff options
author | sternenseemann <git@lukasepple.de> | 2019-10-27 19:16:01 +0100 |
---|---|---|
committer | sternenseemann <git@lukasepple.de> | 2019-10-27 19:19:20 +0100 |
commit | 18cea52049f904a175871e778b89735b3f76828b (patch) | |
tree | f77186f8524e443240a6bb780f52d1cd6f4dce48 | |
parent | b15752f6dc89723c66047caddbff27bae94fd1df (diff) |
simplify object update
* previously deletion of objects was partially done by applyControls and partially by processObject. Now a single action deletionNecessary determines if an object has to be deleted or not, which is then done by processObject. * The remaining functionality of applyControls, i. e. applying a Modification to an Object, has been moved to modifyObject, which is now less nested and doesn't return a Maybe anymore.
-rw-r--r-- | lib/Grav2ty/Control.hs | 63 |
1 files changed, 34 insertions, 29 deletions
diff --git a/lib/Grav2ty/Control.hs b/lib/Grav2ty/Control.hs index 932f450..a4f2928 100644 --- a/lib/Grav2ty/Control.hs +++ b/lib/Grav2ty/Control.hs @@ -7,7 +7,6 @@ import Grav2ty.Util.RelGraph import Control.Lens import Control.Monad (when, unless) -import Data.Foldable (traverse_) import Data.Map (Map (..)) import Data.Maybe import Linear.V2 @@ -24,27 +23,33 @@ projectile (pos,speed) tick ship = getForce :: (Ord a, Num a) => ObjRelGraph a -> Id -> V2 a getForce objRel id = foldlFrom' (\f r -> f + _relForce r) (V2 0 0) id objRel -applyControls :: (Monad m, RealFloat a) - => Id -> Object a -> Grav2ty a g m (Maybe (Object a)) -applyControls _ obj@Static {} = pure $ Just obj -applyControls id obj@Dynamic {} = use tick >>= \currentTick -> - if fromMaybe False ((< currentTick) <$> objectLife obj) - then delObject id >> pure Nothing - else do - let mod = objectMod obj - modOfObj <- use (inputs.at mod) - if mod == NoMod || modOfObj == Nothing - then pure $ Just obj - else do - let Just (Modification rot acc fire) = modOfObj - -- inputs.at mod .= Nothing (doesn't work with current gloss impl, - -- also not necessary…) +modifyObject :: (Monad m, RealFloat a) + => Id -> Object a -> Grav2ty a g m (Object a) +modifyObject id obj@Static {} = pure obj +modifyObject id obj@Dynamic {} = use tick >>= \currentTick -> + let mod = objectMod obj in use (inputs.at mod) >>= \modOfObj -> + if mod == NoMod || modOfObj == Nothing + then pure obj + else do + let Just (Modification rot acc fire) = modOfObj + -- inputs.at mod .= Nothing (doesn't work with current gloss impl, + -- also prob not necessary…) - -- TODO: lenses for Object - let newObj = obj { objectRot = rot, objectAcc = angle rot ^* acc } - when (currentTick == fire && isJust (objectCannon obj)) $ - addObject (projectile (fromJust (objectCannon obj)) currentTick newObj) - pure $ Just newObj + -- TODO: lenses for Object + let newObj = obj { objectRot = rot, objectAcc = angle rot ^* acc } + when (currentTick == fire && isJust (objectCannon obj)) $ + addObject (projectile (fromJust (objectCannon obj)) currentTick newObj) + pure newObj + +deletionNecessary :: Monad m + => ObjRelGraph a -> Id -> Object a + -> Grav2ty a g m Bool +deletionNecessary rels id obj = do + currentTick <- use tick + pure $ + isDynamic obj && -- only dynamic objs are deleted + (fromMaybe False ((< currentTick) <$> objectLife obj) || -- life span expired? + (anyFrom _relColl id rels == Just True)) -- collision? processObject :: (Monad m, RealFloat a) => World a -> ObjRelGraph a @@ -52,14 +57,14 @@ processObject :: (Monad m, RealFloat a) -> Id -> Object a -> Grav2ty a g m () processObject old rels hook id obj = - if isDynamic obj && (anyFrom _relColl id rels == Just True) - -- delete any dynamic object that collided with another object - then delObject id - else do - timeStep <- use timePerTick - newObj <- fmap (updateObject timeStep (getForce rels id)) <$> applyControls id obj - traverse (setObject (Just id)) newObj - traverse_ hook newObj + deletionNecessary rels id obj >>= \del -> + if del + then delObject id + else do + timeStep <- use timePerTick + newObj <- updateObject timeStep (getForce rels id) <$> modifyObject id obj + setObject (Just id) newObj + hook newObj processTick :: (Monad m, RealFloat a) => (Object a -> Grav2ty a g m ()) |