From 3554254e5ed3c2d4719189b202382ed2454ba540 Mon Sep 17 00:00:00 2001 From: lukasepple Date: Sun, 6 Dec 2015 17:20:13 +0100 Subject: Add documentation for every function and type --- grav1ty.hs | 92 ++++++++++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 72 insertions(+), 20 deletions(-) diff --git a/grav1ty.hs b/grav1ty.hs index 2a8ac8d..63f107a 100644 --- a/grav1ty.hs +++ b/grav1ty.hs @@ -1,13 +1,14 @@ {-# LANGUAGE TemplateHaskell #-} -import Linear.V2 -import Linear.Vector -import Linear.Metric -import Debug.Trace -import Control.FRPNow hiding ((*^), (^/), norm) -import Control.FRPNow.Gloss -import Graphics.Gloss -import Control.Lens - +import Control.FRPNow hiding (norm, (*^), (^/)) +import Control.FRPNow.Gloss +import Control.Lens +import Graphics.Gloss +import Linear.Metric +import Linear.V2 +import Linear.Vector + +-- | Statically definition of the frames +-- per second the simulation should run at. fps :: Num a => a fps = 30 @@ -32,45 +33,75 @@ data Object , _pic :: Picture -- ^ the gloss picture to draw the object , _mass :: Float -- ^ mass in kilograms , _acc :: V2 Float -- ^ current manual acceleration of the object. Think of - -- this as the acceleration caused by a spaceship's - -- thrusters or similar. + -- this as the acceleration caused by a spaceship's + -- thrusters or similar. } deriving (Eq, Show) makeLenses ''Object +-- | A Universe is a list of objects. +-- Ordering or similar does not matter type Universe = [Object] +-- | CompSt describes the state of the main +-- computation that is mainly described by +-- nextUniverse. In the FRP context we keep +-- the necessary state as argument of type +-- CompSt. It holds the current and the last +-- Universe. Given these two we can compute +-- the next universe data CompSt = MkCompSt { - _lastUni :: Universe - , _currUni :: Universe + _lastUni :: Universe -- ^ last universe + , _currUni :: Universe -- ^ current universe + } + +data AccInSt + = MkAccInSt { + _angle :: Float -- ^ current angle of the ship + , _norm :: Float -- ^ current thruster power / norm of + -- the acceleration vector } +-- | takePicture extracts the picture +-- of an Object and moves it to its +-- correct position takePicture :: Object -> Picture takePicture obj = let (V2 x y) = _loc obj pic = _pic obj in translate x y pic +-- | dropFirst drops only the first occurence +-- of an element in a list. dropFirst :: Eq a => a -> [a] -> [a] dropFirst _ [] = [] dropFirst x (y:ys) = if x == y then ys else dropFirst x ys -toTuple :: V2 a -> (a, a) -toTuple (V2 x y) = (x, y) - -fromTuple :: (a, a) -> V2 a -fromTuple (x, y) = V2 x y - +-- | scaleBoth is a wrapper around scale from +-- gloss which scales a Picture by the same +-- ratio in both x and y dimension. scaleBoth :: Float -> Picture -> Picture scaleBoth f = scale f f +-- | Timestep holds the time that passes between +-- two computation steps in order to compute +-- the next universe correctly. Time changes +-- every frame in frpnow-gloss, so it is 1/fps +-- seconds. timeStep :: Fractional a => a timeStep = 1 / fps +-- | Given a Behavior unitChange returns a Behavior of +-- Events that fire an unit if the given behavior +-- changed. Convenience wrapper around frpnow's +-- change. unitChange :: Eq a => Behavior a -> Behavior (Event ()) unitChange behavior = (() <$) <$> change behavior -- TODO: think about *best* approximation +-- | Calls nextObject on every object of the +-- universe. Needs the last and the +-- current state of the universe. nextUniverse :: Universe -> Universe -> Universe nextUniverse last curr = next last curr last curr where next last curr (l:ls) (c:cs) @@ -78,12 +109,20 @@ nextUniverse last curr = next last curr last curr : next last curr ls cs next _ _ [] [] = [] +-- | Calculates the next position of an object using +-- given gravity forces and the manual acceleration +-- of the given object. It needs the last and the +-- current state of the object since this is just +-- an approximation. nextObject :: Object -> Object -> [V2 Float] -> Object nextObject last@(Static {}) curr@(Static {}) _ = curr nextObject last@(Dynamic {}) curr@(Dynamic {}) forces = curr & loc .~ 2 * _loc curr - _loc last + (timeStep ** 2) *^ (_acc curr + sum forces) +-- | Calculates the gravity force between +-- two objectts based on the standard +-- formula. gravityForce :: Object -> Object -> V2 Float gravityForce a b = (gravityConst * ((_mass a * _mass b) / (absDistance ** 2))) *^ (distance ^/ absDistance) @@ -91,6 +130,8 @@ gravityForce a b = (gravityConst * ((_mass a * _mass b) / (absDistance ** 2))) distance = _loc b - _loc a absDistance = norm distance +-- | Calculates the gravity forces between an +-- object and the rest of the universe. gravityForces :: Object -> Universe -> [V2 Float] gravityForces obj uni = map (gravityForce obj) $ dropFirst obj uni @@ -107,6 +148,7 @@ universeB state time accB = do e' <- snapshot (universeB newState time accB) e return $ pure (_currUni state) `switch` e' +-- | A basic universe for testing purposes. exampleUniverse :: Universe exampleUniverse = [ Dynamic (V2 0 (earthRadius + 100000)) (color (makeColor 1 0 0 1) $ circleSolid (earthRadius / 100)) spaceshipMass (V2 0 0) @@ -116,7 +158,17 @@ exampleUniverse = earthRadius = 6378137 spaceshipMass = 1935 - +--acceleration :: EvStream GEvent -> AccInSt -> Behavior (Behavior (V2 Float)) +--acceleration evs state = do +-- interestingEvs <- filterEs isInteresting evs +-- e' <- snapshot (acceleration evs newState +-- return $ pure state `switch` e' +-- where isInteresting (EventKey k _ _ _) = if k `elem` [Char ' +-- isInteresting _ = False + +-- | The main FRP routine. It basically warps +-- universeB and renders the gloss picture +-- for every computation step. mainFRP :: Universe -> Behavior Time -> EvStream GEvent -- cgit 1.4.1