{-# 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 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 if res /= NoCollision && qInd /= index then jacc `V.snoc` (qInd, res) else jacc ) V.empty indexedTangibles in if V.null partners then iacc else iacc `V.snoc` ( index , head (sortOn (collisionTime . snd) (V.toList partners)) ) ) V.empty indexedTangibles updater (aindex, partner) = let aobject = (snd $ indexedTangibles V.! aindex) res = (\(pindex, presult) -> let inter = collide aobject (snd $ indexedTangibles V.! pindex) presult in inter ) partner in (aindex, res) in tangibles `V.update` V.map updater collisionPartners (newCast, newPowerups, mnewCat@(Just _)) = V.foldl (\acc@(castAcc, pAcc, _) input -> case input of TCast c -> (castAcc `V.snoc` move dt c, pAcc, mnewCat) TPowerUp p -> (castAcc, pAcc `V.snoc` move dt p, mnewCat) TPlayer ncat -> (castAcc, pAcc, Just (move dt ncat)) TTile _ -> acc ) (V.empty, V.empty, Nothing) collidedTangibles writeTVar (testCast level) newCast writeTVar (testPowerups level) newPowerups writeTVar (testPlayer level) mnewCat -- oldCast <- V.map (\(Cast c) -> Cast $ perform dt c) <$> -- readTVar (testCast level) -- oldCat <- perform dt <$> fromJust <$> readTVar (testPlayer level) -- 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, NoCollision) -- playedCast -- in -- if null partners -- then Cast c1 -- else -- uncurry -- (\(Cast c2) result -> Cast $ collide c1 c2 result) -- partners -- ) -- playedCast -- wallCast (Cast c) = -- Cast $ performWorldCollision c layer dt -- walledCast = -- V.map wallCast collidedCast -- cattedCast = V.map -- (\(Cast c) -> -- Cast $ collide c oldCat $ collisionCheck dt c oldCat -- ) -- walledCast -- in -- V.map -- (\(Cast c) -> Cast $ -- move dt c -- ) -- walledCast -- releasedEffects <- stateTVar (testPowerups level) $ \pus -> -- let living = V.foldl -- (\acc pu -> -- let npu = perform dt pu -- in -- if puTTL npu > 0 -- then npu `V.cons` acc -- else acc -- ) -- V.empty -- pus -- indexCollected = V.filter ((/= NoCollision) . snd) $ -- V.zip (V.fromList [0..length living]) -- (V.map -- (collisionCheck dt oldCat) -- living -- ) -- collected = V.foldl -- (\acc (ind, _) -> -- (living V.! ind) `V.cons` acc -- ) -- V.empty -- indexCollected -- differ = V.foldl -- (\acc life -> if life `V.elem` collected -- then acc -- else life `V.cons` acc -- ) -- V.empty -- living -- fin = V.map -- (\pu -> move dt $ performWorldCollision pu layer dt) -- differ -- in -- (collected, fin) -- modifyTVar -- (testPlayer level) $ \(Just pituicat) -> -- let playedCat = perform dt pituicat -- castCat = -- let allPartners = V.zip (V.fromList [0..V.length oldCast]) -- (V.map -- (\(Cast c) -> collisionCheck dt playedCat c) -- oldCast -- ) -- filtered = (V.filter ((/= NoCollision) . snd) allPartners) -- partner = V.minimumBy -- (\(_, e) (_, f) -> collisionTime e `compare` collisionTime f) -- filtered -- in -- if V.null filtered -- then -- playedCat -- else -- uncurry -- (\(Cast c) cr -> collide playedCat c cr) -- (oldCast V.! fst partner, snd partner) -- walledCat = performWorldCollision castCat layer dt -- affectedCat = walledCat -- { pcEffects = pcEffects walledCat ++ -- map puEffect (V.toList releasedEffects) -- } -- in Just $ move dt affectedCat performWorldCollision :: (Collidible c) => c -- ^ Cast member to check -> Layer -- ^ The walk layer of the level -> Double -- ^ Tick length -> c -- ^ Updated cast member performWorldCollision c layer dt = let partner = V.foldl (\acc@(part, cr) tile -> let res = collisionCheck dt c tile ret = if cr == NoCollision && res == NoCollision then acc else if cr == NoCollision && res /= NoCollision then (tile, res) else if cr /= NoCollision && res == NoCollision then acc else if collisionTime cr < collisionTime res then acc else (tile, res) in ret ) (V.head layer, collisionCheck dt c $ V.head layer) layer in uncurry (collide c) partner