split grav2ty into library and executable

this keeps simulation and game logic separate from graphical implementation,
allowing for future switch of graphical backend or a client-server
multiplayer mode.

5 files changed, 176 insertions, 139 deletions

diff --git a/grav2ty.cabal b/grav2ty.cabal
index 292cc5e..a8b45f3 100644
--- a/grav2ty.cabal
+++ b/grav2ty.cabal
@@ -9,19 +9,31 @@ version:             0.1.0.0
 -- bug-reports:
 license:             GPL-3.0-only
 license-file:        LICENSE
-author:              lukas
+author:              sternenseemann
 maintainer:          git@lukasepple.de
 -- copyright:
 category:            Game
-extra-source-files:  CHANGELOG.md
+extra-source-files:  CHANGELOG.md, README.md
+
+library grav2ty-lib
+  exposed-modules:     Grav2ty.Simulation
+                     , Grav2ty.Control
+  -- other-modules:
+  -- other-extensions:
+  build-depends:       base ^>=4.12.0.0
+                     , containers ^>=0.6.0.1
+                     , linear
+  hs-source-dirs:      lib
+  default-language:    Haskell2010
 
 executable grav2ty
   main-is:             Main.hs
   -- other-modules:
   -- other-extensions:
   build-depends:       base ^>=4.12.0.0
-                     , linear
-                     , lens
+                     , containers ^>=0.6.0.1
                      , gloss
+                     , linear
+                     , grav2ty-lib
   hs-source-dirs:      src
   default-language:    Haskell2010
diff --git a/grav2ty.nix b/grav2ty.nix
index 17eb20b..6d15448 100644
--- a/grav2ty.nix
+++ b/grav2ty.nix
@@ -1,10 +1,12 @@
-{ mkDerivation, base, gloss, lens, linear, stdenv }:
+{ mkDerivation, base, containers, gloss, linear, stdenv }:
 mkDerivation {
   pname = "grav2ty";
   version = "0.1.0.0";
   src = ./.;
   isLibrary = false;
   isExecutable = true;
-  executableHaskellDepends = [ base gloss lens linear ];
+  libraryHaskellDepends = [ base containers linear ];
+  executableHaskellDepends = [ base containers gloss linear ];
+  doHaddock = false;
   license = stdenv.lib.licenses.gpl3;
 }
