processTick now returns all changed objects

This currently means all Dynamic objects and all
created objects. This is probably fine, since
Dynamic Objects stay the same during a Tick very
seldomly.

2 files changed, 31 insertions, 19 deletions

diff --git a/lib/Grav2ty/Control.hs b/lib/Grav2ty/Control.hs
index 3139687..fa75803 100644
--- a/lib/Grav2ty/Control.hs
+++ b/lib/Grav2ty/Control.hs
@@ -24,22 +24,23 @@ getForce :: (Ord a, Num a) =>  ObjRelGraph a -> Id -> V2 a
 getForce objRel id = foldlFrom' (\f r -> f + _relForce r) (V2 0 0) id objRel
 
 modifyObject :: (Monad m, RealFloat a)
-             => Id -> Object a -> Grav2ty a g m (Object a)
-modifyObject id obj@Static {} = pure obj
+             => Id -> Object a -> Grav2ty a g m (Object a, World a)
+modifyObject id obj@Static {} = pure (obj, M.empty)
 modifyObject id obj@Dynamic {} = use tick >>= \currentTick ->
   let mod = objectMod obj in use (inputs.at mod) >>= \modOfObj ->
     if mod == NoMod || isNothing modOfObj
-       then pure obj
+       then pure (obj, M.empty)
        else do
          let Just (Modification rot acc fire) = modOfObj
-         -- inputs.at mod .= Nothing (doesn't work with current gloss impl,
-         --                           also prob not necessary…)
+         -- inputs.at mod .= Nothing (not possible if inputs is
+         --                           used as state)
 
          -- 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
+         if not (currentTick == fire && isJust (objectCannon obj))
+            then pure (newObj, M.empty)
+            else let p = projectile (fromJust (objectCannon obj)) currentTick newObj
+                  in addObject p >>= \id -> pure (newObj, M.singleton id p)
 
 deletionNecessary :: Monad m
                   => ObjRelGraph a -> Id -> Object a
@@ -55,30 +56,40 @@ processObject :: (Monad m, RealFloat a)
               => World a -> ObjRelGraph a
               -> (Object a -> Grav2ty a g m ())
               -> Id -> Object a
-              -> Grav2ty a g m ()
-processObject old rels hook id obj =
-  deletionNecessary rels id obj >>= \del ->
+              -> Grav2ty a g m (World a)
+processObject old rels hook ident obj =
+  deletionNecessary rels ident obj >>= \del ->
     if del
-       then delObject id
+       then delObject ident >> pure M.empty
        else do
          timeStep <- use timePerTick
-         newObj <- updateObject timeStep (getForce rels id) <$> modifyObject id obj
-         setObject (Just id) newObj
+         (newObj, createdObjs) <- bimap (updateObject timeStep (getForce rels ident)) id <$>
+                                    modifyObject ident obj
+         setObject (Just ident) newObj
          hook newObj
+         pure $ M.insert ident newObj createdObjs
 
 -- | If called advances the simulation by one 'Tick' relying on the 'Grav2tyState'.
 --
 --   It also calls the provided hook-Action once for every remaining 'Object'. This
 --   action can be used to update the '_graphics' state @g@ or modify the behaviour
 --   of @processTick@ altogether.
+--
+--   It returns all 'Object's that were changed during the 'Tick' as a 'World'
+--   which will only contain changed 'Dynamic' 'Object's.
 processTick :: (Monad m, RealFloat a)
             => (Object a -> Grav2ty a g m ())
-            -> Grav2ty a g m ()
+            -> Grav2ty a g m (World a)
 processTick objHook = do
   oldWorld <- use world
   let objRel = objectRelGraph oldWorld
 
-  use world >>= M.foldlWithKey' (\action id obj ->
-    action >> processObject oldWorld objRel objHook id obj) (pure ())
+  updatedObjs <- use world >>= M.foldlWithKey' (\action id obj ->
+    action >>= \updated -> fmap (M.union updated) (processObject oldWorld objRel objHook id obj)) (pure M.empty)
 
   tick %= (+1)
+
+  pure updatedObjs
+
+-- TODO Map could be replaced by Seq here because we don't need to
+-- lookup a values in it.
diff --git a/lib/Grav2ty/Core.hs b/lib/Grav2ty/Core.hs
index 4d61c5a..171cdf9 100644
--- a/lib/Grav2ty/Core.hs
+++ b/lib/Grav2ty/Core.hs
@@ -164,13 +164,13 @@ makeLenses ''Grav2tyState
 type Grav2ty p g m a = StateT (Grav2tyState p g) m a
 
 -- | Shortcut for @'setObject' Nothing@.
-addObject :: Monad m => Object a -> Grav2ty a g m ()
+addObject :: Monad m => Object a -> Grav2ty a g m Id
 addObject = setObject Nothing
 
 -- | setObject overwrites or sets the 'Object' at the given 'Id'.
 --   If no 'Id' is given it picks a new 'Id' using '_highestId'
 --   that is guaranteed to be unused (if nothing messed with the 'World').
-setObject :: Monad m => Maybe Id -> Object a -> Grav2ty a g m ()
+setObject :: Monad m => Maybe Id -> Object a -> Grav2ty a g m Id
 setObject id obj = do
   id <- case id of
           Just id -> pure id
@@ -178,6 +178,7 @@ setObject id obj = do
             highestId += 1
             use highestId
   world %= M.insert id obj
+  pure id
 
 -- | Returns the 'Object' at 'Id'.
 getObject :: Monad m => Id -> Grav2ty a g m (Maybe (Object a))