pituicat/src/Scenes/Test/Update.hs

134 lines
4.3 KiB
Haskell
Raw Normal View History

{-# LANGUAGE OverloadedStrings #-}
2021-03-22 05:36:28 +00:00
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Scenes.Test.Update where
2021-04-17 09:33:28 +00:00
import Affection as A
import Control.Concurrent.STM
import Data.List (sortOn)
import qualified Data.Vector as V
2021-03-22 05:36:28 +00:00
import Data.Maybe
import Data.String (fromString)
-- internal imports
import Scenes.Test.Types
import Classes
import Types
import Physics
2021-09-05 08:46:33 +00:00
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)
2021-07-24 01:33:00 +00:00
powerups <- V.filter ((0 <) . puTTL) .
V.map (perform dt) <$>
readTVar (testPowerups level)
2021-07-24 01:33:00 +00:00
cat <- perform dt . fromJust <$> readTVar (testPlayer level)
let layer = mapLayers lmap V.! fromIntegral (mapWalkLayer lmap)
tangibles =
2021-07-24 01:33:00 +00:00
V.map TTile layer V.++
V.map TCast cast V.++
V.map TPowerUp powerups `V.snoc`
TPlayer cat
indexedTangibles = V.zip
2021-07-24 01:33:00 +00:00
(V.fromList [0 .. (V.length tangibles - 1)])
tangibles
collidedTangibles =
let collisionPartners =
V.foldl
2021-07-24 01:33:00 +00:00
(\iacc (index, tangible1) ->
let partners =
V.foldl
2021-07-24 01:33:00 +00:00
(\jacc (qInd, tangible2) ->
let res = collisionCheck dt tangible1 tangible2
in
2021-07-25 13:51:42 +00:00
case res of
2021-09-05 08:46:33 +00:00
c@(OverlapCollision _) ->
2021-07-25 13:51:42 +00:00
if qInd /= index
then jacc `V.snoc` (qInd, c)
else jacc
_ -> jacc
)
V.empty
indexedTangibles
in
if V.null partners
2021-07-24 01:33:00 +00:00
then iacc
else iacc `V.snoc`
( index
2021-09-05 08:46:33 +00:00
, sortOn
((\v -> collisionDepth v `dot` collisionDepth v) . snd)
(V.toList partners)
)
)
V.empty
indexedTangibles
2021-07-24 07:35:41 +00:00
updater (aindex, partners) =
let aobject = (snd $ indexedTangibles V.! aindex)
2021-07-24 07:35:41 +00:00
digest = map
(\(pindex, presults) ->
( snd $ indexedTangibles V.! pindex
, presults
)
)
partners
res =
(\d ->
let inter =
collide
aobject
2021-07-24 07:35:41 +00:00
d
dt
2021-05-14 07:22:01 +00:00
in
2021-09-05 08:46:33 +00:00
resetImpactForces $ resetCollisionOccurence $
if collisionOccured inter
then addLoads inter (impactForces inter)
else addLoads inter constG
2021-05-14 07:22:01 +00:00
)
2021-07-24 07:35:41 +00:00
digest
2021-05-14 07:22:01 +00:00
in
(aindex, res)
in
2021-07-08 17:16:56 +00:00
tangibles `V.update`
2021-07-25 08:11:28 +00:00
V.map
updater
(A.log
A.Debug
("Collision partners: " <>
fromString (show collisionPartners))
collisionPartners
)
(newCast, newPowerups, mnewCat@(Just _)) = V.foldl
2021-07-24 01:33:00 +00:00
(\acc@(castAcc, pAcc, _) input ->
case input of
TCast c ->
2021-09-05 08:46:33 +00:00
(castAcc `V.snoc` updateByEuler c dt, pAcc, mnewCat)
TPowerUp p ->
2021-09-05 08:46:33 +00:00
(castAcc, pAcc `V.snoc` updateByEuler p dt, mnewCat)
2021-07-24 01:33:00 +00:00
TPlayer ncat ->
2021-09-05 08:46:33 +00:00
(castAcc, pAcc, Just (updateByEuler ncat dt))
2021-07-24 01:33:00 +00:00
TTile _ ->
acc
)
(V.empty, V.empty, Nothing)
collidedTangibles
writeTVar (testCast level) newCast
writeTVar (testPowerups level) newPowerups
writeTVar (testPlayer level) mnewCat