diff --git a/src/Physics/Classes/Mass.hs b/src/Physics/Classes/Mass.hs index b4886c7..3064cb2 100644 --- a/src/Physics/Classes/Mass.hs +++ b/src/Physics/Classes/Mass.hs @@ -38,7 +38,7 @@ class Mass m where gravitate g m = let acc = acceleration m + g in - (accelerationUpdater m) acc + accelerationUpdater m acc -- | Apply acceleration to mass object und thus change its velocity accelerate @@ -48,7 +48,7 @@ class Mass m where accelerate dt m = let vel = velocity m + ((dt *) <$> acceleration m) in - (velocityUpdater m) vel + velocityUpdater m vel -- | Apply velocity to mass object and thus change its position -- 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 -- ^ Updated mass object move dt m = - let dpos@(V2 dx dy) = (dt *) <$> velocity m + let dpos = (dt *) <$> velocity m in - (positionUpdater m) (position m + dpos) + positionUpdater m (position m + dpos) diff --git a/src/Scenes/Test/Update.hs b/src/Scenes/Test/Update.hs index db7d0e9..320f39a 100644 --- a/src/Scenes/Test/Update.hs +++ b/src/Scenes/Test/Update.hs @@ -15,8 +15,6 @@ import Data.Maybe import Data.String (fromString) -import Linear - -- internal imports import Scenes.Test.Types @@ -35,40 +33,40 @@ update level dt = liftIO $ do lmap <- readTMVar (testMap level) cast <- 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) <$> 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) tangibles = - (V.map TTile layer) V.++ - (V.map TCast cast) V.++ - (V.map TPowerUp powerups) `V.snoc` + V.map TTile layer V.++ + V.map TCast cast V.++ + V.map TPowerUp powerups `V.snoc` TPlayer cat indexedTangibles = V.zip - (V.fromList [0 .. ((V.length tangibles) - 1)]) + (V.fromList [0 .. (V.length tangibles - 1)]) tangibles collidedTangibles = let collisionPartners = V.foldl - (\acc (index, tangible1) -> + (\iacc (index, tangible1) -> let partners = V.foldl - (\acc (qInd, tangible2) -> + (\jacc (qInd, tangible2) -> let res = collisionCheck dt tangible1 tangible2 in if res /= NoCollision && qInd /= index - then acc `V.snoc` (qInd, res) - else acc + then jacc `V.snoc` (qInd, res) + else jacc ) V.empty indexedTangibles in if V.null partners - then acc - else acc `V.snoc` + then iacc + else iacc `V.snoc` ( index , head (sortOn (collisionTime . snd) (V.toList partners)) @@ -93,17 +91,17 @@ update level dt = liftIO $ do (aindex, res) in tangibles `V.update` - (V.map updater collisionPartners) + V.map updater collisionPartners (newCast, newPowerups, mnewCat@(Just _)) = V.foldl - (\acc@(castAcc, puAcc, mcat) input -> + (\acc@(castAcc, pAcc, _) input -> case input of TCast c -> - (castAcc `V.snoc` move dt c, puAcc, mnewCat) + (castAcc `V.snoc` move dt c, pAcc, mnewCat) TPowerUp p -> - (castAcc, puAcc `V.snoc` move dt p, mnewCat) - TPlayer cat -> - (castAcc, puAcc, Just (move dt cat)) - TTile t -> + (castAcc, pAcc `V.snoc` move dt p, mnewCat) + TPlayer ncat -> + (castAcc, pAcc, Just (move dt ncat)) + TTile _ -> acc ) (V.empty, V.empty, Nothing) diff --git a/src/Types/Player.hs b/src/Types/Player.hs index 4ee4fa2..5ace2c0 100644 --- a/src/Types/Player.hs +++ b/src/Types/Player.hs @@ -99,7 +99,7 @@ instance Actor Pituicat where let (V2 _ dy) = velocity physCat moveFact = if - null (filter ((SpeedUp ==) . effectReleased) (pcEffects p)) + not (any ((SpeedUp ==) . effectReleased) (pcEffects p)) then 1 else 2 physCat = (accelerate dt . gravitate constG) @@ -115,9 +115,7 @@ instance Actor Pituicat where finalCat = physCat { pcMoveVel = lerp (min 0.95 (60 * dt)) (pcMoveVel physCat) (pcTMoveVel physCat) - , pcGrounded = if pcGrounded physCat - then not (abs dy * dt > 2) - else False + , pcGrounded = pcGrounded physCat && abs dy * dt <= 2 , pcEffects = foldl (\acc eff -> @@ -133,7 +131,7 @@ instance Actor Pituicat where (pcEffects p) } in - A.log A.Debug ("*meow* am at: " <> (fromString $ show $ pcPos finalCat)) + A.log A.Debug ("*meow* am at: " <> fromString (show $ position finalCat)) (finalCat { pcViewDirection = if pcGrounded finalCat then @@ -153,43 +151,40 @@ instance Mass Pituicat where acceleration = pcAcc accelerationUpdater cat = - (\accel -> cat + \accel -> cat { pcAcc = accel } - ) velocity cat = - let mvel@(V2 mx my) = pcMoveVel cat + let mvel@(V2 mx _) = pcMoveVel cat nvel@(V2 x y) = pcVel cat + mvel in if abs x > abs mx then V2 (signum x * abs mx) y else nvel velocityUpdater cat = - (\vel@(V2 vx vy) -> + \(V2 vx vy) -> let (V2 mx my) = pcMoveVel cat nvel = V2 (if abs mx > abs vx then 0 - else (signum vx) * (abs vx - abs mx) + else signum vx * (abs vx - abs mx) ) (if abs my > abs vy then 0 - else (signum vy) * (abs vy - abs my) + else signum vy * (abs vy - abs my) ) in cat - { pcVel = vel + { pcVel = nvel } - ) position = pcPos positionUpdater cat = - (\pos -> cat + \pos -> cat { pcPos = pos } - ) instance Collidible Pituicat where @@ -206,26 +201,39 @@ instance Collidible Pituicat where collide cat _ NoCollision = cat collide cat other collr@(Collision ddt (V2 dirx diry)) = - 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 + let ncat = elasticCollision 0.3 cat other collr + nvel@(V2 _ vy) = pcVel ncat + grounded = diry == -1 && abs (vy * ddt) < 2 + fact = fromIntegral <$> V2 + (1 - abs dirx) + (if diry /= -1 && quadrance nvel > bounceThreshold then 1 else 0) 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 + { pcVel = nvel * fact + , pcMoveVel = pcMoveVel ncat * fact + , pcTMoveVel = pcTMoveVel ncat * fact + , pcGrounded = grounded } + -- 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 + -- } diff --git a/src/Util.hs b/src/Util.hs index 893567f..1e72a20 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -29,3 +29,6 @@ globalKeyHandle gd mesg@(MsgKeyboardEvent time win motion repeat keysym) = constG :: V2 Double constG = V2 0 (-500) + +bounceThreshold :: Double +bounceThreshold = 200