internal rework of state handling and world update

* moved internal types and essential functions to Grav2ty.Core
* store Objects in a Map and give them an Id
* update the World using a StateT Monad instead of State-updating
  functions.
  This makes Grav2ty.Control much cleaner (although it can probably
  be improved), but Main uglier. I'll rework Main eventually.
* Make RelGraph use Ids instead of full Objects. Still missing
  new props for this behaviour.
* Use StateT actions as hooks instead of ExtractFunctions
* Rework State, renamed to Grav2tyState
* Remove TimeScaling (not applicable for planned multiplayer mode)

9 files changed, 294 insertions, 227 deletions

diff --git a/README.md b/README.md
index eca024c..5b0856b 100644
--- a/README.md
+++ b/README.md
@@ -10,7 +10,6 @@ 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
 * `space`: fire a projectile
 
 ## roadmap
@@ -27,7 +26,11 @@ the most realistic asteroids-like game in existence.
 - [x] projectiles
   - [ ] Limit firerate
   - [x] make projectiles self-destruct
+- [ ] performance improvements
+  - [ ] don't calculate gravity to every little object
+  - [ ] don't do collision detection at a safe distance
 - [ ] multi player support
+- [ ] Prevent library user from creating a broken state (by hiding lenses etc. if possible)
 - [ ] cosmetics (improved models, stars, …)
 - [ ] switch rendering engine
 - [ ] orbit visualization / prediction
diff --git a/default.nix b/default.nix
index e933c4d..2555fb8 100644
--- a/default.nix
+++ b/default.nix
@@ -6,4 +6,5 @@ let pkgs = import <nixpkgs> {};
         });
       };
     };
-in profiled.callPackage ./grav2ty.nix { }
+    drv = profiled.callPackage ./grav2ty.nix { };
+in if pkgs.lib.inNixShell then drv.env else drv
diff --git a/grav2ty.cabal b/grav2ty.cabal
index fc0ef22..97330c1 100644
--- a/grav2ty.cabal
+++ b/grav2ty.cabal
@@ -19,7 +19,8 @@ extra-source-files:  CHANGELOG.md
                    , doc/grav2ty-first-commit.png
 
 library grav2ty-lib
-  exposed-modules:     Grav2ty.Simulation
+  exposed-modules:     Grav2ty.Core
+                     , Grav2ty.Simulation
                      , Grav2ty.Control
                      , Grav2ty.Util.RelGraph
   -- other-extensions:
@@ -27,6 +28,7 @@ library grav2ty-lib
                      , containers ^>=0.6.0.1
                      , linear ^>=1.20.8
                      , lens ^>= 4.17.1
+                     , transformers^>=0.5.6.2
   hs-source-dirs:      lib
   default-language:    Haskell2010
 
@@ -39,6 +41,7 @@ executable grav2ty
                      , gloss ^>=1.13.0.1
                      , linear ^>=1.20.8
                      , lens ^>= 4.17.1
+                     , transformers^>=0.5.6.2
                      , grav2ty-lib
   hs-source-dirs:      src
   default-language:    Haskell2010
