diff options
author | sternenseemann <git@lukasepple.de> | 2019-05-30 11:26:49 +0200 |
---|---|---|
committer | sternenseemann <git@lukasepple.de> | 2019-05-30 11:26:49 +0200 |
commit | c0b525ca287d4f63fd3735414a7f384e0368a156 (patch) | |
tree | ddb3bae34b4488b419dd1f3971a4a4c9f229294d | |
parent | 4b7c378c321095d55fa3ef7ee0abcc018cc58d6b (diff) |
switch from list to seq; simplify state update
-rw-r--r-- | lib/Grav2ty/Control.hs | 35 | ||||
-rw-r--r-- | lib/Grav2ty/Simulation.hs | 29 | ||||
-rw-r--r-- | src/Main.hs | 24 |
3 files changed, 51 insertions, 37 deletions
diff --git a/lib/Grav2ty/Control.hs b/lib/Grav2ty/Control.hs index 120924a..78f6c26 100644 --- a/lib/Grav2ty/Control.hs +++ b/lib/Grav2ty/Control.hs @@ -15,7 +15,10 @@ module Grav2ty.Control import Grav2ty.Simulation import Control.Lens +import Data.Foldable import Data.Maybe +import Data.Sequence ((<|), (|>), (><)) +import qualified Data.Sequence as S import Linear.V2 import Linear.Vector import qualified Data.Map as Map @@ -62,19 +65,19 @@ 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 -> [Object a] -applyControls _ obj@Static {} = [obj] +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 [] + else S.empty where life = objectLife obj moddedObjs = case objectMod obj of - NoMod -> [obj] + NoMod -> S.singleton obj LocalMod -> case Map.lookup (objectMod obj) (cs^.ctrlInputs) of - Nothing -> [obj] + Nothing -> S.singleton obj Just (Modification rot acc fire) -> let newObj = obj { objectRot = rot @@ -83,28 +86,26 @@ applyControls cs obj@Dynamic {} = -- Note: we are relying on laziness here: if objectCannon -- is Nothing the pObj never gets evaluated. pObj = projectile (fromJust . objectCannon $ obj) (cs^.ctrlTick) newObj - pList = if cs^.ctrlTick /= fire || isNothing (objectCannon obj) - then [] - else [pObj] - in newObj : pList + in if cs^.ctrlTick /= fire || isNothing (objectCannon obj) + then S.singleton newObj + else S.fromList [pObj, newObj] -type ExtractFunction a b = Object a -> (State a b -> State a b) +type ExtractFunction a b = Object a -> Maybe (State a b -> State a b) updateState :: (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 - . updateState' $ state + . fromMaybe id updateState' $ state where oldWorld = state^.world - (newWorld, updateState') = tailCall oldWorld ([], id) - tailCall [] acc = acc - tailCall (x:xs) (nw, f) = tailCall xs $ + (newWorld, updateState') = foldl' updateAndExtract (S.empty, Nothing) oldWorld + updateAndExtract acc@(seq, f) x = if coll x - then (nw, f) - else (updateObject' x ++ nw, extract x . f) + then acc + else (updateObject' x >< seq, (.) <$> extract x <*> f) coll obj = isDynamic obj && collisionWithWorld oldWorld obj scaledT = state^.control^.ctrlTimeScale * t updateObject' obj = - map (updateObject scaledT (gravitationForces oldWorld obj)) + fmap (updateObject scaledT (gravitationForces oldWorld obj)) . applyControls (state^.control) $ obj diff --git a/lib/Grav2ty/Simulation.hs b/lib/Grav2ty/Simulation.hs index 2b61e51..f23b134 100644 --- a/lib/Grav2ty/Simulation.hs +++ b/lib/Grav2ty/Simulation.hs @@ -22,6 +22,9 @@ module Grav2ty.Simulation import Control.Lens import Data.Complex +import Data.Foldable +import Data.Sequence (Seq (..)) +import qualified Data.Sequence as S import Linear.Matrix import Linear.Metric (norm, distance) import Linear.V2 @@ -144,8 +147,11 @@ collision (HCombined as) b = any (collision b) as collision a b@(HCombined _) = collision b a collisionWithWorld :: (Ord a, RealFloat a) => World a -> Object a -> Bool -collisionWithWorld world obj = any (\obj' -> - obj /= obj' && collision (realHitbox obj) (realHitbox obj')) world +collisionWithWorld world obj = any + (\obj' -> + obj /= obj' && + (objectLoc obj == objectLoc obj' + || collision (realHitbox obj) (realHitbox obj'))) world data Modifier = NoMod -- ^ Not modified, purely physics based. @@ -189,7 +195,7 @@ isDynamic :: Object a -> Bool isDynamic Dynamic {} = True isDynamic _ = False -type World a = [Object a] +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 @@ -202,18 +208,17 @@ gravitationForce a b = (gravityConst * 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 +gravitationForces :: (Ord a, Floating a) => World a -> Object a -> V2 a +gravitationForces world obj = foldl' calcSum (pure 0) world + where calcSum force x = if separated obj x + then force + gravitationForce obj x + else force -updateObject :: Fractional a => a -> [V2 a] -> Object a -> Object a +updateObject :: Fractional a => a -> V2 a -> Object a -> Object a updateObject _ _ obj@Static {} = obj -updateObject timeStep forces obj@Dynamic {} = obj +updateObject timeStep force obj@Dynamic {} = obj { objectLoc = objectLoc obj + (objectSpeed obj ^* timeStep) , objectSpeed = objectSpeed obj + - (((sum forces ^/ objectMass obj) + objectAcc obj) ^* timeStep) + (((force ^/ objectMass obj) + objectAcc obj) ^* timeStep) } diff --git a/src/Main.hs b/src/Main.hs index 9d30370..4e95e32 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -8,7 +8,9 @@ import Grav2ty.Control import Control.Lens import Linear.V2 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 Data.Map.Lens @@ -58,7 +60,7 @@ renderStars center = undefined renderGame :: State Float GlossState -> Picture renderGame state = Pictures [ renderUi state, applyViewPort objs ] - where objs = Pictures . map renderObject $ state^.world + where objs = Pictures . foldl' (\l x -> renderObject x : l) [] $ state^.world applyViewPort = if state^.graphics . glossCenterView then applyViewPortToPicture viewport else id @@ -104,22 +106,28 @@ eventHandler _ s = s updateWorld :: Float -> State Float GlossState -> State Float GlossState updateWorld ts state = updateState ts extract state - where extract obj@Dynamic { objectMod = LocalMod } = set + where extract obj@Dynamic { objectMod = LocalMod } = Just $ set (graphics.glossViewPortCenter) (vectorToPoint . objectLoc $ obj) - extract _ = id + extract _ = Nothing initialWorld :: Fractional a => State a GlossState initialWorld = State (ControlState (Map.fromList [(LocalMod, zeroModification)]) 1 0) - (GlossState (800, 800) (0, 0) 1 True) - [ 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) + (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) - ] + ] 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)) |