From a6f08aef16d4d04e2f4fea81a0b611a5ae952d0b Mon Sep 17 00:00:00 2001 From: jgk Date: Wed, 18 Aug 2021 11:53:14 +0200 Subject: [PATCH] Move toward diagnosing state update leak --- src/Dodge/Creature/ChaseCrit.hs | 15 +++---- src/Dodge/Creature/Inanimate.hs | 5 ++- src/Dodge/Creature/Rationality.hs | 37 +++++++---------- src/Dodge/Creature/State.hs | 69 +++++++++++++++---------------- src/Dodge/Creature/Update.hs | 6 +-- src/Dodge/Creature/YourControl.hs | 12 ++++-- src/Dodge/Data.hs | 9 ++-- src/Dodge/Default.hs | 3 +- src/Dodge/Update.hs | 16 ++----- 9 files changed, 81 insertions(+), 91 deletions(-) diff --git a/src/Dodge/Creature/ChaseCrit.hs b/src/Dodge/Creature/ChaseCrit.hs index f324dee17..279d75deb 100644 --- a/src/Dodge/Creature/ChaseCrit.hs +++ b/src/Dodge/Creature/ChaseCrit.hs @@ -34,13 +34,14 @@ smallChaseCrit = chaseCrit } chaseCrit :: Creature chaseCrit = defaultCreature - { _crUpdate = stateUpdate $ impulsiveAIR $ - doStrategyActionsR >=> - performActionsR >=> - overrideMeleeCloseTargetR >=> - chaseTargetR targetYouLOS >=> - basicPerceptionUpdateR [0] >=> - targetYouWhenCognizantR >=> + { _crUpdate = stateUpdate $ --dummyUpdate + impulsiveAIR $ + --doStrategyActionsR >=> + --performActionsR >=> + --overrideMeleeCloseTargetR >=> + --chaseTargetR targetYouLOS >=> + --basicPerceptionUpdateR [0] >=> + --targetYouWhenCognizantR >=> return . (crMeleeCooldown . _Just %~ max 0 . subtract 1) , _crHP = 300 , _crPict = basicCrPict green diff --git a/src/Dodge/Creature/Inanimate.hs b/src/Dodge/Creature/Inanimate.hs index ec54902f0..8401e3f17 100644 --- a/src/Dodge/Creature/Inanimate.hs +++ b/src/Dodge/Creature/Inanimate.hs @@ -14,7 +14,7 @@ import Dodge.Creature.State import Dodge.LightSources import Dodge.WorldEvent.Flash import Dodge.WorldEvent.Sound -import Dodge.Creature.Update hiding (CRUpdate) +import Dodge.Creature.Update import Picture import qualified IntMapHelp as IM import Geometry @@ -25,6 +25,7 @@ import Polyhedra import Control.Lens import qualified Control.Foldl as L --import qualified Data.Vector.Fusion.Stream.Monadic as VS +import Data.Monoid defaultInanimate :: Creature defaultInanimate = defaultCreature & crActionPlan .~ Inanimate @@ -61,7 +62,7 @@ polyToTriFold (s:x:xs) = L.fold (lTriFold s x) xs polyToTriFold _ = [] initialiseLamp :: Float -> CRUpdate -initialiseLamp h w (f,g) cr = ( (addLS . f , g), Just $ cr & crUpdate .~ updateLamp h i) +initialiseLamp h cr _ = ( Endo addLS , Just $ cr & crUpdate .~ updateLamp h i) where i = _crID cr addLS = over lightSources (IM.insert i (lightAt (V3 x y h) i)) diff --git a/src/Dodge/Creature/Rationality.hs b/src/Dodge/Creature/Rationality.hs index 32216dcfd..dac7e7866 100644 --- a/src/Dodge/Creature/Rationality.hs +++ b/src/Dodge/Creature/Rationality.hs @@ -15,6 +15,7 @@ import qualified Data.IntMap.Strict as IM import System.Random import Control.Lens import Control.Monad.Reader +import Data.Monoid composeInternalAIs :: [World -> Creature -> Creature] @@ -25,36 +26,30 @@ composeInternalAIs fs w c = foldr ($ w) c fs impulsiveAIR :: (Creature -> Reader World Creature) - -> World - -> (World -> World, StdGen) -> Creature - -> ((World -> World, StdGen) , Maybe Creature) -impulsiveAIR impf w (f,g) = followImpulses w (f,g') . ($ w) . runReader . impf - where - (g',_) = split g + -> World + -> (Endo World , Maybe Creature) +impulsiveAIR impf cr w = followImpulses w . ($ w) . runReader $ impf cr -impulsiveAI - :: (World -> Creature -> Creature) -- ^ Internal AI update, should determine impulses - -> World - -> (World -> World,StdGen) - -> Creature - -> ((World -> World,StdGen), Maybe Creature) -impulsiveAI impF w (f,g) = followImpulses w (f,g) . impF w +--impulsiveAI +-- :: (World -> Creature -> Creature) -- ^ Internal AI update, should determine impulses +-- -> World +-- -> (World -> World,StdGen) +-- -> Creature +-- -> ((World -> World,StdGen), Maybe Creature) +--impulsiveAI impF w (f,g) = followImpulses w (f,g) . impF w -- needs cleanup followImpulses :: World - -> (World -> World,StdGen) -> Creature - -> ((World -> World,StdGen), Maybe Creature) -followImpulses w (f,g) cr - = (\(f''' ,cr') -> ((f''',g'),Just cr')) + -> (Endo World, Maybe Creature) +followImpulses w cr + = (\(f''' ,cr') -> (Endo f''',Just cr')) $ foldr - (\imp (f' , cr') -> let (f'', cr'') = followImpulse cr' w imp in (f'' . f', cr'')) - (f, cr) + (\imp (f , cr') -> let (f'', cr'') = followImpulse cr' w imp in (f'' . f , cr'')) + (id, cr) (_crImpulse $ _crActionPlan cr) - where - g' = snd $ genWord8 g followImpulse :: Creature diff --git a/src/Dodge/Creature/State.hs b/src/Dodge/Creature/State.hs index 02c228b29..d854c2d1b 100644 --- a/src/Dodge/Creature/State.hs +++ b/src/Dodge/Creature/State.hs @@ -32,24 +32,19 @@ import System.Random --import qualified Data.Map as M import Data.Monoid -type CRUpdate = World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) +dummyUpdate :: CRUpdate +dummyUpdate cr _ = (Endo id, Just cr) - -meleeCooldown :: CRUpdate -> CRUpdate -meleeCooldown u w (f,g) cr = u w (f,g) $ cr & crMeleeCooldown . _Just %~ (max 0 . (\x -> x - 1)) -- | The movement is updated before the ai in order to correctly set the oldpos. --- the whole of this update cycle could do with a rethink, it is becoming --- convoluted stateUpdate :: CRUpdate -> CRUpdate -stateUpdate u w (f,g) cr = case u w (f,g) (updateMovement g cr) of - ((f',g') , maybeCr) -> - ( (invSideEff cr . movementSideEff cr . deathEff . f' - , g') - , fmap (stepReloading . stepItemUseCooldown . doDamage . crAutoReload) $ crOrCorpse =<< maybeCr - ) +stateUpdate u cr w = case u (updateMovement cr) w of + (f, maybeCr) -> + ( Endo $ invSideEff cr . movementSideEff cr . deathEff . appEndo f + , fmap (stepReloading . stepItemUseCooldown . doDamage . crAutoReload) $ crOrCorpse =<< maybeCr + ) where - crOrCorpse cr''' - | cr''' ^. crHP > 0 = Just cr''' + crOrCorpse cr' + | cr' ^. crHP > 0 = Just cr' | otherwise = Nothing deathEff | cr ^.crHP > 0 = id @@ -80,6 +75,9 @@ velocity to carry across frames. crFriction :: Creature -> Point2 -> Point2 crFriction _ _ = V2 0 0 +meleeCooldown :: CRUpdate -> CRUpdate +meleeCooldown u cr = u $ cr & crMeleeCooldown . _Just %~ (max 0 . (\x -> x - 1)) + doDamage :: Creature -> Creature doDamage cr = set (crState . crDamage) [] $ over (crState . crPastDamage) (forceFoldable . take 10 . (dams :) ) damagedCr @@ -135,16 +133,15 @@ weaponReloadSounds cr w = case _crInv cr IM.!? _crInvSel cr of where cid = _crID cr -updateMovement :: StdGen -> Creature -> Creature -updateMovement g cr +updateMovement :: Creature -> Creature +updateMovement cr | isFrictionless cr = over crPos (+.+ momentum) $ setOldPos cr | otherwise = updateWalkCycle $ setOldPos cr where momentum' = 0.98 *.* (_crPos cr -.- _crOldPos cr) momentum'' | magV momentum' > 1 = 1 *.* normalizeV momentum' | otherwise = momentum' - momentum = momentum'' +.+ 0.01 *.* unitVectorAtAngle randAng - (randAng,_) = randomR (0,2*pi) g + momentum = momentum'' isFrictionless :: Creature -> Bool isFrictionless cr = case cr ^? crStance . carriage of @@ -169,29 +166,30 @@ decreaseToZero :: Int -> Int decreaseToZero x = max 0 (x - 1) onDeath :: (Creature -> World -> World) -> CRUpdate -> CRUpdate -onDeath h u w (f,g) cr - | _crHP cr > 0 = u w (f,g) cr - | otherwise = ( ( h cr . f, g ) , Nothing ) +onDeath h u cr w + | _crHP cr > 0 = u cr w + | otherwise = ( Endo $ h cr , Nothing ) updateBarrel - :: World - -> (World -> World,StdGen) - -> Creature - -> ((World -> World , StdGen), Maybe Creature) -updateBarrel _ (f,g) cr - | _crHP cr > 0 = ((f, g), newCr) - | otherwise = ((f, g), Nothing) + :: Creature + -> World + -> (Endo World, Maybe Creature) +updateBarrel cr _ + | _crHP cr > 0 = (Endo id, newCr) + | otherwise = (Endo id, Nothing) where newCr = Just $ doDamage cr --- it is easy to leave off the "f" here --- should find some better way of doing all this that is less prone to error -updateExpBarrel :: - World -> (World -> World,StdGen) -> Creature -> ((World -> World , StdGen), Maybe Creature) -updateExpBarrel _ (f,g) cr - | _crHP cr > 0 = ((f . foldr (.) id pierceSparks . hiss, g'), newCr) - | otherwise = ((f . makeExplosionAt (_crPos cr) . stopSounds , g'), Nothing) +-- should generate the sparks externally using new random generators +updateExpBarrel + :: Creature + -> World + -> (Endo World, Maybe Creature) +updateExpBarrel cr w + | _crHP cr > 0 = (Endo $ foldr (.) id pierceSparks . hiss, newCr) + | otherwise = (Endo $ makeExplosionAt (_crPos cr) . stopSounds , Nothing) where + g = _randGen w damages = _crDamage $ _crState cr pierceSparks :: [World -> World] pierceSparks @@ -200,7 +198,6 @@ updateExpBarrel _ (f,g) cr as = randomRs (-0.7,0.7) g colids = randomRs (0,11) g times = randomRs (2,5) g - (g',_) = split g poss = _piercedPoints $ _crSpState $ _crState cr --newCr = Just $ doDamage $ applyFuseDamage cr -- $ foldr perforate cr damages newCr = Just $ applyFuseDamage $ set (crState . crDamage) [] $ damToExpBarrel damages cr diff --git a/src/Dodge/Creature/Update.hs b/src/Dodge/Creature/Update.hs index 65419ca8c..370f74c1a 100644 --- a/src/Dodge/Creature/Update.hs +++ b/src/Dodge/Creature/Update.hs @@ -2,14 +2,14 @@ module Dodge.Creature.Update where import Dodge.Data -import System.Random +--import System.Random +import Data.Monoid -- combinators for helping with dealing with creature update -type CRUpdate = World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) unrandUpdate :: (Creature -> World -> World) -> (Creature -> Maybe Creature) -> CRUpdate {-# INLINE unrandUpdate #-} -unrandUpdate h cF _ (f,g) cr = ( ( h cr . f , g) , cF cr ) +unrandUpdate h cF cr _ = ( Endo (h cr) , cF cr ) diff --git a/src/Dodge/Creature/YourControl.hs b/src/Dodge/Creature/YourControl.hs index 4917544b2..edca86d8a 100644 --- a/src/Dodge/Creature/YourControl.hs +++ b/src/Dodge/Creature/YourControl.hs @@ -16,11 +16,15 @@ import qualified SDL --import Data.Maybe import qualified Data.Set as S import qualified Data.IntMap.Strict as IM -import System.Random +--import System.Random +import Data.Monoid {- | The AI equivalent for your control. -} -yourControl :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature) -yourControl w (f,g) cr = - ( (updateUsingInput . f, g) +yourControl + :: Creature + -> World + -> (Endo World, Maybe Creature) +yourControl cr w = + ( Endo updateUsingInput , Just . mouseActionsCr (_mouseButtons w) $ wasdWithAiming w speed 0 cr ) where diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 4241522a3..ff7fca6b7 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -44,6 +44,8 @@ import qualified Data.IntSet as IS import qualified Data.IntMap.Strict as IM import qualified Data.Map.Strict as M import SDL (Scancode, MouseButton) +import Data.Monoid +type CRUpdate = Creature -> World -> (Endo World, Maybe Creature) data World = World { _keys :: !(S.Set Scancode) , _mouseButtons :: !(S.Set MouseButton) @@ -157,10 +159,9 @@ data Creature = Creature , _crID :: Int , _crPict :: Creature -> World -> Picture , _crUpdate - :: World - -> (World -> World,StdGen) - -> Creature - -> ((World -> World,StdGen), Maybe Creature) + :: Creature + -> World + -> (Endo World, Maybe Creature) , _crRad :: Float , _crMass :: Float , _crHP :: Int diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index f050124d2..ab827e8d5 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -19,6 +19,7 @@ import Picture import Control.Lens import qualified Data.IntMap.Strict as IM import Data.List +import Data.Monoid defaultCreature :: Creature defaultCreature = Creature @@ -29,7 +30,7 @@ defaultCreature = Creature , _crMvDir = 0 , _crID = 1 , _crPict = \_ _ -> setLayer 0 $ onLayer CrLayer $ circleSolid 10 - , _crUpdate = \ _ f cr -> (f , Just cr) + , _crUpdate = \cr _ -> (Endo id , Just cr) , _crRad = 10 , _crMass = 10 , _crHP = 100 diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index c21e660d2..de71572d7 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -30,7 +30,7 @@ import qualified Data.IntMap.Lazy as IM import qualified Data.Map as M import Control.Lens import Data.Monoid -import System.Random +--import System.Random update :: World -> World update = update' . pushSideEffects @@ -131,20 +131,10 @@ updateParticles w = set particles (catMaybes ps) w' where (w',ps) = mapAccumR (\a b -> _ptUpdate' b a b) w $ _particles w -updateCreatures' :: World -> World -updateCreatures' w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w - where - ((f,newG),crs) = - IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w) $ _creatures w - -updateToTM :: (World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)) -> World -> Creature -> (Endo World, Maybe Creature) -updateToTM u w cr = case u w (id,_randGen w) cr of - ((f,_),mcr) -> (Endo f,mcr) - updateCreatures :: World -> World -updateCreatures w = appEndo f $ creatures .~ IM.mapMaybe id m $ w +updateCreatures w = appEndo f $ w & creatures .~ IM.mapMaybe id m where - (f,m) = traverse (\cr -> updateToTM (_crUpdate cr) w cr) (_creatures w) + (f,m) = traverse (\cr -> _crUpdate cr cr w) (_creatures w) {- | Apply door mechanisms. -}