generalize state update

2 files changed, 28 insertions, 31 deletions

diff --git a/lib/Grav2ty/Control.hs b/lib/Grav2ty/Control.hs
index 776c3ac..698950b 100644
--- a/lib/Grav2ty/Control.hs
+++ b/lib/Grav2ty/Control.hs
@@ -8,6 +8,8 @@ module Grav2ty.Control
   , Modification (..)
   , zeroModification
   , modAcc, modRot
+  , ExtractFunction (..)
+  , updateState
   ) where
 
 import Grav2ty.Simulation
@@ -61,3 +63,14 @@ applyControls cs obj@Dynamic {} =
                  , objectAcc = angle rot ^* acc
                  }
 
+type ExtractFunction a b = Object a -> (State a b -> State a b)
+
+updateState :: (Floating a, Ord a) => a -> ExtractFunction a b
+                -> State a b -> State a b
+updateState t extract state = set world newWorld . updateState $ state
+  where oldWorld = state^.world
+        (newWorld, updateState) = tailCall oldWorld ([], id)
+        tailCall [] acc = acc
+        tailCall (x:xs) (nw, f) = tailCall xs (updateObject' x : nw, extract x . f)
+        updateObject' obj = updateObject t (gravitationForces oldWorld obj)
+          . applyControls (state^.control) $ obj
diff --git a/src/Main.hs b/src/Main.hs
index ba64582..ea87c7f 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -70,41 +70,25 @@ eventHandler (EventKey key Down _ _) state = action state
         accStep = 1
         rotStep = pi / 10
         scaleStep = 0.05
-        action = case key of
-                   SpecialKey KeyUp -> updateLocalMod modAcc (+ accStep)
-                   SpecialKey KeyDown -> updateLocalMod modAcc (subtract accStep)
-                   SpecialKey KeyLeft -> updateLocalMod modRot (+ rotStep)
-                   SpecialKey KeyRight -> updateLocalMod modRot (subtract rotStep)
-                   Char 'c' -> over (graphics.glossCenterView) not
-                   Char '+' -> over (graphics.glossViewPortScale) (+ scaleStep)
-                   Char '-' -> over (graphics.glossViewPortScale) (subtract scaleStep)
-                   _ -> id
+        action =
+          case key of
+            SpecialKey KeyUp -> updateLocalMod modAcc (+ accStep)
+            SpecialKey KeyDown -> updateLocalMod modAcc (subtract accStep)
+            SpecialKey KeyLeft -> updateLocalMod modRot (+ rotStep)
+            SpecialKey KeyRight -> updateLocalMod modRot (subtract rotStep)
+            Char 'c' -> over (graphics.glossCenterView) not
+            Char '+' -> over (graphics.glossViewPortScale) (+ scaleStep)
+            Char '-' -> over (graphics.glossViewPortScale) (subtract scaleStep)
+            _ -> id
 eventHandler (EventResize vp) state = set (graphics.glossViewPort) vp state
 eventHandler _ s = s
 
--- TODO make code more generic and move to Grav2ty.Simulation
 updateWorld :: Float -> State Float GlossState -> State Float GlossState
-updateWorld timeStep (State ctrl g world) = State ctrl
-  (set glossViewPortCenter (fromMaybe (0, 0) center) g) uncollidedWorld
-  where uncollidedWorld = foldl collideFolder [] newWorld
-        collideFolder res obj =
-          if isDynamic obj && collisionWithWorld newWorld obj
-             then res
-             else obj : res
-        (newWorld, center) = updateAndExtract world extractCenter ([], Nothing)
-        extractCenter :: Object Float -> Maybe (Float, Float)
-                      -> Maybe (Float, Float)
-        extractCenter o@(Dynamic { objectMod = LocalMod }) _ =
-          Just . vectorToPoint . objectLoc $ o
-        extractCenter _ c = c
-        updateAndExtract :: World Float -> (Object Float -> i -> i)
-                         -> (World Float, i) -> (World Float, i)
-        updateAndExtract [] f acc = acc
-        updateAndExtract (x:xs) f (xs', i) = updateAndExtract xs f
-          (updateObject' x : xs', f x i)
-        updateObject' :: Object Float -> Object Float
-        updateObject' obj = updateObject timeStep (gravitationForces world obj)
-          . applyControls ctrl $ obj
+updateWorld ts state = updateState ts extract state
+  where extract obj@Dynamic { objectMod = LocalMod } = set
+          (graphics.glossViewPortCenter)
+          (vectorToPoint . objectLoc $ obj)
+        extract _ = id
 
 initialWorld :: Fractional a => State a GlossState
 initialWorld = State