{-# 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