mitigate 'swamping' and hunt warnings

This commit is contained in:
nek0 2021-01-03 01:43:37 +01:00
parent 20954c0484
commit 3797869d14
8 changed files with 37 additions and 34 deletions

View file

@ -31,7 +31,7 @@ class (Show c, Mass c) => Collidible c where
(V2 m2x1 m2y1) = position m2 + fst (boundary m2) + delta2 (V2 m2x1 m2y1) = position m2 + fst (boundary m2) + delta2
(V2 m2x2 m2y2) = position m2 + snd (boundary m2) + delta2 (V2 m2x2 m2y2) = position m2 + snd (boundary m2) + delta2
delta1@(V2 vx1 vy1) = (dt *) <$> velocity m1 delta1@(V2 vx1 vy1) = (dt *) <$> velocity m1
delta2@(V2 vx2 vy2) = (dt *) <$> velocity m2 delta2 = (dt *) <$> velocity m2
dtx 0 = dt dtx 0 = dt
dtx vx = dtx vx =
if vx > 0 if vx > 0
@ -55,9 +55,11 @@ class (Show c, Mass c) => Collidible c where
, m2y2 < m1y2 && m2y2 > m1y1 , m2y2 < m1y2 && m2y2 > m1y1
] ]
in in
(if vx1 == 0 then posColl else dt > dtx vx1) -- (if vx1 == 0 then posColl else dt > dtx vx1)
(dt > dtx vx1 || posColl)
&& &&
(if vy1 == 0 then posColl else dt > dty vy1) -- (if vy1 == 0 then posColl else dt > dty vy1)
(dt > dty vy1 || posColl)
-- | This Function is called for every collision on both colliding objects. -- | This Function is called for every collision on both colliding objects.
collide collide
@ -78,12 +80,32 @@ elasticCollision
elasticCollision damping mo1 mo2 = elasticCollision damping mo1 mo2 =
let (V2 v1x v1y) = velocity mo1 let (V2 v1x v1y) = velocity mo1
(V2 v2x v2y) = velocity mo2 (V2 v2x v2y) = velocity mo2
p1@(V2 p1x p1y) = position mo1
p2 = position mo2
(V2 m1x1 m1y1, V2 m1x2 m1y2) = boundary mo1
(V2 m2x1 m2y1, V2 m2x2 m2y2) = boundary mo2
m1 = mass mo1 m1 = mass mo1
m2 = mass mo2 m2 = mass mo2
v1x' = 2 * (m1 * v1x + m2 * v2x) / (m1 + m2) - v1x v1x' = 2 * (m1 * v1x + m2 * v2x) / (m1 + m2) - v1x
v1y' = 2 * (m1 * v1y + m2 * v2y) / (m1 + m2) - v1y v1y' = 2 * (m1 * v1y + m2 * v2y) / (m1 + m2) - v1y
(V2 dx dy) = p2 - p1
np = V2
( p1x + if v1x == 0
then 0
else
if dx < 0
then (abs m2x1 + abs m1x2 - abs dx)
else - (abs m2x2 + abs m1x1 - abs dx)
)
( p1y + if v1y == 0
then 0
else
if dy < 0
then (abs m2y1 + abs m1y2 - abs dy)
else - (abs m2y2 + abs m1y1 - abs dy)
)
in in
(velocityUpdater mo1) (velocityUpdater ((positionUpdater mo1) np))
(if m1 == recip 0 (if m1 == recip 0
then V2 0 0 then V2 0 0
else (damping *) <$> else (damping *) <$>

View file

@ -51,7 +51,7 @@ class Mass m where
(velocityUpdater m) vel (velocityUpdater m) vel
-- | Apply velocity to mass object and thus change its position -- | Apply velocity to mass object and thus change its position
-- Changes in position smaller than a pixel are ignored. -- Changes in position smaller than around half a pixel per second are ignored.
move move
:: Double -- ^ Time step duration :: Double -- ^ Time step duration
-> m -- ^ Original mass object -> m -- ^ Original mass object
@ -59,6 +59,6 @@ class Mass m where
move dt m = move dt m =
let dpos = ((dt *) <$> velocity m) let dpos = ((dt *) <$> velocity m)
in in
if quadrance dpos < 1 if quadrance dpos * sqrt 2 > dt
then m then (positionUpdater m) (position m + dpos)
else (positionUpdater m) (position m + dpos) else m

View file

@ -40,7 +40,7 @@ readLayer
:: (Word, FilePath) -- ^ index and path of the layer descriptor image :: (Word, FilePath) -- ^ index and path of the layer descriptor image
-> V2 Float -- ^ size of Tilemap in pixels -> V2 Float -- ^ size of Tilemap in pixels
-> IO ((V.Vector Tile), V2 Int) -> IO ((V.Vector Tile), V2 Int)
readLayer (idx, path) (V2 tx ty) = do readLayer (_, path) (V2 tx ty) = do
img <- flipVertically <$> convertRGBA8 <$> either error id <$> readImage path img <- flipVertically <$> convertRGBA8 <$> either error id <$> readImage path
let width = imageWidth img let width = imageWidth img
height = imageHeight img height = imageHeight img

View file

@ -1,14 +1,8 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
module Renderer where module Renderer where
import Affection
import SDL (($=), get)
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import Data.String (fromString)
import Control.Concurrent.STM import Control.Concurrent.STM
import Foreign.Ptr import Foreign.Ptr

View file

@ -1,21 +1,14 @@
{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE ExistentialQuantification #-}
module Types.Application where module Types.Application where
import Affection
import qualified SDL import qualified SDL
import Control.Concurrent (ThreadId) import Control.Concurrent (ThreadId)
import Control.Concurrent.STM import Control.Concurrent.STM
import qualified Data.Map.Strict as M
import qualified Data.Text as T
-- internal imports -- internal imports
import Types.Subsystems import Types.Subsystems
import Types.Map
import Types.Util import Types.Util
import Classes.Scene import Classes.Scene

View file

@ -6,7 +6,7 @@ module Types.Graphics.VertexBuffer where
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import SDL (($=), get) import SDL (($=))
import Control.Monad.Loops (whileM_) import Control.Monad.Loops (whileM_)
@ -16,7 +16,6 @@ import qualified Data.Vector.Storable as VS
import Linear import Linear
import Foreign
import Foreign import Foreign
import Foreign.C.Types import Foreign.C.Types
import Foreign.Storable.Generic import Foreign.Storable.Generic
@ -193,7 +192,7 @@ instance VertexLayout Vertex where
layoutElements _ = layoutElements _ =
foldl foldl
(\acc a@(index, count) -> (\acc (index, count) ->
( index ( index
, GL.VertexArrayDescriptor , GL.VertexArrayDescriptor
count count

View file

@ -3,8 +3,6 @@ module Types.Player where
import Affection as A import Affection as A
import qualified Graphics.Rendering.OpenGL as GL
import Linear import Linear
import qualified Data.Vector as V import qualified Data.Vector as V
@ -33,7 +31,7 @@ data Pituicat = Pituicat
instance Drawable Pituicat where instance Drawable Pituicat where
toVertices (Pituicat pos@(V2 x y) _ _ _ tex) = toVertices (Pituicat (V2 x y) _ _ _ _) =
( V.fromList [0, 1, 2, 2, 3, 0] ( V.fromList [0, 1, 2, 2, 3, 0]
, V.fromList , V.fromList
[ newVertex [ newVertex
@ -110,4 +108,4 @@ instance Collidible Pituicat where
Debug Debug
("*boing* meow! other: " <> ("*boing* meow! other: " <>
fromString (show other)) fromString (show other))
(elasticCollision 0.1 cat other) (elasticCollision 0.3 cat other)

View file

@ -4,8 +4,6 @@ import SDL (($=), get)
import qualified Graphics.Rendering.OpenGL as GL import qualified Graphics.Rendering.OpenGL as GL
import SDL (($=), get)
import Codec.Picture import Codec.Picture
import Codec.Picture.Extra import Codec.Picture.Extra
@ -14,7 +12,6 @@ import Data.Vector.Storable (unsafeWith)
import Linear import Linear
import Foreign import Foreign
import Foreign.Ptr
-- internal imports -- internal imports
@ -32,7 +29,7 @@ instance Bindable Texture where
GL.activeTexture $= textureSlot t GL.activeTexture $= textureSlot t
GL.textureBinding GL.Texture2D $= Just (textureId t) GL.textureBinding GL.Texture2D $= Just (textureId t)
unbind t = GL.textureBinding GL.Texture2D $= Nothing unbind _ = GL.textureBinding GL.Texture2D $= Nothing
newTexture :: FilePath -> GL.GLuint -> IO (V2 Word, Texture) newTexture :: FilePath -> GL.GLuint -> IO (V2 Word, Texture)
newTexture fp slot = do newTexture fp slot = do
@ -74,7 +71,7 @@ newTexture fp slot = do
return (fmap fromIntegral dimensions, tex) return (fmap fromIntegral dimensions, tex)
loadTexture :: Texture -> V2 GL.GLsizei -> Ptr () -> IO () loadTexture :: Texture -> V2 GL.GLsizei -> Ptr () -> IO ()
loadTexture tex dimensions data_ = loadTexture _ dimensions data_ =
let (V2 w h) = dimensions let (V2 w h) = dimensions
in GL.texImage2D in GL.texImage2D
GL.Texture2D GL.Texture2D