diff --git a/lib/Grav2ty/Control.hs b/lib/Grav2ty/Control.hs
new file mode 100644
index 0000000..13229b4
--- /dev/null
+++ b/lib/Grav2ty/Control.hs
@@ -0,0 +1,36 @@
+module Grav2ty.Control where
+
+import Grav2ty.Simulation
+
+import Linear.V2
+import Linear.Vector
+import qualified Data.Map as Map
+
+data State a
+  = State
+  { control :: ControlState a
+  , world   :: World a
+  } deriving (Show, Eq)
+
+data ControlState a
+  = ControlState
+  { controlInputs :: Map.Map Modifier (a, 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.
+  } deriving (Show, Eq)
+
+applyControls :: Floating a => ControlState a -> Object a -> Object a
+applyControls _ obj@Static {} = obj
+applyControls cs obj@Dynamic {} =
+  case objectMod obj of
+    NoMod -> obj
+    LocalMod -> case Map.lookup LocalMod (controlInputs cs) of
+               Nothing -> obj
+               Just (rot, acc) -> obj
+                 { objectRot = rot
+                 , objectAcc = angle rot ^* acc
+                 }
+
diff --git a/lib/Grav2ty/Simulation.hs b/lib/Grav2ty/Simulation.hs
new file mode 100644
index 0000000..9ecee21
--- /dev/null
+++ b/lib/Grav2ty/Simulation.hs
@@ -0,0 +1,83 @@
+module Grav2ty.Simulation where
+
+import Linear.Metric (norm, distance)
+import Linear.V2
+import Linear.Vector
+
+data Hitbox a
+  = HMultiple [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 = HMultiple
+  [ 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
+
+data Modifier
+  = NoMod
+  | LocalMod
+  deriving (Eq, Ord, Show)
+
+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.
+  }
+  | Static
+  { objectHitbox :: Hitbox a -- ^ See above.
+  , objectRot    :: a        -- ^ See above.
+  , objectMass   :: a        -- ^ See above.
+  , objectLoc    :: V2 a     -- ^ See above.
+  } deriving (Show, Eq, Ord)
+
+type World a = [Object a]
+
+separated :: (Floating a, Ord a) => Object a -> Object a -> Bool
+separated a b = distance (objectLoc a) (objectLoc b) > 3
+
+gravitationForce :: Floating a => Object a -> Object a -> V2 a
+gravitationForce a b = (gravityConst *
+  ((objectMass a * objectMass b) / (absDistance ** 2)))
+  *^ (distance ^/ absDistance)
+  where gravityConst = 6.67408e-11
+        distance = objectLoc b - objectLoc a
+        absDistance = norm distance
+
+gravitationForces :: (Ord a, Floating a) => [Object a] -> Object a -> [V2 a]
+gravitationForces []     _   = []
+gravitationForces (w:ws) obj =
+  if separated obj w
+     then gravitationForce obj w : gravitationForces ws obj
+     else gravitationForces ws obj
+
+updateObject :: Fractional a =>  a -> [V2 a] -> Object a -> Object a
+updateObject _ _ obj@Static {} = obj
+updateObject timeStep forces obj@Dynamic {} = obj
+    { objectLoc   = objectLoc obj + (objectSpeed obj ^* timeStep)
+    , objectSpeed = objectSpeed obj +
+      (((sum forces ^/ objectMass obj) + objectAcc obj) ^* timeStep)
+    }
+
diff --git a/src/Main.hs b/src/Main.hs
index 641993b..8e20246 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -1,102 +1,18 @@
 module Main where
 
-import Control.Lens
-import Debug.Trace
-import Linear.Metric (norm, distance)
+import Grav2ty.Simulation
+import Grav2ty.Control
+
 import Linear.V2
-import Linear.Vector
+import Data.Maybe
+import qualified Data.Map as Map
 
 import Graphics.Gloss
 import Graphics.Gloss.Interface.Pure.Game
 
-fps :: Num a => a
-fps = 200
-
-data Hitbox a
-  = HLine
-  { lineStart  :: V2 a
-  , lineEnd    :: V2 a
-  }
-  | HMultiple [Hitbox a]
-  | HCircle
-  { circleLoc    :: V2 a
-  , circleRadius :: a
-  } deriving (Eq, Show, Ord)
-
-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.
-  , objectPlayer :: Bool      -- ^ Wether the object is controlled by the player
-  }
-  | Static
-  { objectHitbox :: Hitbox a
-  , objectRot    :: a
-  , objectMass   :: a
-  , objectLoc    :: V2 a
-  } deriving (Show, Eq, Ord)
-
-isStatic :: Object a -> Bool
-isStatic Static {} = True
-isStatic _         = False
-
-isDynamic :: Object a -> Bool
-isDynamic Dynamic {} = True
-isDynamic _          = False
-
-gravitationForce :: Floating a => Object a -> Object a -> V2 a
-gravitationForce a b = (gravityConst *
-  ((objectMass a * objectMass b) / (absDistance ** 2)))
-  *^ (distance ^/ absDistance)
-  where gravityConst = 6.67408e-11
-        distance = objectLoc b - objectLoc a
-        absDistance = norm distance
-
-separated :: (Floating a, Ord a) => Object a -> Object a -> Bool
-separated a b = distance (objectLoc a) (objectLoc b) > 3
-
-gravitationForces :: (Ord a, Floating a) => [Object a] -> Object a -> [V2 a]
-gravitationForces []     _   = []
-gravitationForces (w:ws) obj =
-  if separated obj w
-     then gravitationForce obj w : gravitationForces ws obj
-     else gravitationForces ws obj
-
-updateObject :: Fractional a =>  a -> [V2 a] -> Object a -> Object a
-updateObject _ _ obj@Static {} = obj
-updateObject timeStep forces obj@Dynamic {} = obj
-    { objectLoc   = objectLoc obj + (objectSpeed obj ^* timeStep)
-    , objectSpeed = objectSpeed obj +
-      (((sum forces ^/ objectMass obj) + objectAcc obj) ^* timeStep)
-    }
-
-applyPlayerState :: Floating a => PlayerState a -> Object a -> Object a
-applyPlayerState _ obj@Static {} = obj
-applyPlayerState _ obj@Dynamic { objectPlayer = False} = obj
-applyPlayerState ps obj@Dynamic { objectPlayer = True} = obj
-  { objectRot = shipRot ps
-  , objectAcc = angle (shipRot ps) ^* shipAcc ps
-  }
-
 vectorToPoint :: V2 a -> (a, a)
 vectorToPoint (V2 x y) = (x, y)
 
-renderObject :: Object Float -> Picture
-renderObject obj = translate x y . rot . renderHitbox . objectHitbox $ obj
-  where (V2 x y)  = objectLoc obj
-        rot       =  rotate (clockwise . toDegree . objectRot $ obj)
-        toDegree  = (*) (360 / (2 * pi))
-        clockwise = (*) (-1)
-
 renderHitbox :: Hitbox Float -> Picture
 renderHitbox box =  Color white $
   case box of
@@ -104,67 +20,55 @@ renderHitbox box =  Color white $
     HLine a b -> Line . map vectorToPoint $ [a, b]
     HMultiple boxes -> Pictures $ map renderHitbox boxes
 
-centeredCircle :: Num a => a -> Hitbox a
-centeredCircle r = HCircle (V2 0 0) r
-
-data PlayerState a
-  = PlayerState
-  { shipRot :: a -- ^ Radial angle the ship is rotated at.
-  , shipAcc :: a -- ^ Current acceleration of the ship.
-  } deriving (Show, Eq)
-
-data State a
-  = State
-  { player :: PlayerState a
-  , world  :: [Object a]
-  } deriving (Show, Eq)
-
-shipHitbox :: Num a => Hitbox a
-shipHitbox = HMultiple
-  [ HLine (V2 (-10) (-5)) (V2 (-10) 5)
-  , HLine (V2 (-10) (-5)) (V2 10 0)
-  , HLine (V2 (-10) 5)    (V2 10 0)
-  ]
-
-initialWorld :: Fractional a => State a
-initialWorld = State (PlayerState 0 0)
-  [ Dynamic shipHitbox 0 10000 (V2 200 0) (V2 0 0) (V2 0 0) True
-  , Static (centeredCircle 80) 0 moonMass (V2 0 0)
---  , Static (centeredCircle 40) 0 (0.5 * moonMass) (V2 250 120)
-  ]
-  where moonMass = 8e14
+renderObject :: Object Float -> Picture
+renderObject obj = translate x y . rot . renderHitbox . objectHitbox $ obj
+  where (V2 x y)  = objectLoc obj
+        rot       =  rotate (clockwise . toDegree . objectRot $ obj)
+        toDegree  = (*) (360 / (2 * pi))
+        clockwise = (*) (-1)
 
-renderUi :: Show a => PlayerState a -> Picture
-renderUi ps = translate (-350) (350) . scale 0.3 0.3 . Color green . Text . show $ shipAcc ps
+renderUi :: (Show a, Num a) => ControlState a -> Picture
+renderUi = translate (-350) (350) . scale 0.3 0.3 . Color green . Text . show
+  . fromMaybe 0 . fmap snd . Map.lookup LocalMod . controlInputs
 
 renderWorld :: State Float -> Picture
 renderWorld (State ps world) = Pictures
   . (:) (renderUi ps)
   . map renderObject $ world
 
+eventHandler :: Floating a => Event -> State a -> State a
+eventHandler (EventKey key Down _ _) state = state
+  { control = ControlState . Map.alter f LocalMod . controlInputs . control $ state
+  }
+    where f = Just . f' . fromMaybe (0, 0)
+          f' = case key of
+                SpecialKey KeyUp -> \(rot, acc) -> (rot, acc + 1)
+                SpecialKey KeyDown -> \(rot, acc) -> (rot, acc - 1)
+                SpecialKey KeyLeft -> \(rot, acc) -> (rot + 0.1, acc)
+                SpecialKey KeyRight -> \(rot, acc) -> (rot - 0.1, acc)
+                _                   -> id
+eventHandler _ s = s
+
 updateWorld :: Float -> State Float -> State Float
-updateWorld timeStep (State ps world) = State ps $ map
+updateWorld timeStep (State ctrl world) = State ctrl $ map
   (\obj ->
     updateObject timeStep (gravitationForces world obj) .
-      applyPlayerState ps $ obj)
+      applyControls ctrl $ obj)
   world
 
-eventHandler :: Floating a => Event -> State a -> State a
-eventHandler (EventKey key Down _ _) state = state
-  { player = case key of
-               SpecialKey KeyUp -> (player state) { shipAcc = shipAcc (player state) + 1 }
-               SpecialKey KeyDown -> (player state) { shipAcc = shipAcc (player state) - 1 }
-               SpecialKey KeyLeft -> (player state) { shipRot = shipRot (player state) + 0.1 }
-               SpecialKey KeyRight -> (player state) { shipRot = shipRot (player state) - 0.1 }
-               _                   -> player state
-  }
-eventHandler _ s = s
+initialWorld :: Fractional a => State a
+initialWorld = State (ControlState Map.empty)
+  [ Dynamic shipHitbox 0 10000 (V2 200 0) (V2 0 0) (V2 0 0) LocalMod
+  , Static (centeredCircle 80) 0 moonMass (V2 0 0)
+--  , Static (centeredCircle 40) 0 (0.5 * moonMass) (V2 250 120)
+  ]
+  where moonMass = 8e14
 
 main :: IO ()
 main = play
   (InWindow "grav2ty" (800, 800) (0,0))
   black
-  fps
+  300
   initialWorld
   renderWorld
   eventHandler