diff --git a/grav2ty.nix b/grav2ty.nix
index 4c27560..6c416ff 100644
--- a/grav2ty.nix
+++ b/grav2ty.nix
@@ -1,19 +1,20 @@
-{ mkDerivation, base, containers, gloss, lens, linear, stdenv
-, tasty, tasty-quickcheck
+{ mkDerivation, aeson, base, bytestring, containers, flat, gloss
+, lens, linear, stdenv, tasty, tasty-quickcheck
 }:
 mkDerivation {
   pname = "grav2ty";
   version = "0.1.0.0";
   src = ./.;
-  isLibrary = true;
+  isLibrary = false;
   isExecutable = true;
-  libraryHaskellDepends = [ base containers lens linear ];
+  libraryHaskellDepends = [
+    aeson base bytestring containers flat lens linear
+  ];
   executableHaskellDepends = [ base containers gloss lens linear ];
   testHaskellDepends = [ base tasty tasty-quickcheck ];
-  doHaddock = true;
-  doCheck = true;
   enableLibraryProfiling = true;
   enableExecutableProfiling = true;
+  doHaddock = true;
   description = "a 2d space (ship) game with realistic physics-based gameplay";
   license = stdenv.lib.licenses.gpl3;
 }
diff --git a/lib/Grav2ty/Control.hs b/lib/Grav2ty/Control.hs
index 0fab401..932f450 100644
--- a/lib/Grav2ty/Control.hs
+++ b/lib/Grav2ty/Control.hs
@@ -1,64 +1,19 @@
-{-# LANGUAGE TemplateHaskell #-}
-module Grav2ty.Control
-  ( State (..)
-  , control, graphics, world
-  , ControlState (..)
-  , ctrlInputs, ctrlTimeScale, ctrlTick
-  , applyControls
-  , Modification (..)
-  , zeroModification
-  , modAcc, modRot, modFire
-  , ExtractFunction (..)
-  , updateState
-  ) where
+{-# LANGUAGE BlockArguments #-}
+module Grav2ty.Control (processTick) where
 
+import Grav2ty.Core
 import Grav2ty.Simulation
 import Grav2ty.Util.RelGraph
 
 import Control.Lens
-import Data.Foldable
+import Control.Monad (when, unless)
+import Data.Foldable (traverse_)
+import Data.Map (Map (..))
 import Data.Maybe
-import Data.Sequence ((<|), (|>), (><))
-import qualified Data.Sequence as S
 import Linear.V2
 import Linear.Vector
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as M
 
-data Modification a
-  = Modification
-  { _modRot :: a        -- ^ Rotation (angle in radiant) set by the modification
-  , _modAcc :: a        -- ^ Acceleration set by the modification
-  , _modFire :: Integer -- ^ Set to tick a projectile should be fired at
-  } deriving (Show, Eq, Ord)
-
-makeLenses ''Modification
-
-zeroModification :: Num a => Modification a
-zeroModification = Modification 0 0 (-1)
-
-data ControlState a
-  = ControlState
-  { _ctrlInputs :: Map.Map Modifier (Modification a)
-  -- ^ Map containing the Modifier and the modified values, mainly the
-  -- Radial angle the object is rotated at and the current acceleration
-  -- of the ship.
-  , _ctrlTimeScale :: a
-  -- ^ Scaling of time allowing for the simulation to be sped up or slowed down
-  , _ctrlTick :: Integer
-  -- ^ Current tick. Ticks are not of constant length, but depend on time scale
-  --   and the simulation steps per second.
-  } deriving (Show, Eq)
-
-makeLenses ''ControlState
-
-data State a g
-  = State
-  { _control  :: ControlState a
-  , _graphics :: g
-  , _world    :: World a
-  } deriving (Show, Eq)
-
-makeLenses ''State
 
 projectile :: RealFloat a => (V2 a, V2 a) -> Integer -> Object a -> Object a
 projectile (pos,speed) tick ship =
@@ -66,52 +21,54 @@ projectile (pos,speed) tick ship =
   where pPos = objectLoc ship + rotateV2 (objectRot ship) pos
         pSpeed = (15 * rotateV2 (objectRot ship) speed) + objectSpeed ship
 
-applyControls :: RealFloat a => ControlState a -> Object a -> World a
-applyControls _ obj@Static {} = S.singleton obj
-applyControls cs obj@Dynamic {} =
-  if isNothing life || fromJust life >= cs^.ctrlTick
-     then moddedObjs
-     else S.empty
-  where life = objectLife obj
-        moddedObjs =
-          case objectMod obj of
-            NoMod -> S.singleton obj
-            LocalMod ->
-              case Map.lookup (objectMod obj) (cs^.ctrlInputs) of
-                Nothing -> S.singleton obj
-                Just (Modification rot acc fire) ->
-                  let newObj = obj
-                       { objectRot = rot
-                       , objectAcc = angle rot ^* acc
-                       }
-                      -- Note: we are relying on laziness here: if objectCannon
-                      -- is Nothing the pObj never gets evaluated.
-                      pObj = projectile (fromJust . objectCannon $ obj) (cs^.ctrlTick) newObj
-                   in if cs^.ctrlTick /= fire || isNothing (objectCannon obj)
-                                 then S.singleton newObj
-                                 else S.fromList [pObj, newObj]
+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…)
+
+            -- 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
+
+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 =
+  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
+
+processTick :: (Monad m, RealFloat a)
+            => (Object a -> Grav2ty a g m ())
+            -> Grav2ty a g m ()
+processTick objHook = do
+  oldWorld <- use world
+  let objRel = objectRelGraph oldWorld
 
-type ExtractFunction a b = Object a -> Maybe (State a b -> State a b)
+  use world >>= M.foldlWithKey' (\action id obj ->
+    action >> processObject oldWorld objRel objHook id obj) (pure ())
 
-updateState :: (Show a, RealFloat a, Ord a) => a -> ExtractFunction a b
-                -> State a b -> State a b
-updateState t extract state =
-  over (control.ctrlTick) (+ 1)
-  . set world newWorld
-  . fromMaybe id updateState' $ state
-  where oldWorld = state^.world
-        (newWorld, updateState') = foldl' updateAndExtract (S.empty, Nothing) oldWorld
-        updateAndExtract acc@(seq, f) x =
-          if isDynamic x && (anyFrom _relColl x objectRel == Just True)
-             then acc
-             else let updated = updateObject' x
-                   in (updated >< seq, foldl' chainFun f (fmap extract updated))
-        chainFun x@(Just _) f@(Just _) = (.) <$> x <*> f
-        chainFun Nothing f = f
-        chainFun x Nothing = x
-        objectRel = objectRelGraph oldWorld
-        getForce obj = foldlFrom' (\f r -> f + _relForce r) (V2 0 0) obj objectRel
-        scaledT = state^.control^.ctrlTimeScale * t
-        updateObject' obj =
-          fmap (updateObject scaledT (getForce obj))
-          . applyControls (state^.control) $ obj
+  tick %= (+1)
diff --git a/lib/Grav2ty/Core.hs b/lib/Grav2ty/Core.hs
new file mode 100644
index 0000000..0d8f215
--- /dev/null
+++ b/lib/Grav2ty/Core.hs
@@ -0,0 +1,153 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Grav2ty.Core
+  ( -- * Basic Types
+    Id (..)
+  , World (..)
+  -- ** Object
+  , Object (..)
+  , isDynamic
+  , Cannon (..)
+  , Modifier (..)
+  -- *** Hitboxes
+  , Hitbox (..)
+  , shipHitbox
+  , centeredCircle
+  -- ** Modification handling
+  , Modification (..)
+  , modAcc, modRot, modFire
+  , ModMap (..)
+  , zeroModification
+  -- * The Grav2ty Monad
+  , Grav2ty (..)
+  , setObject
+  , getObject
+  , addObject
+  , delObject
+  -- ** State
+  , Grav2tyState (..)
+  , tick, timePerTick, inputs, graphics, world, highestId
+  , Tick (..)
+  ) where
+
+import Control.Lens
+import Control.Monad.Trans.State.Strict
+import Data.Map.Strict (Map (..))
+import qualified Data.Map.Strict as M
+import Linear.V2
+
+type Id = Integer
+type Tick = Integer
+
+type World a = Map Id (Object a)
+
+data Modifier
+  = 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)
+
+-- | @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
+--   are disabled for the particular 'Object'.
+type Cannon a = Maybe (V2 a, V2 a)
+
+data Object a
+  = Dynamic
+  { objectHitbox :: Hitbox a      -- ^ hitbox of the object. Hitbox points at
+                                  --   (V2 0 0) will always be at the center of
+                                  --   the object
+  , objectRot    :: a             -- ^ Radial angle
+  , objectMass   :: a             -- ^ mass of the object in kg
+  , objectLoc    :: V2 a          -- ^ Current location of the object.
+  , objectSpeed  :: V2 a          -- ^ Current speed of the Object. Used for
+                                  --   simulation approximation
+  , objectAcc    :: V2 a          -- ^ Current static Acceleration of the object.
+                                  --   0 unless controlled by the player or
+                                  --   projectile.
+  , objectMod    :: Modifier      -- ^ If and how the Object can be modified
+                                  --   during the simulation.
+  , objectCannon :: Cannon a      -- ^ Point and Direction projectiles can or
+                                  --   can not be fired from.
+  , objectLife   :: Maybe Integer -- ^ Tick the Object will be destroyed at.
+  }
+  | Static
+  { objectHitbox :: Hitbox a -- ^ See above.
+  , objectRot    :: a        -- ^ See above.
+  , objectMass   :: a        -- ^ See above.
+  , objectLoc    :: V2 a     -- ^ See above.
+  } deriving (Show, Eq, Ord)
+
+-- | Wether the 'Object' is Dynamic, i. e. affected by physics
+isDynamic :: Object a -> Bool
+isDynamic Dynamic {} = True
+isDynamic _ = False
+
+data Hitbox a
+  = HCombined [Hitbox a]
+  | HLine
+  { lineStart  :: V2 a
+  , lineEnd    :: V2 a
+  }
+  | HCircle
+  { circleLoc    :: V2 a
+  , circleRadius :: a
+  } deriving (Eq, Show, Ord)
+
+-- | Example 'Hitbox' for a triangular, asteroids-like spaceship
+shipHitbox :: Num a => Hitbox a
+shipHitbox = HCombined
+  [ HLine (V2 (-10) (-5)) (V2 (-10) 5)
+  , HLine (V2 (-10) (-5)) (V2 10 0)
+  , HLine (V2 (-10) 5)    (V2 10 0)
+  ]
+
+-- | Generates a 'Hitbox' with a given radius centered around (0,0).
+centeredCircle :: Num a => a -> Hitbox a
+centeredCircle r = HCircle (V2 0 0) r
+
+data Modification a
+  = Modification
+  { _modRot :: a        -- ^ Rotation (angle in radiant) set by the modification
+  , _modAcc :: a        -- ^ Acceleration set by the modification
+  , _modFire :: Integer -- ^ Set to tick a projectile should be fired at
+  } deriving (Show, Eq, Ord)
+
+makeLenses ''Modification
+
+zeroModification :: Num a => Modification a
+zeroModification = Modification 0 0 (-1)
+
+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
+  , _highestId   :: Id
+  } deriving (Show, Eq)
+
+makeLenses ''Grav2tyState
+
+-- | The 'Grav2ty' Monad is a renamed 'StateT' holding a 'Grav2tyState'.
+type Grav2ty p g m a = StateT (Grav2tyState p g) m a
+
+addObject :: Monad m => Object a -> Grav2ty a g m ()
+addObject obj = setObject Nothing obj
+
+setObject :: Monad m => Maybe Id -> Object a -> Grav2ty a g m ()
+setObject id obj = do
+  id <- case id of
+          Just id -> pure id
+          Nothing -> do
+            highestId += 1
+            use highestId
+  world %= (M.insert id obj)
+
+getObject :: Monad m => Id -> Grav2ty a g m (Maybe (Object a))
+getObject id = use (world.at id)
+
+delObject :: Monad m => Id -> Grav2ty a g m ()
+delObject id = world %= M.delete id
diff --git a/lib/Grav2ty/Simulation.hs b/lib/Grav2ty/Simulation.hs
index 65bbf94..c6a12d6 100644
--- a/lib/Grav2ty/Simulation.hs
+++ b/lib/Grav2ty/Simulation.hs
@@ -2,60 +2,35 @@
 module Grav2ty.Simulation
   (
   -- * Objects
-    Object (..)
-  , Modifier (..)
-  , realHitbox
-  , isDynamic
-  , World (..)
+    realHitbox
   , updateObject
   , gravitationForce
-  , ObjRel (..)
-  , objectRelGraph
   -- * Hitboxes
-  , Hitbox (..)
-  , shipHitbox
-  , centeredCircle
   , translateHitbox
   , rotateHitbox
   , collision
   , objectCollision
+  -- * Object Relations
+  , ObjRelGraph (..)
+  , ObjRel (..)
+  , objectRelGraph
   -- * Exposed Utilities
   , rotateV2
   ) where
 
+import Grav2ty.Core
 import Grav2ty.Util.RelGraph
 
 import Control.Lens
 import Data.Complex
 import Data.Foldable
-import Data.Sequence (Seq (..))
-import qualified Data.Sequence as S
+import Data.Map.Strict (Map (..))
+import qualified Data.Map.Strict as M
 import Linear.Matrix
 import Linear.Metric (norm, distance)
 import Linear.V2
 import Linear.Vector
 
-data Hitbox a
-  = HCombined [Hitbox a]
-  | HLine
-  { lineStart  :: V2 a
-  , lineEnd    :: V2 a
-  }
-  | HCircle
-  { circleLoc    :: V2 a
-  , circleRadius :: a
-  } deriving (Eq, Show, Ord)
-
-shipHitbox :: Num a => Hitbox a
-shipHitbox = HCombined
-  [ HLine (V2 (-10) (-5)) (V2 (-10) 5)
-  , HLine (V2 (-10) (-5)) (V2 10 0)
-  , HLine (V2 (-10) 5)    (V2 10 0)
-  ]
-
-centeredCircle :: Num a => a -> Hitbox a
-centeredCircle r = HCircle (V2 0 0) r
-
 translateHitbox :: Num a => V2 a -> Hitbox a -> Hitbox a
 translateHitbox t (HLine a b) = HLine (a + t) (b + t)
 translateHitbox t (HCircle c r) = HCircle (c + t) r
@@ -156,50 +131,6 @@ objectCollision a b = a /= b &&
   ((objectLoc a == objectLoc b)
     || collision (realHitbox a) (realHitbox b))
 
-data Modifier
-  = 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)
-
--- | @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
---   are disabled for the particular 'Object'.
-type Cannon a = Maybe (V2 a, V2 a)
-
-data Object a
-  = Dynamic
-  { objectHitbox :: Hitbox a      -- ^ hitbox of the object. Hitbox points at
-                                  --   (V2 0 0) will always be at the center of
-                                  --   the object
-  , objectRot    :: a             -- ^ Radial angle
-  , objectMass   :: a             -- ^ mass of the object in kg
-  , objectLoc    :: V2 a          -- ^ Current location of the object.
-  , objectSpeed  :: V2 a          -- ^ Current speed of the Object. Used for
-                                  --   simulation approximation
-  , objectAcc    :: V2 a          -- ^ Current static Acceleration of the object.
-                                  --   0 unless controlled by the player or
-                                  --   projectile.
-  , objectMod    :: Modifier      -- ^ If and how the Object can be modified
-                                  --   during the simulation.
-  , objectCannon :: Cannon a      -- ^ Point and Direction projectiles can or
-                                  --   can not be fired from.
-  , objectLife   :: Maybe Integer -- ^ Tick the Object will be destroyed at.
-  }
-  | Static
-  { objectHitbox :: Hitbox a -- ^ See above.
-  , objectRot    :: a        -- ^ See above.
-  , objectMass   :: a        -- ^ See above.
-  , objectLoc    :: V2 a     -- ^ See above.
-  } deriving (Show, Eq, Ord)
-
-isDynamic :: Object a -> Bool
-isDynamic Dynamic {} = True
-isDynamic _ = False
-
-type World a = Seq (Object a)
-
 separated :: (Floating a, Ord a) => Object a -> Object a -> Bool
 separated a b = distance (objectLoc a) (objectLoc b) > 3
 
