From e84b4a29e8cff65a54ac7ef23d5bfb412d425c6e Mon Sep 17 00:00:00 2001 From: justin Date: Thu, 9 Dec 2021 22:37:14 +0000 Subject: [PATCH] Cleanup --- src/Dodge/Creature.hs | 2 +- src/Dodge/Creature/Impulse.hs | 31 +++++++------- src/Dodge/Creature/Inanimate.hs | 2 +- src/Dodge/Creature/Lamp.hs | 68 ++++++++++++++++++++++++++++++ src/Dodge/Creature/ReaderUpdate.hs | 11 +++-- src/Dodge/Creature/SentinelAI.hs | 30 ++++++++----- src/Dodge/Creature/State.hs | 24 +++++++++++ src/Dodge/Creature/Update.hs | 8 +--- src/Dodge/Data.hs | 6 ++- src/Dodge/RemoveCreatureEndo.hs | 15 +++++++ 10 files changed, 154 insertions(+), 43 deletions(-) create mode 100644 src/Dodge/Creature/Lamp.hs create mode 100644 src/Dodge/RemoveCreatureEndo.hs diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 7d8e202c9..087ba3684 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -69,7 +69,7 @@ spawnerCrit = defaultCreature miniGunCrit :: Creature miniGunCrit = defaultCreature { _crPict = basicCrPict red - , _crUpdate = stateUpdate $ impulsiveAI $ + , _crUpdate = stateUpdate' $ impulsiveAI' $ sentinelFireType (const shootTillEmpty) , _crActionPlan = ActionPlan { _crImpulse = [] diff --git a/src/Dodge/Creature/Impulse.hs b/src/Dodge/Creature/Impulse.hs index e8148ae61..25f8a15d3 100644 --- a/src/Dodge/Creature/Impulse.hs +++ b/src/Dodge/Creature/Impulse.hs @@ -1,6 +1,7 @@ module Dodge.Creature.Impulse ( impulsiveAIR , impulsiveAI + , impulsiveAI' ) where import Dodge.Data import Dodge.Creature.Vocalization @@ -20,31 +21,29 @@ impulsiveAIR -> Creature -> World -> (World -> World , Maybe Creature) -impulsiveAIR impf cr w = bimap id Just $ followImpulses w . ($ w) . runReader $ impf cr +impulsiveAIR impf cr w = second Just $ followImpulses w . ($ w) . runReader $ impf cr impulsiveAI :: (World -> Creature -> Creature) -> Creature -> World -> (World -> World , Maybe Creature) -impulsiveAI impf cr w = bimap id Just $ followImpulses w $ impf w cr +impulsiveAI impf cr w = second Just $ followImpulses w $ impf w cr -followImpulses - :: World - -> Creature - -> (World -> World, Creature) -followImpulses w cr - = foldr - foldf - (id, cr) - (_crImpulse $ _crActionPlan cr) +impulsiveAI' :: (World -> Creature -> Creature) + -> Creature + -> World + -> (World -> World , Creature) +impulsiveAI' impf cr w = followImpulses w $ impf w cr + +followImpulses :: World -> Creature -> (World -> World, Creature) +followImpulses w cr = foldr + foldf + (id, cr) + (_crImpulse $ _crActionPlan cr) where foldf imp (f,cr') = first ( . f) $ followImpulse cr' w imp -followImpulse - :: Creature - -> World - -> Impulse - -> (World -> World , Creature) +followImpulse :: Creature -> World -> Impulse -> (World -> World , Creature) followImpulse cr w imp = case imp of Bark sid -> (soundStart (CrMouth cid) cpos sid Nothing, resetCrVocCoolDown cr) Move p -> (id, crMvBy p cr) diff --git a/src/Dodge/Creature/Inanimate.hs b/src/Dodge/Creature/Inanimate.hs index 2353f57aa..cc05870cf 100644 --- a/src/Dodge/Creature/Inanimate.hs +++ b/src/Dodge/Creature/Inanimate.hs @@ -65,7 +65,7 @@ updateBarrel cr -- should generate the sparks externally using new random generators updateExpBarrel :: Creature -> World -> World updateExpBarrel cr w - | _crHP cr > 0 = foldr (.) id pierceSparks $ hiss w & creatures . at (_crID cr) .~ newCr + | _crHP cr > 0 = foldr ($) (hiss w & creatures . at (_crID cr) .~ newCr) pierceSparks | otherwise = makeExplosionAt (_crPos cr) $ stopSounds w & creatures . at (_crID cr) .~ Nothing where g = _randGen w diff --git a/src/Dodge/Creature/Lamp.hs b/src/Dodge/Creature/Lamp.hs new file mode 100644 index 000000000..9dad395aa --- /dev/null +++ b/src/Dodge/Creature/Lamp.hs @@ -0,0 +1,68 @@ +module Dodge.Creature.Lamp + ( lamp + , colorLamp + ) where +import Dodge.Data +import Dodge.Default +import Dodge.Creature.Picture +import Dodge.LightSource +import Dodge.WorldEvent.Flash +import Dodge.WorldEvent.Sound +import Dodge.Creature.State +import Geometry +import Picture +import Polyhedra +import qualified IntMapHelp as IM +import LensHelp + +colorLamp + :: Point3 -- color of lamp + -> Float -- height of lamp + -> Creature +colorLamp col h = defaultInanimate + { _crUpdate = initialiseColorLamp col h + , _crHP = 100 + , _crPict = picAtCrPosNoRot (lampCrPic h) + , _crRad = 3 + , _crMass = 3 + } + +lamp :: Float -> Creature +lamp h = defaultInanimate + { _crUpdate = initialiseLamp h + , _crHP = 100 + , _crPict = picAtCrPosNoRot (lampCrPic h) + , _crRad = 3 + , _crMass = 3 + } +lampCrPic :: Float -> Picture +lampCrPic h = pictures + [ setLayer 1 (setDepth h . color white $ circleSolid 3) + , concatMap (polyToTris . map f) $ boxXYZnobase 5 5 (h-1) + ] + where + f pos = Verx (pos -.-.- V3 2.5 2.5 0) blue [] 0 polyNum + +initialiseLamp :: Float -> Creature -> World -> World +initialiseLamp = initialiseColorLamp 0.75 + +initialiseColorLamp :: Point3 -> Float -> Creature -> World -> World +initialiseColorLamp col h cr w = w + & lightSources . at lsid ?~ lsColPosID col (addZ h $ _crPos cr) lsid + & creatures . ix (_crID cr) . crUpdate .~ updateLamp h lsid + where + lsid = IM.newKey $ _lightSources w + +updateLamp :: Float -> Int -> Creature -> World -> World +updateLamp h i cr w + | _crHP cr < 0 = w + & explosionFlashAt cpos + & mkSoundBreakGlass cpos + & lightSources . at i .~ Nothing + & creatures . at cid .~ Nothing + | otherwise = w + & lightSources . ix i . lsParam . lsPos .~ addZ h cpos + & creatures . ix cid %~ doDamage + where + cpos = _crPos cr + cid = _crID cr diff --git a/src/Dodge/Creature/ReaderUpdate.hs b/src/Dodge/Creature/ReaderUpdate.hs index b70c15528..5ac4a4ea6 100644 --- a/src/Dodge/Creature/ReaderUpdate.hs +++ b/src/Dodge/Creature/ReaderUpdate.hs @@ -121,14 +121,14 @@ doStrategyActionsR cr = return $ case cr ^? crActionPlan . crStrategy of & crActionPlan . crStrategy .~ strat _ -> cr -doStrategyActions :: World -> Creature -> Creature -doStrategyActions w cr = case cr ^? crActionPlan . crStrategy of +doStrategyActions :: Creature -> Creature +doStrategyActions cr = case cr ^? crActionPlan . crStrategy of Just (StrategyActions strat acs) -> cr & crActionPlan . crAction .~ acs & crActionPlan . crStrategy .~ strat _ -> cr -reloadOverride :: World -> Creature -> Creature -reloadOverride w cr +reloadOverride :: Creature -> Creature +reloadOverride cr | cr ^? crInv . ix (_crInvSel cr) . itConsumption . ammoLoaded == Just 0 && cr ^. crStance . posture == Aiming = cr & crActionPlan . crStrategy .~ StrategyActions Reload reloadActions @@ -163,10 +163,9 @@ overrideInternalRRR test update cr = do overrideInternal :: (Creature -> Bool) -> (Creature -> Creature) - -> World -> Creature -> Creature -overrideInternal test update w cr +overrideInternal test update cr | test cr = update cr | otherwise = cr diff --git a/src/Dodge/Creature/SentinelAI.hs b/src/Dodge/Creature/SentinelAI.hs index ce32608b3..6334a4baf 100644 --- a/src/Dodge/Creature/SentinelAI.hs +++ b/src/Dodge/Creature/SentinelAI.hs @@ -41,13 +41,21 @@ sentinelAI = sentinelExtraWatchUpdate tcid cr = _crID <$> _targetCr (_crIntention cr) lostest (w,cr) = maybe False (\cid -> canSee (_crID cr) cid w) (tcid cr) -chainCreatureUpdates :: [World -> Creature -> Creature] -> World -> Creature -> Creature -chainCreatureUpdates ls w cr = foldr (\f -> f w) cr ls +--chainCreatureUpdates :: [World -> Creature -> Creature] -> World -> Creature -> Creature +--chainCreatureUpdates ls w cr = foldr (\f -> f w) cr ls + +chainCreatureUpdatesLR + :: [Either (World -> Creature -> Creature) (Creature -> Creature)] + -> World -> Creature -> Creature +chainCreatureUpdatesLR ls w cr = foldr unf cr ls + where + unf (Left g) = g w + unf (Right g) = g sentinelFireType :: (Int -> Action) -> World -> Creature -> Creature -sentinelFireType f = chainCreatureUpdates - [ performActions - , watchUpdateStrat +sentinelFireType f = chainCreatureUpdatesLR + [ Left performActions + , Left $ watchUpdateStrat [ (crHasTargetLOS, \_ _ -> StrategyActions (ShootAt 0) [ drawwp `DoActionThen` f 0 `DoActionThen` DoImpulses [ChangeStrategy WatchAndWait] , aiming @@ -55,13 +63,13 @@ sentinelFireType f = chainCreatureUpdates ) , (crAwayFromPost, goToPostStrat) ] - , perceptionUpdate' [0] - , doStrategyActions - , reloadOverride - , targetYouWhenCognizant - , overrideInternal + , Left $ perceptionUpdate' [0] + , Right doStrategyActions + , Right reloadOverride + , Left targetYouWhenCognizant + , Right $ overrideInternal (\cr -> crHasTarget' cr && crStratConMatches' (GetTo (V2 0 0)) cr) - ((crActionPlan . crStrategy .~ WatchAndWait)) + (crActionPlan . crStrategy .~ WatchAndWait) ] where drawwp = DoActionIfElse NoAction crIsAiming (DoActionThen drawWeapon (WaitThen 50 NoAction)) diff --git a/src/Dodge/Creature/State.hs b/src/Dodge/Creature/State.hs index ec622e96f..4f01305a9 100644 --- a/src/Dodge/Creature/State.hs +++ b/src/Dodge/Creature/State.hs @@ -1,5 +1,6 @@ module Dodge.Creature.State ( stateUpdate + , stateUpdate' , stateUpdateDamage , doDamage , clearDamage @@ -45,6 +46,10 @@ stateUpdate :: CRUpdate -> Creature -> World -> World stateUpdate f cr w = let (fw,mcr) = stateUpdateDamage doDamage f cr w in fw $ w & creatures . at (_crID cr) .~ mcr +stateUpdate' :: CRUpdate' -> Creature -> World -> World +stateUpdate' f cr w = let (fw,mcr) = stateUpdateDamage' doDamage f cr w + in fw $ w & creatures . at (_crID cr) .~ mcr + stateUpdateDamage :: (Creature -> Creature) -> CRUpdate -> CRUpdate stateUpdateDamage damageupdate u cr w = case u (updateMovement cr) w of (f, maybeCr) -> @@ -64,6 +69,25 @@ stateUpdateDamage damageupdate u cr w = case u (updateMovement cr) w of $ uncurryV translate (_crOldPos cr) $ rotate (_crDir cr) (_crCorpse cr) +stateUpdateDamage' :: (Creature -> Creature) -> CRUpdate' -> CRUpdate +stateUpdateDamage' damageupdate u cr w = case u (updateMovement cr) w of + (f, upcr) -> + ( invSideEff upcr . movementSideEff cr . deathEff . f + , (stepReloading . damageupdate) <$> crOrCorpse upcr + ) + where + crOrCorpse cr' + | cr' ^. crHP > 0 = Just cr' + | otherwise = Nothing + deathEff + | cr ^.crHP > 0 = id + | otherwise = stopSoundFrom (CrWeaponSound (_crID cr) 0) + . over decorations addCorpse + . dropByState cr + addCorpse = IM.insertNewKey + $ uncurryV translate (_crOldPos cr) + $ rotate (_crDir cr) + (_crCorpse cr) -- | Drop items according to the creature state. dropByState :: Creature -> World -> World dropByState cr w = foldr (copyInvItemToFloor cr) w is diff --git a/src/Dodge/Creature/Update.hs b/src/Dodge/Creature/Update.hs index e54284e15..859663989 100644 --- a/src/Dodge/Creature/Update.hs +++ b/src/Dodge/Creature/Update.hs @@ -3,10 +3,6 @@ module Dodge.Creature.Update ) where import Dodge.Data - -unrandUpdate - :: (Creature -> World -> World) - -> (Creature -> Maybe Creature) - -> CRUpdate +unrandUpdate :: (Creature -> World -> World) -> (Creature -> Maybe Creature) -> CRUpdate {-# INLINE unrandUpdate #-} -unrandUpdate h cF cr _ = ( (h cr) , cF cr ) +unrandUpdate h cF cr _ = ( h cr , cF cr ) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 610eb7b62..b7665cd03 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -53,6 +53,8 @@ import qualified Data.IntMap.Strict as IM import qualified Data.Map.Strict as M import SDL (Scancode, MouseButton) type CRUpdate = Creature -> World -> (World -> World, Maybe Creature) +type CRUpdate' = Creature -> World -> (World -> World, Creature) + data Universe = Universe { _uvWorld :: World , _preloadData :: PreloadData @@ -78,7 +80,7 @@ data World = World , _props :: IM.IntMap Prop , _instantParticles :: [Particle] , _particles :: [Particle] - , _walls :: (IM.IntMap Wall) + , _walls :: IM.IntMap Wall , _doors :: IM.IntMap Door , _machines :: IM.IntMap Machine , _magnets :: IM.IntMap Magnet @@ -109,7 +111,7 @@ data World = World , _carteCenter :: Point2 , _carteZoom :: Float , _carteRot :: Float - , _lightSources :: (IM.IntMap LightSource) + , _lightSources :: IM.IntMap LightSource , _tempLightSources :: [TempLightSource] , _closeObjects :: [Either FloorItem Button] , _seenLocations :: IM.IntMap (World -> Point2,String) diff --git a/src/Dodge/RemoveCreatureEndo.hs b/src/Dodge/RemoveCreatureEndo.hs new file mode 100644 index 000000000..9751581ac --- /dev/null +++ b/src/Dodge/RemoveCreatureEndo.hs @@ -0,0 +1,15 @@ +-- | stopgap module, making creature update simpler +-- should probably end up removed after further refactoring +module Dodge.RemoveCreatureEndo + ( + toCrUpdate' + )where +import Dodge.Data +import Control.Lens + +toCrUpdate' :: (Creature -> World -> (World -> World, Maybe Creature)) + -> Creature + -> World + -> World +toCrUpdate' f cr w = let (fw,mcr) = f cr w + in fw $ w & creatures . at (_crID cr) .~ mcr