mitigate 'swamping' and hunt warnings
This commit is contained in:
parent
20954c0484
commit
3797869d14
8 changed files with 37 additions and 34 deletions
|
@ -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 *) <$>
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in a new issue