feat(Grav2ty.Control): rework to emit updates instead of modifying state

2 files changed, 60 insertions, 79 deletions

diff --git a/lib/Grav2ty/Control.hs b/lib/Grav2ty/Control.hs
index fa75803..d6f4e4e 100644
--- a/lib/Grav2ty/Control.hs
+++ b/lib/Grav2ty/Control.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE BlockArguments #-}
-module Grav2ty.Control (processTick) where
+{-# LANGUAGE RecordWildCards #-}
+module Grav2ty.Control (tickUpdates, Grav2tyUpdate (..)) where
 
 import Grav2ty.Core
 import Grav2ty.Simulation
@@ -7,12 +7,19 @@ import Grav2ty.Util.RelGraph
 
 import Control.Lens
 import Control.Monad (when, unless)
+import Data.Bifunctor (first)
 import Data.Map (Map (..))
 import Data.Maybe
 import Linear.V2
 import Linear.Vector
 import qualified Data.Map.Strict as M
 
+data Grav2tyUpdate a
+  = DeleteObject Id              -- ^ Delete an object
+  | NewObject (Object a)         -- ^ Add an object
+  | UpdateObject Id (Object a)   -- ^ Change object with given id to new value
+--  | TickDone Tick                -- ^ Last update of a tick signifying it's fully computed
+  deriving (Show, Eq, Ord)
 
 projectile :: RealFloat a => (V2 a, V2 a) -> Integer -> Object a -> Object a
 projectile (pos,speed) tick ship =
@@ -23,73 +30,42 @@ 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
 
-modifyObject :: (Monad m, RealFloat a)
-             => 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, M.empty)
-       else do
-         let Just (Modification rot acc fire) = modOfObj
-         -- inputs.at mod .= Nothing (not possible if inputs is
-         --                           used as state)
+deletionNecessary :: Tick -> ObjRelGraph a -> Id -> Object a -> Bool
+deletionNecessary tick rels id obj =
+  isDynamic obj &&                          -- only dynamic objs are deleted
+  (maybe False (< tick) (objectLife obj) || -- life span expired?
+  (anyFrom _relColl id rels == Just True))  -- collision?
 
-         -- TODO: lenses for Object
-         let newObj = obj { objectRot = rot, objectAcc = angle rot ^* acc }
-         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)
+applyModification :: RealFloat a => Grav2tyState a s -> Id -> Object a -> (Object a, [Grav2tyUpdate a])
+applyModification _ _ obj@(Static {}) = (obj, [])
+applyModification (Grav2tyState {..}) id obj
+  | not (doesModify (objectMod obj)) = (obj, [])
+  | otherwise =
+    case modObj of
+      Nothing -> (obj, [])
+      Just (newObj, fire) ->
+        ( newObj
+        , if _tick /= fire
+            then []
+            else case objectCannon newObj of
+                   Just c  -> [NewObject $ projectile c _tick newObj]
+                   Nothing -> [])
+  where modObj = do
+          (Modification rot acc fire) <- M.lookup (objectMod obj) _inputs
+          pure (obj { objectRot = rot, objectAcc = angle rot ^* acc }, fire)
 
-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
-    (maybe False (< currentTick) (objectLife obj) || -- life span expired?
-    (anyFrom _relColl id rels == Just True))         -- collision?
+objectUpdates :: (Ord a, RealFloat a) => Grav2tyState a s -> ObjRelGraph a -> Id -> Object a -> [Grav2tyUpdate a]
+objectUpdates s@(Grav2tyState {..}) rels id obj =
+  case obj of
+    Static {}      -> []
+    d@(Dynamic {}) ->
+      let (modObject, newObjects) = applyModification s id obj
+          updatedObject = updateObject (fromIntegral _timePerTick / (10**6)) (getForce rels id) modObject
+       in if deletionNecessary _tick rels id obj
+            then [DeleteObject id]
+            else UpdateObject id updatedObject : newObjects
 
-processObject :: (Monad m, RealFloat a)
-              => World a -> ObjRelGraph a
-              -> (Object a -> Grav2ty a g m ())
-              -> Id -> Object a
-              -> Grav2ty a g m (World a)
-processObject old rels hook ident obj =
-  deletionNecessary rels ident obj >>= \del ->
-    if del
-       then delObject ident >> pure M.empty
-       else do
-         timeStep <- use timePerTick
-         (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 (World a)
-processTick objHook = do
-  oldWorld <- use world
-  let objRel = objectRelGraph oldWorld
-
-  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.
+tickUpdates :: (Ord a, RealFloat a) => Grav2tyState a s -> [[Grav2tyUpdate a]]
+tickUpdates s@(Grav2tyState {..}) =
+  M.foldlWithKey' (\updates id obj -> objectUpdates s objRel id obj : updates) [] _world
+  where objRel = objectRelGraph _world
diff --git a/lib/Grav2ty/Core.hs b/lib/Grav2ty/Core.hs
index 171cdf9..0ee7473 100644
--- a/lib/Grav2ty/Core.hs
+++ b/lib/Grav2ty/Core.hs
@@ -9,6 +9,7 @@ module Grav2ty.Core
   , isDynamic
   , Cannon (..)
   , Modifier (..)
+  , doesModify
   -- *** Hitboxes
   , Hitbox (..)
   , shipHitbox
@@ -22,7 +23,7 @@ module Grav2ty.Core
   , Grav2ty (..)
   -- ** State
   , Grav2tyState (..)
-  , tick, timePerTick, inputs, graphics, world, highestId
+  , tick, timePerTick, inputs, customState, world, highestId
   -- ** Operations
   , setObject
   , getObject
@@ -53,6 +54,10 @@ data Modifier
            --   which might be a local or remote player.
   deriving(Eq, Ord, Show)
 
+doesModify :: Modifier -> Bool
+doesModify NoMod = False
+doesModify _     = True
+
 -- | @Just (<cannon position>, <cannon direction>)@ describes origin and
 --   trajectory of projectiles of this object. Note that both position and
 --   direction are rotated by 'objectRot'. @Nothing@ means that projectiles
@@ -148,15 +153,15 @@ zeroModification = Modification 0 0 (-1)
 --   that is being simulated.
 type ModMap a = Map Modifier (Modification a)
 
-data Grav2tyState a g = Grav2tyState
-  { _tick        :: Tick               -- ^ The 'Tick' the game is at currently.
-  , _timePerTick :: a                  -- ^ The time between two 'Tick's.
-  , _inputs      :: ModMap a           -- ^ 'Modification's that have to be processed in the next tick.
-  , _graphics    :: g                  -- ^ Graphics state. Use @()@ if non-graphical.
-  , _world       :: World a            -- ^ All objects.
-  , _highestId   :: Id                 -- ^ Highest 'Id' used in 'World'. This is updated by 'addObject'
-                                       --   in Order to prevent accidental overwrites.
-  } deriving (Show, Eq)
+data Grav2tyState a s = Grav2tyState
+  { _tick        :: Tick                      -- ^ The 'Tick' the game is at currently.
+  , _timePerTick :: Int                       -- ^ The time between two 'Tick's in microseconds.
+  , _inputs      :: ModMap a                  -- ^ 'Modification's that have to be processed in the next tick.
+  , _customState :: s                         -- ^ Custom State, e. g. for graphics. Use @()@ if not used.
+  , _world       :: World a                   -- ^ All objects.
+  , _highestId   :: Id                        -- ^ Highest 'Id' used in 'World'. This is updated by 'addObject'
+                                              --   in Order to prevent accidental overwrites.
+  }
 
 makeLenses ''Grav2tyState