pituicat/src/Scenes/Test/Update.hs

122 lines
3.8 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
module Scenes.Test.Update where
import Affection
import Control.Concurrent.STM
import qualified Data.Vector as V
import Data.String (fromString)
import Linear
-- 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)
modifyTVar
(testCast level) $ \cast ->
let playedCast =
V.map
(\(Cast c) -> Cast (perform dt c))
cast
collidedCast =
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
)
(Cast c1, Collision dt (V2 0 0))
playedCast
in
if null partners
then Cast c1
else
uncurry
(\(Cast c2) result -> Cast $ collide c1 c2 result)
partners
)
playedCast
wallCast (Cast c) = Cast $ uncurry (collide c) $
V.foldl
(\acc@(_, ires) tile ->
let res = collisionCheck dt c tile
in
if res /= NoCollision &&
collisionTime res < collisionTime ires
then (tile, res)
else acc
)
(V.head layer, Collision dt (V2 0 0))
layer
walledCast =
V.map wallCast collidedCast
in
V.map
(\(Cast c) -> Cast $
move dt c
)
walledCast
updatedCast <- readTVar (testCast level)
modifyTVar
(testPlayer level) $ \(Just pituicat) ->
let playedCat = perform dt pituicat
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, Collision dt (V2 0 0))
updatedCast
in
if (collisionTime $ snd partner) == dt
then playedCat
else uncurry
(\(Cast cx) res -> collide playedCat cx res)
partner
walledCat =
let partner =
V.foldl
(\acc@(_, ires) tile ->
let res = collisionCheck dt collidedCat tile
in
if res /= NoCollision &&
collisionTime res < collisionTime ires
then (tile, res)
else acc
)
(V.head layer, Collision dt (V2 0 0))
layer
in
if (collisionTime $ snd partner) == dt
then collidedCat
else uncurry (collide collidedCat) partner
in Just $ move dt walledCat