@@ -224,8 +155,10 @@ data ObjRel a = ObjRel
 
 makeLenses 'ObjRel
 
-objectRelGraph :: (RealFloat a, Ord a) => World a -> RelGraph (Object a) (ObjRel a)
-objectRelGraph = insertSeq rel emptyRel
+type ObjRelGraph a = RelGraph Id (ObjRel a)
+
+objectRelGraph :: (RealFloat a, Ord a) => World a -> ObjRelGraph a
+objectRelGraph = insertMapKey rel emptyRel
   where rel a b = let res = ObjRel (objectCollision a b) (gravity a b)
                    in (res, over relForce negated res)
         gravity a b = if separated a b
diff --git a/lib/Grav2ty/Util/RelGraph.hs b/lib/Grav2ty/Util/RelGraph.hs
index 589fb91..bf529b4 100644
--- a/lib/Grav2ty/Util/RelGraph.hs
+++ b/lib/Grav2ty/Util/RelGraph.hs
@@ -5,10 +5,13 @@ module Grav2ty.Util.RelGraph
   , emptyRel
   , insertRel
   , insertRelNoOv
-  , insertSeq
+  , insertMap
+  , insertMapKey
   , lookupRel
   , anyFrom
   , foldlFrom'
+  -- * Unused
+  , insertSeq
   -- * Props
   , prop_relCorrectness
   , prop_insertLookup
