pituicat/src/Scenes/Test/Update.hs

134 lines
4.3 KiB
Haskell

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Scenes.Test.Update where
import Affection as A
import Control.Concurrent.STM
import Data.List (sortOn)
import qualified Data.Vector as V
import Data.Maybe
import Data.String (fromString)
-- internal imports
import Scenes.Test.Types
import Classes
import Types
import Physics
import Util
update
:: Test
-> Double
-> Affection ()
update level dt = liftIO $ do
logIO Debug ("FPS: " <> fromString (show $ 1 / dt))
atomically $ do
lmap <- readTMVar (testMap level)
cast <-
V.map (\(Cast c) -> Cast $ perform dt c) <$> readTVar (testCast level)
powerups <- V.filter ((0 <) . puTTL) .
V.map (perform dt) <$>
readTVar (testPowerups 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`
TPlayer cat
indexedTangibles = V.zip
(V.fromList [0 .. (V.length tangibles - 1)])
tangibles
collidedTangibles =
let collisionPartners =
V.foldl
(\iacc (index, tangible1) ->
let partners =
V.foldl
(\jacc (qInd, tangible2) ->
let res = collisionCheck dt tangible1 tangible2
in
case res of
c@(OverlapCollision _) ->
if qInd /= index
then jacc `V.snoc` (qInd, c)
else jacc
_ -> jacc
)
V.empty
indexedTangibles
in
if V.null partners
then iacc
else iacc `V.snoc`
( index
, sortOn
((\v -> collisionDepth v `dot` collisionDepth v) . snd)
(V.toList partners)
)
)
V.empty
indexedTangibles
updater (aindex, partners) =
let aobject = (snd $ indexedTangibles V.! aindex)
digest = map
(\(pindex, presults) ->
( snd $ indexedTangibles V.! pindex
, presults
)
)
partners
res =
(\d ->
let inter =
collide
aobject
d
dt
in
resetImpactForces $ resetCollisionOccurence $
if collisionOccured inter
then addLoads inter (impactForces inter)
else addLoads inter constG
)
digest
in
(aindex, res)
in
tangibles `V.update`
V.map
updater
(A.log
A.Debug
("Collision partners: " <>
fromString (show collisionPartners))
collisionPartners
)
(newCast, newPowerups, mnewCat@(Just _)) = V.foldl
(\acc@(castAcc, pAcc, _) input ->
case input of
TCast c ->
(castAcc `V.snoc` updateByEuler c dt, pAcc, mnewCat)
TPowerUp p ->
(castAcc, pAcc `V.snoc` updateByEuler p dt, mnewCat)
TPlayer ncat ->
(castAcc, pAcc, Just (updateByEuler ncat dt))
TTile _ ->
acc
)
(V.empty, V.empty, Nothing)
collidedTangibles
writeTVar (testCast level) newCast
writeTVar (testPowerups level) newPowerups
writeTVar (testPlayer level) mnewCat