nek0/pituicat
2
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

linted

Browse source
This commit is contained in:
nek0 2021-07-24 03:33:00 +02:00
parent 95f5b2c3a8
commit d71437774f
4 changed files with 69 additions and 60 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
src/Physics/Classes/Mass.hs
View file

@ -38,7 +38,7 @@ class Mass m where
gravitate g m = gravitate g m =
let acc = acceleration m + g let acc = acceleration m + g
in in
(accelerationUpdater m) acc accelerationUpdater m acc
-- | Apply acceleration to mass object und thus change its velocity -- | Apply acceleration to mass object und thus change its velocity
accelerate accelerate
@ -48,7 +48,7 @@ class Mass m where
accelerate dt m = accelerate dt m =
let vel = velocity m + ((dt *) <$> acceleration m) let vel = velocity m + ((dt *) <$> acceleration m)
in in
(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 around half a pixel per second are ignored. -- Changes in position smaller than around half a pixel per second are ignored.
@ -57,6 +57,6 @@ class Mass m where
-> m -- ^ Original mass object -> m -- ^ Original mass object
-> m -- ^ Updated mass object -> m -- ^ Updated mass object
move dt m = move dt m =
let dpos@(V2 dx dy) = (dt *) <$> velocity m let dpos = (dt *) <$> velocity m
in in
(positionUpdater m) (position m + dpos) positionUpdater m (position m + dpos)

40
src/Scenes/Test/Update.hs
View file

@ -15,8 +15,6 @@ import Data.Maybe
import Data.String (fromString) import Data.String (fromString)
import Linear
-- internal imports -- internal imports
import Scenes.Test.Types import Scenes.Test.Types
@ -35,40 +33,40 @@ update level dt = liftIO $ do
lmap <- readTMVar (testMap level) lmap <- readTMVar (testMap level)
cast <- cast <-
V.map (\(Cast c) -> Cast $ perform dt c) <$> readTVar (testCast level) V.map (\(Cast c) -> Cast $ perform dt c) <$> readTVar (testCast level)
powerups <- V.filter ((0 <) . puTTL) <$> powerups <- V.filter ((0 <) . puTTL) .
V.map (perform dt) <$> V.map (perform dt) <$>
readTVar (testPowerups level) readTVar (testPowerups level)
cat <- perform dt <$> fromJust <$> readTVar (testPlayer level) cat <- perform dt . fromJust <$> readTVar (testPlayer level)
let layer = mapLayers lmap V.! fromIntegral (mapWalkLayer lmap) let layer = mapLayers lmap V.! fromIntegral (mapWalkLayer lmap)
tangibles = tangibles =
(V.map TTile layer) V.++ V.map TTile layer V.++
(V.map TCast cast) V.++ V.map TCast cast V.++
(V.map TPowerUp powerups) `V.snoc` V.map TPowerUp powerups `V.snoc`
TPlayer cat TPlayer cat
indexedTangibles = V.zip indexedTangibles = V.zip
(V.fromList [0 .. ((V.length tangibles) - 1)]) (V.fromList [0 .. (V.length tangibles - 1)])
tangibles tangibles
collidedTangibles = collidedTangibles =
let collisionPartners = let collisionPartners =
V.foldl V.foldl
(\acc (index, tangible1) -> (\iacc (index, tangible1) ->
let partners = let partners =
V.foldl V.foldl
(\acc (qInd, tangible2) -> (\jacc (qInd, tangible2) ->
let res = collisionCheck dt tangible1 tangible2 let res = collisionCheck dt tangible1 tangible2
in in
if res /= NoCollision && qInd /= index if res /= NoCollision && qInd /= index
then acc `V.snoc` (qInd, res) then jacc `V.snoc` (qInd, res)
else acc else jacc
) )
V.empty V.empty
indexedTangibles indexedTangibles
in in
if V.null partners if V.null partners
then acc then iacc
else acc `V.snoc` else iacc `V.snoc`
( index ( index
, head , head
(sortOn (collisionTime . snd) (V.toList partners)) (sortOn (collisionTime . snd) (V.toList partners))
@ -93,17 +91,17 @@ update level dt = liftIO $ do
(aindex, res) (aindex, res)
in in
tangibles `V.update` tangibles `V.update`
(V.map updater collisionPartners) V.map updater collisionPartners
(newCast, newPowerups, mnewCat@(Just _)) = V.foldl (newCast, newPowerups, mnewCat@(Just _)) = V.foldl
(\acc@(castAcc, puAcc, mcat) input -> (\acc@(castAcc, pAcc, _) input ->
case input of case input of
TCast c -> TCast c ->
(castAcc `V.snoc` move dt c, puAcc, mnewCat) (castAcc `V.snoc` move dt c, pAcc, mnewCat)
TPowerUp p -> TPowerUp p ->
(castAcc, puAcc `V.snoc` move dt p, mnewCat) (castAcc, pAcc `V.snoc` move dt p, mnewCat)
TPlayer cat -> TPlayer ncat ->
(castAcc, puAcc, Just (move dt cat)) (castAcc, pAcc, Just (move dt ncat))
TTile t -> TTile _ ->
acc acc
) )
(V.empty, V.empty, Nothing) (V.empty, V.empty, Nothing)

78
src/Types/Player.hs
View file

@ -99,7 +99,7 @@ instance Actor Pituicat where
let (V2 _ dy) = velocity physCat let (V2 _ dy) = velocity physCat
moveFact = moveFact =
if if
null (filter ((SpeedUp ==) . effectReleased) (pcEffects p)) not (any ((SpeedUp ==) . effectReleased) (pcEffects p))
then 1 then 1
else 2 else 2
physCat = (accelerate dt . gravitate constG) physCat = (accelerate dt . gravitate constG)
@ -115,9 +115,7 @@ instance Actor Pituicat where
finalCat = physCat finalCat = physCat
{ pcMoveVel = { pcMoveVel =
lerp (min 0.95 (60 * dt)) (pcMoveVel physCat) (pcTMoveVel physCat) lerp (min 0.95 (60 * dt)) (pcMoveVel physCat) (pcTMoveVel physCat)
, pcGrounded = if pcGrounded physCat , pcGrounded = pcGrounded physCat && abs dy * dt <= 2
then not (abs dy * dt > 2)
else False
, pcEffects = , pcEffects =
foldl foldl
(\acc eff -> (\acc eff ->
@ -133,7 +131,7 @@ instance Actor Pituicat where
(pcEffects p) (pcEffects p)
} }
in in
A.log A.Debug ("*meow* am at: " <> (fromString $ show $ pcPos finalCat)) A.log A.Debug ("*meow* am at: " <> fromString (show $ position finalCat))
(finalCat (finalCat
{ pcViewDirection = if pcGrounded finalCat { pcViewDirection = if pcGrounded finalCat
then then
@ -153,43 +151,40 @@ instance Mass Pituicat where
acceleration = pcAcc acceleration = pcAcc
accelerationUpdater cat = accelerationUpdater cat =
(\accel -> cat \accel -> cat
{ pcAcc = accel { pcAcc = accel
} }
)
velocity cat = velocity cat =
let mvel@(V2 mx my) = pcMoveVel cat let mvel@(V2 mx _) = pcMoveVel cat
nvel@(V2 x y) = pcVel cat + mvel nvel@(V2 x y) = pcVel cat + mvel
in in
if abs x > abs mx then V2 (signum x * abs mx) y else nvel if abs x > abs mx then V2 (signum x * abs mx) y else nvel
velocityUpdater cat = velocityUpdater cat =
(\vel@(V2 vx vy) -> \(V2 vx vy) ->
let let
(V2 mx my) = pcMoveVel cat (V2 mx my) = pcMoveVel cat
nvel = V2 nvel = V2
(if abs mx > abs vx (if abs mx > abs vx
then 0 then 0
else (signum vx) * (abs vx - abs mx) else signum vx * (abs vx - abs mx)
) )
(if abs my > abs vy (if abs my > abs vy
then 0 then 0
else (signum vy) * (abs vy - abs my) else signum vy * (abs vy - abs my)
) )
in in
cat cat
{ pcVel = vel { pcVel = nvel
} }
)
position = pcPos position = pcPos
positionUpdater cat = positionUpdater cat =
(\pos -> cat \pos -> cat
{ pcPos = pos { pcPos = pos
} }
)
instance Collidible Pituicat where instance Collidible Pituicat where
@ -206,26 +201,39 @@ instance Collidible Pituicat where
collide cat _ NoCollision = cat collide cat _ NoCollision = cat
collide cat other collr@(Collision ddt (V2 dirx diry)) = collide cat other collr@(Collision ddt (V2 dirx diry)) =
let ncat = (elasticCollision 0.3 cat other collr) let ncat = elasticCollision 0.3 cat other collr
vel@(V2 vx vy) = velocity ncat nvel@(V2 _ vy) = pcVel ncat
moveVel@(V2 mx my) = pcMoveVel cat grounded = diry == -1 && abs (vy * ddt) < 2
nvel = V2 fact = fromIntegral <$> V2
(if abs mx > abs vx (1 - abs dirx)
then 0 (if diry /= -1 && quadrance nvel > bounceThreshold then 1 else 0)
else (signum vx) * (abs vx - abs mx)
)
((\(V2 _ y) -> y) (if diry /= 0 then pcVel ncat else pcVel cat))
grounded =
diry == -1 && abs (vy * ddt) < 2
in in
ncat ncat
{ pcGrounded = grounded { pcVel = nvel * fact
, pcMoveVel = pcMoveVel ncat * , pcMoveVel = pcMoveVel ncat * fact
if dirx /= 0 , pcTMoveVel = pcTMoveVel ncat * fact
then V2 0 1 , pcGrounded = grounded
else V2 1 1
, pcVel = nvel *
if dirx /= 0
then V2 0 1
else V2 1 1
} }
-- let ncat = (elasticCollision 0.3 cat other collr)
-- vel@(V2 vx vy) = velocity ncat
-- moveVel@(V2 mx my) = pcMoveVel cat
-- nvel = V2
-- (if abs mx > abs vx
-- then 0
-- else (signum vx) * (abs vx - abs mx)
-- )
-- ((\(V2 _ y) -> y) (if diry /= 0 then pcVel ncat else pcVel cat))
-- grounded =
-- diry == -1 && abs (vy * ddt) < 2
-- in
-- ncat
-- { pcGrounded = grounded
-- , pcMoveVel = pcMoveVel ncat *
-- if dirx /= 0
-- then V2 0 1
-- else V2 1 1
-- , pcVel = nvel *
-- if dirx /= 0
-- then V2 0 1
-- else V2 1 1
-- }

3
src/Util.hs
View file

@ -29,3 +29,6 @@ globalKeyHandle gd mesg@(MsgKeyboardEvent time win motion repeat keysym) =
constG :: V2 Double constG :: V2 Double
constG = V2 0 (-500) constG = V2 0 (-500)
bounceThreshold :: Double
bounceThreshold = 200