@@ -18,7 +21,7 @@ module Grav2ty.Util.RelGraph
 import Data.Foldable
 import Data.Map.Strict (Map (..))
 import Data.Maybe
-import Data.Sequence (Seq (..), (<|))
+import Data.Sequence (Seq (..))
 import qualified Data.Map.Strict as M
 
 -- | Representation of a directed Relation Graph.
@@ -62,6 +65,26 @@ insertSeq f g seq = ins seq g
         folder x g el = let (v, v') = f x el
                        in insertRelNoOv x el v v' g
 
+-- | Takes a 'Map' of Vertices and a function that returns the relations for
+--   the associated edge and inserts them into a 'RelGraph'
+insertMap :: Ord a => (a -> a -> (v, v)) -> RelGraph a v -> Map k a -> RelGraph a v
+insertMap f g map = M.foldl' ins g map
+  where ins g x = foldl' (folder x) g map
+        folder x g el = let (v, v') = f x el
+                       in insertRelNoOv x el v v' g
+
+-- | Takes a 'Map' of Vertices and a function that returns the relations for
+--   the associated edge and inserts them into a 'RelGraph'. Instead of using
+--   the vertices themselves we use the keys of the vertices as keys in
+--   the 'RelGraph' as well.
+--
+--   TODO: prop
+insertMapKey :: Ord k => (a -> a -> (v, v)) -> RelGraph k v -> Map k a -> RelGraph k v
+insertMapKey f g map = M.foldlWithKey' ins g map
+  where ins g k x = M.foldlWithKey' (folder k x) g map
+        folder k x g k' el = let (v, v') = f x el
+                       in insertRelNoOv k k' v v' g
+
 -- | Lookup the Relation between two given Vertices.
 lookupRel :: Ord a => a -> a -> RelGraph a v -> Maybe v
 lookupRel x y = (>>= (M.lookup y)) . M.lookup x . unRelGraph
diff --git a/src/Main.hs b/src/Main.hs
index 8fc4fcc..09f6d6d 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,18 +1,20 @@
 {-# LANGUAGE TemplateHaskell  #-}
 {-# LANGUAGE Rank2Types       #-}
+{-# LANGUAGE FlexibleContexts #-}
 module Main where
 
+import Grav2ty.Core
 import Grav2ty.Simulation
 import Grav2ty.Control
 
 import Control.Lens
 import Linear.V2
+import Control.Monad.Trans.State.Strict
 import Data.Fixed (mod')
 import Data.Foldable
 import Data.Maybe
-import qualified Data.Sequence as S
 import Data.Tuple (uncurry)
-import qualified Data.Map as Map
+import qualified Data.Map.Strict as M
 import Data.Map.Lens
 import Text.Printf
 
@@ -46,22 +48,22 @@ renderHitbox box =  Color white $
 renderObject :: Object Float -> Picture
 renderObject obj = renderHitbox . realHitbox $ obj
 
-renderUi :: (PrintfArg a, Num a) => State a GlossState -> Picture
+renderUi :: (PrintfArg a, Num a) => Grav2tyState a GlossState -> Picture
 renderUi state = (uncurry translate) (homBimap ((+ 50) . (* (-1)) . (/ 2) . fromIntegral)
-  . view (graphics . glossViewPort) $ state)
+  . (^. graphics.glossViewPort) $ state)
   . scale 0.2 0.2 . Color green . Text $ uiText
-  where uiText = printf "Acceleration: %.0f TimeScale: %.0f Tick: %d" acc timeScale tick
-        acc = fromMaybe 0 $ state^?control.ctrlInputs.at LocalMod ._Just.modAcc
-        timeScale = state^.control.ctrlTimeScale
-        tick = state^.control^.ctrlTick
+  where uiText = printf "Acceleration: %.0f Time/Tick: %f Tick: %d" acc tpt t
+        acc = fromMaybe 0 $ state^?inputs.at LocalMod ._Just.modAcc
+        t = state^.tick
+        tpt = state^.timePerTick
 
 renderStars :: (Float, Float) -> Picture
 renderStars center = undefined
 
-renderGame :: State Float GlossState -> Picture
+renderGame :: Grav2tyState Float GlossState -> Picture
 renderGame state = Pictures [ renderUi  state, applyViewPort objs ]
   where objs = Pictures . foldl' (\l x -> renderObject x : l) [] $ state^.world
-        applyViewPort = if state^.graphics . glossCenterView
+        applyViewPort = if state^.graphics.glossCenterView
                            then applyViewPortToPicture viewport
                            else id
         viewport = ViewPort
@@ -78,11 +80,11 @@ 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
+             -> Grav2tyState a GlossState -> Grav2tyState a GlossState
 eventHandler (EventKey key Down _ _) state = action state
   where updateLocalMod :: Lens' (Modification a) b -> (b -> b)
-                       -> State a GlossState -> State a GlossState
-        updateLocalMod l f = over (control.ctrlInputs.at LocalMod ._Just.l) f
+                       -> Grav2tyState a GlossState -> Grav2tyState a GlossState
+        updateLocalMod l f = over (inputs.at LocalMod ._Just.l) f
         accStep = 1
         rotStep = pi / 10
         scaleStep = 1.1
@@ -94,40 +96,31 @@ eventHandler (EventKey key Down _ _) state = action state
             SpecialKey KeyDown -> updateLocalMod modAcc (boundSub 0 accStep)
             SpecialKey KeyLeft -> updateLocalMod modRot (mod2pi . (+ rotStep))
             SpecialKey KeyRight -> updateLocalMod modRot (mod2pi . (subtract rotStep))
-            SpecialKey KeySpace -> updateLocalMod modFire (const $ state^.control.ctrlTick + 10)
+            SpecialKey KeySpace -> updateLocalMod modFire (const $ state^.tick + 10)
             Char 'c' -> over (graphics.glossCenterView) not
             Char '+' -> over (graphics.glossViewPortScale) (* scaleStep)
             Char '-' -> over (graphics.glossViewPortScale) (/ 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
 
-updateWorld :: Float -> State Float GlossState -> State Float GlossState
-updateWorld ts state = updateState ts extract state
-  where extract obj@Dynamic { objectMod = LocalMod } = Just $ set
-          (graphics.glossViewPortCenter)
-          (vectorToPoint . objectLoc $ obj)
-        extract _ = Nothing
-
-initialWorld :: Fractional a => State a GlossState
-initialWorld = State
-  (ControlState (Map.fromList [(LocalMod, zeroModification)]) 1 0)
-  (GlossState (800, 800) (0, 0) 1 True) $ S.fromList
-    [ Dynamic shipHitbox 0 10000 (V2 200 0) (V2 0 0) (V2 0 0) LocalMod (Just (V2 15 0, V2 1 0)) Nothing
-    , Dynamic (centeredCircle 10) 0 5000 (V2 0 200) (V2 15 0) (V2 0 0) NoMod Nothing Nothing
-    , Static (centeredCircle 80) 0 moonMass (V2 0 0)
---  , Static (centeredCircle 40) 0 (0.5 * moonMass) (V2 250 250)
-    ]
+updateWorld :: Float -> Grav2tyState Float GlossState -> Grav2tyState Float GlossState
+updateWorld ts state = snd . flip runState state $ timePerTick .= ts >> processTick hook
+  where hook obj@Dynamic { objectMod = LocalMod } =
+          graphics.glossViewPortCenter .= (vectorToPoint . objectLoc $ obj)
+        hook _ = pure ()
+
+initialWorld :: Fractional a => Grav2tyState a GlossState
+initialWorld = snd . flip runState (Grav2tyState 0 (1/300)
+  (M.fromList [(LocalMod, zeroModification)])
+  (GlossState (800, 800) (0, 0) 1 True)
+  mempty 0) $ do
+    addObject $ Dynamic shipHitbox 0 10000 (V2 200 0) (V2 0 0) (V2 0 0) LocalMod (Just (V2 15 0, V2 1 0)) Nothing
+    addObject $ Dynamic (centeredCircle 10) 0 5000 (V2 0 200) (V2 15 0) (V2 0 0) NoMod Nothing Nothing
+    addObject $ Static (centeredCircle 80) 0 moonMass (V2 0 0)
+--  addObject $ Static (centeredCircle 40) 0 (0.5 * moonMass) (V2 250 250)
   where moonMass = 8e14
 
-testWorld :: State Float GlossState
-testWorld = State
-  (ControlState (Map.empty) 1 0)
-  (GlossState (800, 800) (0, 0) 1 True) .  S.fromList $
-    map (\x -> Dynamic (centeredCircle 2) 0 1000000 (V2 0 (fromIntegral x * 5)) (V2 0 0) (V2 0 0) NoMod Nothing Nothing) [1..10]
-
 main :: IO ()
 main = play
   (InWindow "grav2ty" (initialWorld^.graphics.glossViewPort) (0,0))