2021-01-11 09:33:20 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2021-03-22 05:36:28 +00:00
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
2021-01-11 09:33:20 +00:00
|
|
|
module Scenes.Test.Update where
|
|
|
|
|
|
|
|
import Affection
|
|
|
|
|
|
|
|
import Control.Concurrent.STM
|
|
|
|
|
|
|
|
import qualified Data.Vector as V
|
|
|
|
|
2021-03-22 05:36:28 +00:00
|
|
|
import Data.Maybe
|
|
|
|
|
2021-01-11 09:33:20 +00:00
|
|
|
import Data.String (fromString)
|
|
|
|
|
2021-02-27 15:08:45 +00:00
|
|
|
import Linear
|
|
|
|
|
2021-01-11 09:33:20 +00:00
|
|
|
-- internal imports
|
|
|
|
|
|
|
|
import Scenes.Test.Types
|
|
|
|
import Classes
|
|
|
|
import Types
|
|
|
|
|
|
|
|
update
|
|
|
|
:: Test
|
|
|
|
-> Double
|
|
|
|
-> Affection ()
|
|
|
|
update level dt = liftIO $ do
|
|
|
|
logIO Debug ("FPS: " <> fromString (show $ 1 / dt))
|
|
|
|
|
|
|
|
-- Let all Actors update themselves and check for collisions
|
|
|
|
-- (Typeclasses rock!)
|
|
|
|
atomically $ do
|
|
|
|
lmap <- readTMVar (testMap level)
|
|
|
|
let layer = mapLayers lmap V.! fromIntegral (mapWalkLayer lmap)
|
2021-04-20 02:19:54 +00:00
|
|
|
modifyTVar (testPowerups level) $ \pus ->
|
|
|
|
let played = V.map (perform dt) pus
|
|
|
|
collided = V.map (\pu -> performWorldCollision pu layer dt) played
|
|
|
|
in
|
|
|
|
collided
|
2021-01-11 09:33:20 +00:00
|
|
|
modifyTVar
|
|
|
|
(testCast level) $ \cast ->
|
|
|
|
let playedCast =
|
|
|
|
V.map
|
|
|
|
(\(Cast c) -> Cast (perform dt c))
|
|
|
|
cast
|
|
|
|
collidedCast =
|
2021-02-27 15:08:45 +00:00
|
|
|
V.map
|
|
|
|
(\(Cast c1) ->
|
|
|
|
let partners = V.foldl
|
|
|
|
(\acc@(Cast _, ires) (Cast c2) ->
|
|
|
|
let res = collisionCheck dt c1 c2
|
|
|
|
in
|
|
|
|
if res /= NoCollision &&
|
|
|
|
collisionTime res < collisionTime ires
|
|
|
|
then (Cast c2, res)
|
|
|
|
else acc
|
|
|
|
)
|
2021-03-22 05:36:28 +00:00
|
|
|
(Cast c1, NoCollision)
|
2021-02-27 15:08:45 +00:00
|
|
|
playedCast
|
|
|
|
in
|
|
|
|
if null partners
|
|
|
|
then Cast c1
|
|
|
|
else
|
|
|
|
uncurry
|
|
|
|
(\(Cast c2) result -> Cast $ collide c1 c2 result)
|
|
|
|
partners
|
|
|
|
)
|
|
|
|
playedCast
|
2021-03-22 05:36:28 +00:00
|
|
|
wallCast (Cast c) =
|
|
|
|
Cast $ performWorldCollision c layer dt
|
2021-01-11 09:33:20 +00:00
|
|
|
walledCast =
|
|
|
|
V.map wallCast collidedCast
|
|
|
|
in
|
|
|
|
V.map
|
|
|
|
(\(Cast c) -> Cast $
|
|
|
|
move dt c
|
|
|
|
)
|
|
|
|
walledCast
|
2021-01-11 23:51:58 +00:00
|
|
|
updatedCast <- readTVar (testCast level)
|
|
|
|
modifyTVar
|
|
|
|
(testPlayer level) $ \(Just pituicat) ->
|
|
|
|
let playedCat = perform dt pituicat
|
2021-04-16 16:46:01 +00:00
|
|
|
-- collidedCat =
|
|
|
|
-- let partner =
|
|
|
|
-- V.foldl
|
|
|
|
-- (\acc@(_, ires) (Cast c) ->
|
|
|
|
-- let res = collisionCheck dt playedCat c
|
|
|
|
-- in
|
|
|
|
-- if res /= NoCollision &&
|
|
|
|
-- collisionTime res < collisionTime ires
|
|
|
|
-- then (Cast c, res)
|
|
|
|
-- else acc
|
|
|
|
-- )
|
|
|
|
-- (V.head updatedCast, NoCollision)
|
|
|
|
-- updatedCast
|
|
|
|
-- in
|
|
|
|
-- if (collisionTime $ snd partner) == dt
|
|
|
|
-- then playedCat
|
|
|
|
-- else uncurry
|
|
|
|
-- (\(Cast cx) res -> collide playedCat cx res)
|
|
|
|
-- partner
|
2021-01-11 23:51:58 +00:00
|
|
|
walledCat =
|
2021-03-22 05:36:28 +00:00
|
|
|
performWorldCollision playedCat layer dt
|
2021-01-17 01:30:45 +00:00
|
|
|
in Just $ move dt walledCat
|
2021-03-22 05:36:28 +00:00
|
|
|
|
|
|
|
performWorldCollision
|
|
|
|
:: (Collidible c)
|
|
|
|
=> c -- ^ Cast member to check
|
|
|
|
-> Layer -- ^ The walk layer of the level
|
|
|
|
-> Double -- ^ Tick length
|
|
|
|
-> c -- ^ Updated cast member
|
|
|
|
performWorldCollision c layer dt =
|
|
|
|
let partner = V.foldl
|
2021-04-16 16:46:01 +00:00
|
|
|
(\acc@(part, cr) tile ->
|
2021-03-22 05:36:28 +00:00
|
|
|
let res = collisionCheck dt c tile
|
2021-04-16 16:46:01 +00:00
|
|
|
ret = if cr == NoCollision && res == NoCollision
|
|
|
|
then
|
|
|
|
acc
|
|
|
|
else
|
|
|
|
if cr == NoCollision && res /= NoCollision
|
|
|
|
then (tile, res)
|
|
|
|
else
|
|
|
|
if cr /= NoCollision && res == NoCollision
|
|
|
|
then
|
|
|
|
acc
|
|
|
|
else
|
|
|
|
if collisionTime cr < collisionTime res
|
|
|
|
then acc
|
|
|
|
else (tile, res)
|
2021-03-22 05:36:28 +00:00
|
|
|
in
|
|
|
|
ret
|
|
|
|
)
|
2021-04-16 16:46:01 +00:00
|
|
|
(V.head layer, collisionCheck dt c $ V.head layer)
|
2021-03-22 05:36:28 +00:00
|
|
|
layer
|
|
|
|
in
|
2021-04-16 16:46:01 +00:00
|
|
|
uncurry (collide c) partner
|