re-add collision and add time scaling

4 files changed, 38 insertions, 16 deletions

diff --git a/README.md b/README.md
index 4b6e7fb..5e324a6 100644
--- a/README.md
+++ b/README.md
@@ -10,6 +10,7 @@ the most realistic asteroids-like game in existence.
 * `left`/`right`: rotate ship (counter)-clockwise
 * `c`: toggle centered view
 * `+`/`-`: zoom in/out
+* `,`/`.`: slow time down / speed it up
 
 ## roadmap
 
@@ -18,7 +19,7 @@ the most realistic asteroids-like game in existence.
 - [x] collision detection
 - [ ] make measurements more realistic
 - [x] allow for zooming the viewport
-- [ ] time scaling / fast forward
+- [x] time scaling / fast forward
 - [ ] rework HUD, log additional info to console
 - [ ] cosmetics (improved models, stars, …)
 - [ ] projectiles & targets
diff --git a/lib/Grav2ty/Control.hs b/lib/Grav2ty/Control.hs
index 698950b..266db8d 100644
--- a/lib/Grav2ty/Control.hs
+++ b/lib/Grav2ty/Control.hs
@@ -65,12 +65,15 @@ applyControls cs obj@Dynamic {} =
 
 type ExtractFunction a b = Object a -> (State a b -> State a b)
 
-updateState :: (Floating a, Ord a) => a -> ExtractFunction a b
+updateState :: (RealFloat 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)
+        tailCall (x:xs) (nw, f) = tailCall xs
+          (if coll x then nw else updateObject' x : nw, extract x . f)
+        coll obj = isDynamic obj && collisionWithWorld oldWorld obj
+        scaledT = state^.control^.ctrlTimeScale * t
+        updateObject' obj = updateObject scaledT (gravitationForces oldWorld obj)
           . applyControls (state^.control) $ obj
diff --git a/lib/Grav2ty/Simulation.hs b/lib/Grav2ty/Simulation.hs
index 06aa8de..bba3169 100644
--- a/lib/Grav2ty/Simulation.hs
+++ b/lib/Grav2ty/Simulation.hs
@@ -143,9 +143,10 @@ collisionWithWorld world obj = any (\obj' ->
   obj /= obj' && collision (realHitbox obj) (realHitbox obj')) world
 
 data Modifier
-  = NoMod
-  | LocalMod
-  deriving (Eq, Ord, Show)
+  = NoMod            -- ^ Not modified, purely physics based.
+  | LocalMod         -- ^ Object is modified by local client / player.
+  | External Integer -- ^ Object is modified by an external source / other players.
+  deriving(Eq, Ord, Show)
 
 data Object a
   = Dynamic
diff --git a/src/Main.hs b/src/Main.hs
index ea87c7f..264b330 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -7,10 +7,12 @@ import Grav2ty.Control
 
 import Control.Lens
 import Linear.V2
+import Data.Fixed (mod')
 import Data.Maybe
 import Data.Tuple (uncurry)
 import qualified Data.Map as Map
 import Data.Map.Lens
+import Text.Printf
 
 import Graphics.Gloss
 import Graphics.Gloss.Data.ViewPort
@@ -42,11 +44,13 @@ renderHitbox box =  Color white $
 renderObject :: Object Float -> Picture
 renderObject obj = renderHitbox . realHitbox $ obj
 
-renderUi :: (Show a, Num a) => State a GlossState -> Picture
+renderUi :: (PrintfArg a, Num a) => State a GlossState -> Picture
 renderUi state = (uncurry translate) (homBimap ((+ 50) . (* (-1)) . (/ 2) . fromIntegral)
-    . view (graphics . glossViewPort) $ state)
-  . scale 0.3 0.3 . Color green . Text . show
-  . fromMaybe 0 $ state^?control.ctrlInputs.at LocalMod ._Just.modAcc
+  . view (graphics . glossViewPort) $ state)
+  . scale 0.2 0.2 . Color green . Text $ uiText
+  where uiText = printf "Acceleration: %.0f TimeScale: %.1f" acc timeScale
+        acc = fromMaybe 0 $ state^?control.ctrlInputs.at LocalMod ._Just.modAcc
+        timeScale = state^.control.ctrlTimeScale
 
 renderStars :: (Float, Float) -> Picture
 renderStars center = undefined
@@ -62,7 +66,16 @@ renderGame state = Pictures [ renderUi  state, applyViewPort objs ]
           0
           (state^.graphics.glossViewPortScale)
 
-eventHandler :: (Show a, Floating a) => Event -> State a GlossState -> State a GlossState
+boundSub :: (Ord a, Num a) => a -> a -> a -> a
+boundSub min a x = if res < min then min else res
+  where res = x - a
+
+boundAdd :: (Ord a, Num a) => a -> a -> a -> a
+boundAdd max a x = if res > max then max else res
+  where res = x + a
+
+eventHandler :: (Show a, Ord a, Real a, Floating a) => Event
+             -> State a GlossState -> State a GlossState
 eventHandler (EventKey key Down _ _) state = action state
   where updateLocalMod :: Lens' (Modification a) a -> (a -> a)
                        -> State a GlossState -> State a GlossState
@@ -70,15 +83,19 @@ eventHandler (EventKey key Down _ _) state = action state
         accStep = 1
         rotStep = pi / 10
         scaleStep = 0.05
+        timeStep = 0.2
+        mod2pi = flip mod' (2 * pi)
         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)
+            SpecialKey KeyDown -> updateLocalMod modAcc (boundSub 0 accStep)
+            SpecialKey KeyLeft -> updateLocalMod modRot (mod2pi . (+ rotStep))
+            SpecialKey KeyRight -> updateLocalMod modRot (mod2pi . (subtract rotStep))
             Char 'c' -> over (graphics.glossCenterView) not
             Char '+' -> over (graphics.glossViewPortScale) (+ scaleStep)
             Char '-' -> over (graphics.glossViewPortScale) (subtract scaleStep)
+            Char '.' -> over (control.ctrlTimeScale) (+ timeStep)
+            Char ',' -> over (control.ctrlTimeScale) (boundSub 0 timeStep)
             _ -> id
 eventHandler (EventResize vp) state = set (graphics.glossViewPort) vp state
 eventHandler _ s = s
@@ -97,7 +114,7 @@ initialWorld = State
   [ Dynamic shipHitbox 0 10000 (V2 200 0) (V2 0 0) (V2 0 0) LocalMod
   , Dynamic (centeredCircle 10) 0 5000 (V2 0 200) (V2 15 0) (V2 0 0) NoMod
   , Static (centeredCircle 80) 0 moonMass (V2 0 0)
---  , Static (centeredCircle 40) 0 (0.5 * moonMass) (V2 250 120)
+--  , Static (centeredCircle 40) 0 (0.5 * moonMass) (V2 250 250)
   ]
   where moonMass = 8e14