pituicat/src/Scenes/Test/Update.hs

255 lines
8.4 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)
import Linear
-- 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
(\acc (index, tangible1) ->
let partners =
V.foldl
(\acc (qInd, tangible2) ->
let res = collisionCheck dt tangible1 tangible2
in
if res /= NoCollision && qInd /= index
then acc `V.snoc` (qInd, res)
else acc
)
V.empty
indexedTangibles
in
if V.null partners
then acc
else acc `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, puAcc, mcat) input ->
case input of
TCast c ->
(castAcc `V.snoc` move dt c, puAcc, mnewCat)
TPowerUp p ->
(castAcc, puAcc `V.snoc` move dt p, mnewCat)
TPlayer cat ->
(castAcc, puAcc, Just (move dt cat))
TTile t ->
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