2021-01-11 09:33:20 +00:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
2021-03-22 05:36:28 +00:00
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
2021-07-08 16:39:31 +00:00
|
|
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
2021-01-11 09:33:20 +00:00
|
|
|
module Scenes.Test.Update where
|
|
|
|
|
2021-04-17 09:33:28 +00:00
|
|
|
import Affection as A
|
2021-01-11 09:33:20 +00:00
|
|
|
|
|
|
|
import Control.Concurrent.STM
|
|
|
|
|
2021-07-08 16:39:31 +00:00
|
|
|
import Data.List (sortOn)
|
|
|
|
|
2021-01-11 09:33:20 +00:00
|
|
|
import qualified Data.Vector as V
|
|
|
|
|
2021-03-22 05:36:28 +00:00
|
|
|
import Data.Maybe
|
|
|
|
|
2021-01-11 09:33:20 +00:00
|
|
|
import Data.String (fromString)
|
|
|
|
|
2021-02-27 15:08:45 +00:00
|
|
|
import Linear
|
|
|
|
|
2021-01-11 09:33:20 +00:00
|
|
|
-- internal imports
|
|
|
|
|
|
|
|
import Scenes.Test.Types
|
|
|
|
import Classes
|
|
|
|
import Types
|
2021-04-29 18:28:52 +00:00
|
|
|
import Physics
|
2021-01-11 09:33:20 +00:00
|
|
|
|
|
|
|
update
|
|
|
|
:: Test
|
|
|
|
-> Double
|
|
|
|
-> Affection ()
|
|
|
|
update level dt = liftIO $ do
|
|
|
|
logIO Debug ("FPS: " <> fromString (show $ 1 / dt))
|
|
|
|
|
|
|
|
atomically $ do
|
|
|
|
lmap <- readTMVar (testMap level)
|
2021-07-08 16:39:31 +00:00
|
|
|
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)
|
2021-01-11 09:33:20 +00:00
|
|
|
let layer = mapLayers lmap V.! fromIntegral (mapWalkLayer lmap)
|
2021-07-08 16:39:31 +00:00
|
|
|
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
|
2021-05-14 07:22:01 +00:00
|
|
|
in
|
2021-07-08 16:39:31 +00:00
|
|
|
inter
|
2021-05-14 07:22:01 +00:00
|
|
|
)
|
2021-07-08 16:39:31 +00:00
|
|
|
partner
|
2021-05-14 07:22:01 +00:00
|
|
|
in
|
2021-07-08 16:39:31 +00:00
|
|
|
(aindex, res)
|
|
|
|
in
|
2021-07-08 17:16:56 +00:00
|
|
|
tangibles `V.update`
|
2021-07-08 16:39:31 +00:00
|
|
|
(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
|
2021-01-11 09:33:20 +00:00
|
|
|
)
|
2021-07-08 16:39:31 +00:00
|
|
|
(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
|
2021-03-22 05:36:28 +00:00
|
|
|
|
|
|
|
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
|
2021-04-16 16:46:01 +00:00
|
|
|
(\acc@(part, cr) tile ->
|
2021-03-22 05:36:28 +00:00
|
|
|
let res = collisionCheck dt c tile
|
2021-04-16 16:46:01 +00:00
|
|
|
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)
|
2021-03-22 05:36:28 +00:00
|
|
|
in
|
|
|
|
ret
|
|
|
|
)
|
2021-04-16 16:46:01 +00:00
|
|
|
(V.head layer, collisionCheck dt c $ V.head layer)
|
2021-03-22 05:36:28 +00:00
|
|
|
layer
|
|
|
|
in
|
2021-04-16 16:46:01 +00:00
|
|
|
uncurry (collide c) partner
|