136 lines
4.3 KiB
Haskell
136 lines
4.3 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
|
module Scenes.Test.Update where
|
|
|
|
import Affection as A
|
|
|
|
import Linear
|
|
|
|
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
|