Cleanup actions/impulses

2025-10-18 18:01:14 +01:00
parent 4542a6cea6
commit b8f6a29e28
4 changed files with 79 additions and 82 deletions
@@ -11,48 +11,44 @@ module Dodge.Creature.Action (
    youDropItem,
 ) where

-import Data.Foldable
-import Linear
-import NewInt
-import Dodge.Creature.MoveType
-import Dodge.Creature.Radius
-import Dodge.Item.BackgroundEffect
 import Control.Applicative
 import Control.Monad
 import Data.Bifunctor
+import Data.Foldable
 import Data.Maybe
 import Dodge.Base
 import Dodge.Creature.Action.Blink
+import Dodge.Creature.Impulse
+import Dodge.Creature.MoveType
+import Dodge.Creature.Radius
 import Dodge.CreatureEffect
 import Dodge.Data.World
 import Dodge.FloatFunction
 import Dodge.FloorItem
 import Dodge.Inventory
+import Dodge.Item.BackgroundEffect
 import Dodge.Path
 import Dodge.SoundLogic
 import Geometry
 import qualified IntMapHelp as IM
 import LensHelp
-import Dodge.Creature.Impulse
-
--performActions :: World -> Creature -> ([Impulse],Creature)
--performActions w cr = (concat iss
--    , cr & crActionPlan . apAction .~ catMaybes mayas)
--  where
--    (iss, mayas) = unzip $ map (performAction cr w) $ cr ^. crActionPlan . apAction
+import Linear
+import NewInt

 performActions :: Int -> World -> World
-performActions cid w = foldl' (followImpulse cid) 
-    (w & cWorld . lWorld . creatures . ix cid . crActionPlan . apAction .~ catMaybes mayas)
-    (concat iss)
+performActions cid w =
+    foldl'
+        (followImpulse cid)
+        (w & cWorld . lWorld . creatures . ix cid . crActionPlan . apAction .~ mayas)
+        iss
  where
    cr = w ^?! cWorld . lWorld . creatures . ix cid
-    (iss, mayas) = unzip $ map (performAction cr w) $ cr ^. crActionPlan . apAction
+    (iss, mayas) = foldMap (performAction cr w) $ cr ^. crActionPlan . apAction

-type OutAction = ([Impulse], Maybe Action)
+type OutAction = ([Impulse], [Action])

 performAimAt :: Creature -> World -> Int -> Point2 -> OutAction
-performAimAt cr w tcid p = ([TurnToward tpos aimSp], Just $ AimAt tcid tpos)
+performAimAt cr w tcid p = ([TurnToward tpos aimSp], [AimAt tcid tpos])
  where
    cdir = _crDir cr
    cpos = cr ^. crPos . _xy
@@ -66,8 +62,11 @@ performAimAt cr w tcid p = ([TurnToward tpos aimSp], Just $ AimAt tcid tpos)

 performPathTo :: Creature -> World -> Point2 -> OutAction
 performPathTo cr w p
-    | dist cpos p <= crRad (cr ^. crType) = ([], Nothing)
-    | isWalkable cpos p w = ([MvTurnToward 0 cpos p p, MvForward, RandomTurn jit], Just (PathTo p))
+    | dist cpos p <= crRad (cr ^. crType) = ([], [])
+    | isWalkable cpos p w =
+        ( [MvTurnToward 0 cpos p p, MvForward, RandomTurn jit]
+        , [PathTo p]
+        )
    | otherwise = case pointTowardsImpulse cpos p w of
        Just q ->
            (
@@ -75,17 +74,17 @@ performPathTo cr w p
                , MvForward
                , RandomTurn jit
                ]
-            , Just (PathTo p)
+            , [PathTo p]
            )
-        _ -> ([ChangeStrategy Flee], Nothing)
+        _ -> ([ChangeStrategy Flee], [])
  where
    cpos = cr ^. crPos . _xy
    jit = _mvTurnJit $ crMvType cr

 performTurnToA :: Creature -> Point2 -> OutAction
 performTurnToA cr p
-    | angleVV cdirv dirv < 0.1 = ([], Nothing)
-    | otherwise = ([MvTurnToward 2 p p p, RandomTurn jit], Just (TurnToPoint p))
+    | angleVV cdirv dirv < 0.1 = ([], [])
+    | otherwise = ([MvTurnToward 2 p p p, RandomTurn jit], [TurnToPoint p])
  where
    cpos = cr ^. crPos . _xy
    cdirv = unitVectorAtAngle (_crDir cr)
@@ -97,54 +96,54 @@ performTurnToA cr p
 -}
 performAction :: Creature -> World -> Action -> OutAction
 performAction cr w ac = case ac of
-    ActionNothing -> ([], Nothing)
+    ActionNothing -> ([], mempty)
    LabelAction str subAc -> second (fmap (LabelAction str)) $ performAction cr w subAc
    AimAt tcid p -> performAimAt cr w tcid p
-    WaitThen 0 newAc -> ([], Just newAc)
-    WaitThen t newAc -> ([], Just (WaitThen (t -1) newAc))
-    ImpulsesList (xs : xss) -> (xs, Just $ ImpulsesList xss)
-    ImpulsesList _ -> ([], Nothing)
-    DoImpulses imps -> (imps, Nothing)
-    DoActionThen fsta afta -> case performAction cr w fsta of
-        (imps, Just nxta) -> (imps, Just (DoActionThen nxta afta))
-        (imps, Nothing) -> (imps, Just afta)
+    WaitThen 0 newAc -> ([], [newAc])
+    WaitThen t newAc -> ([], [WaitThen (t -1) newAc])
+    ImpulsesList (xs : xss) -> (xs, [ImpulsesList xss])
+    ImpulsesList _ -> ([], mempty)
+    DoImpulses imps -> (imps, mempty)
+    DoActionThen fsta afta -> case performAction cr w fsta of -- NOTE this only does ONE continuation action
+        (imps, nxta : _) -> (imps, [DoActionThen nxta afta])
+        (imps, []) -> (imps, [afta])
    DoActionWhile f act -> performAction cr w $ DoActionWhilePartial act f act
    DoActionWhilePartial partAc f resetAc
        | doWdCrBl f w cr -> case performAction cr w partAc of
-            (imps, Just nxta) -> (imps, Just $ DoActionWhilePartial nxta f resetAc)
-            (imps, Nothing) -> (imps, Just $ DoActionWhilePartial resetAc f resetAc)
+            (imps, nxta : _) -> (imps, [DoActionWhilePartial nxta f resetAc])
+            (imps, []) -> (imps, [DoActionWhilePartial resetAc f resetAc])
        | otherwise -> performAction cr w partAc
    DoActionIf f ifa
        | doWdCrBl f w cr -> performAction cr w ifa
-        | otherwise -> ([], Nothing)
+        | otherwise -> ([], mempty)
    DoActionIfElse ifa f elsea
        | doWdCrBl f w cr -> performAction cr w ifa
        | otherwise -> performAction cr w elsea
    DoActionWhileInterrupt repa f afta
-        | doWdCrBl f w cr -> (fst $ performAction cr w repa, Just $ DoActionWhileInterrupt repa f afta)
+        | doWdCrBl f w cr -> (fst $ performAction cr w repa, [DoActionWhileInterrupt repa f afta])
        | otherwise -> performAction cr w afta
-    DoActions [] -> ([], Nothing)
+    DoActions [] -> ([], mempty)
    DoActions acs ->
-        let (imps, newAcs) = unzip $ map (performAction cr w) acs
-         in (concat imps, Just . DoActions $ catMaybes newAcs)
-    StartSentinelPost -> ([AddGoal $ SentinelAt (cr ^. crPos . _xy) (_crDir cr)], Nothing)
+        let (imps, newAcs) = foldMap (performAction cr w) acs
+         in (imps, newAcs)
+    StartSentinelPost -> ([AddGoal $ SentinelAt (cr ^. crPos . _xy) (_crDir cr)], mempty)
    PathTo p -> performPathTo cr w p
    TurnToPoint p -> performTurnToA cr p
-    LeadTarget p -> fromMaybe ([],Nothing) $ do
-        i <- cr ^? crIntention . targetCr . _Just 
+    LeadTarget p -> fromMaybe ([], mempty) $ do
+        i <- cr ^? crIntention . targetCr . _Just
        tcr <- w ^? cWorld . lWorld . creatures . ix i
-        return ([TurnTo (tcr ^. crPos . _xy +.+ rotateV (_crDir tcr) p)], Nothing)
+        return ([TurnTo (tcr ^. crPos . _xy +.+ rotateV (_crDir tcr) p)], mempty)
    UseSelf f -> performAction cr w $ doCrAc f cr
    ArbitraryAction f -> performAction cr w (doCrWdAc f cr w)
    DoImpulsesAlongside sideImp mainAc -> case performAction cr w mainAc of
-        (imp, Just nxtac) -> (sideImp ++ imp, Just $ DoImpulsesAlongside sideImp nxtac)
-        (imp, _) -> (sideImp ++ imp, Nothing)
+        (imp, [nxtac]) -> (sideImp ++ imp, [DoImpulsesAlongside sideImp nxtac])
+        (imp, _) -> (sideImp ++ imp, mempty)
    DoReplicate t nxtac -> performAction cr w $ DoReplicatePartial nxtac t nxtac
    DoReplicatePartial _ 0 pac -> performAction cr w pac
    DoReplicatePartial startac t partac -> case performAction cr w partac of
-        (imps, Just nextac) -> (imps, Just $ DoReplicatePartial startac t nextac)
-        (imps, _) -> (imps, Just $ DoReplicatePartial startac (t -1) startac)
-    NoAction -> ([], Nothing)
+        (imps, [nextac]) -> (imps, [DoReplicatePartial startac t nextac])
+        (imps, _) -> (imps, [DoReplicatePartial startac (t -1) startac])
+    NoAction -> ([], mempty)

 --setMinInvSize :: Int -> Creature -> World -> World
 --setMinInvSize n cr = cWorld . lWorld . creatures . ix (_crID cr) . crInvCapacity .~ n
@@ -171,7 +170,7 @@ performAction cr w ac = case ac of
 dropExcept :: Creature -> Int -> World -> World
 dropExcept cr invid w =
    foldr (dropItem cr) w . IM.keys $
--        invid `IM.delete` _crInv cr
+        --        invid `IM.delete` _crInv cr
        invid `IM.delete` _unNIntMap (_crInv cr)

 -- why not a cid (Int)?
@@ -180,8 +179,8 @@ dropItem cr invid w' =
    doanyitemdropeffect
        . maybeshiftseldown
        . copyItemToFloor (cr ^. crPos . _xy) itm -- . mayberemoveequip
-        . rmInvItem (_crID cr) (NInt invid) -- it is important 
-            -- to do this before copying the item to the floor!
+        . rmInvItem (_crID cr) (NInt invid) -- it is important
+        -- to do this before copying the item to the floor!
        . soundStart (CrSound (_crID cr)) (cr ^. crPos . _xy) whiteNoiseFadeOutS Nothing
        $ w'
  where
@@ -204,7 +203,7 @@ youDropItem w = fromMaybe w $ do
            <|> fmap fst (IM.lookupMax (cr ^. crInv . unNIntMap))
    guard $ not $ w ^. cWorld . lWorld . lInvLock
    return $ case cr ^. crStance . posture of
-        Aiming {} -> throwItem w
+        Aiming{} -> throwItem w
        AtEase -> dropItem cr curpos w
  where
    cr = you w
@@ -1,3 +1,4 @@
+{-# LANGUAGE LambdaCase #-}
 --{-# LANGUAGE TupleSections #-}

 module Dodge.Creature.Impulse (followImpulse) where
@@ -21,7 +22,7 @@ import System.Random

 -- note SwitchToItem doesn't necessarily update the root item correctly
 followImpulse :: Int -> World -> Impulse -> World
-followImpulse cid w imp = case imp of
+followImpulse cid w = \case
    ImpulseNothing -> w
    RandomImpulse rimp ->
        let (newimp, newgen) = runState (doRandImpulse rimp) (_randGen w)
@@ -41,7 +42,7 @@ followImpulse cid w imp = case imp of
    Melee cid' ->
        hitCr cid' $
            crup
-                ( (crMvAbsolute (w ^. cWorld . lWorld) (10 *.* normalizeV (posFromID cid' -.- cpos))) . (crType . meleeCooldown .~ 20)
+                ( crMvAbsolute (w ^. cWorld . lWorld) (10 *.* normalizeV (posFromID cid' -.- cpos)) . (crType . meleeCooldown .~ 20)
                )
    RandomTurn a ->
        let (aa, g) = rr a
@@ -138,9 +138,7 @@ data Action
        }
    | NoAction
    | StartSentinelPost
-    | UseSelf
-        { _useSelf :: CrAc
-        }
+    | UseSelf { _useSelf :: CrAc }
    | ArbitraryAction {_arbitraryAction :: CrWdAc}
 -- | Repeatedly perform impulses alongside a main action until the main action terminates
    | DoImpulsesAlongside
@@ -932,7 +932,7 @@ Opaque	src/Dodge/Data/Wall.hs	44;"	C
 OpticScope	src/Dodge/Data/Item/Scope.hs	14;"	C
 OptionScreen	src/Dodge/Data/Universe.hs	82;"	C
 OptionScreenFlag	src/Dodge/Data/Universe.hs	72;"	t
-OutAction	src/Dodge/Creature/Action.hs	42;"	t
+OutAction	src/Dodge/Creature/Action.hs	46;"	t
 OutLink	src/Dodge/Data/Room.hs	44;"	C
 OutsideTerminal	src/Dodge/Data/Input.hs	30;"	C
 OutwardShockwave	src/Dodge/Data/Shockwave.hs	14;"	C
@@ -2806,12 +2806,12 @@ chaseCritMv	src/Dodge/Creature/ReaderUpdate.hs	120;"	f
 chaseCritPerceptionUpdate	src/Dodge/Creature/Perception.hs	32;"	f
 chaseCritVocalization	src/Dodge/Creature/ChaseCrit.hs	36;"	f
 chasmSimpleMaze	src/Dodge/Room/Tutorial.hs	180;"	f
-chasmTest	src/Dodge/Creature/Update.hs	133;"	f
+chasmTest	src/Dodge/Creature/Update.hs	132;"	f
 chasmWallToSurface	src/Dodge/Base/Collide.hs	120;"	f
 checkCombineSelectionExists	src/Dodge/DisplayInventory.hs	100;"	f
 checkConnection	src/Dodge/Inventory/Swap.hs	66;"	f
-checkDeath	src/Dodge/Creature/Update.hs	71;"	f
-checkDeath'	src/Dodge/Creature/Update.hs	74;"	f
+checkDeath	src/Dodge/Creature/Update.hs	70;"	f
+checkDeath'	src/Dodge/Creature/Update.hs	73;"	f
 checkEndGame	src/Dodge/Update.hs	768;"	f
 checkErrorGL	src/Shader/Compile.hs	255;"	f
 checkFBO	src/Framebuffer/Check.hs	6;"	f
@@ -2936,7 +2936,7 @@ copierItemUpdate	src/Dodge/Creature/State.hs	131;"	f
 copyItemToFloor	src/Dodge/FloorItem.hs	14;"	f
 corDoor	src/Dodge/Room/Room.hs	385;"	f
 cornerList	src/Preload/Render.hs	198;"	f
-corpseOrGib	src/Dodge/Creature/Update.hs	112;"	f
+corpseOrGib	src/Dodge/Creature/Update.hs	111;"	f
 corridor	src/Dodge/Room/Corridor.hs	17;"	f
 corridorBoss	src/Dodge/LockAndKey.hs	133;"	f
 corridorN	src/Dodge/Room/Corridor.hs	52;"	f
@@ -2980,7 +2980,7 @@ crShape	src/Dodge/Creature/Shape.hs	8;"	f
 crSpring	src/Dodge/Update.hs	867;"	f
 crStratConMatches	src/Dodge/Creature/Test.hs	80;"	f
 crStrength	src/Dodge/Creature/Statistics.hs	29;"	f
-crUpdate	src/Dodge/Creature/Update.hs	64;"	f
+crUpdate	src/Dodge/Creature/Update.hs	63;"	f
 crUpdateInvidLocations	src/Dodge/Inventory/Location.hs	66;"	f
 crUpdateItemLocations	src/Dodge/Inventory/Location.hs	48;"	f
 crVocalizationSound	src/Dodge/Creature/Vocalization.hs	13;"	f
@@ -3418,10 +3418,10 @@ drawWlIDs	src/Dodge/Debug/Picture.hs	393;"	f
 drawZoneCirc	src/Dodge/Debug/Picture.hs	301;"	f
 drawZoneCol	src/Dodge/Debug/Picture.hs	149;"	f
 drawZoneNearPointCursor	src/Dodge/Debug/Picture.hs	294;"	f
-dropAll	src/Dodge/Creature/Update.hs	130;"	f
-dropExcept	src/Dodge/Creature/Action.hs	161;"	f
+dropAll	src/Dodge/Creature/Update.hs	129;"	f
+dropExcept	src/Dodge/Creature/Action.hs	166;"	f
 dropInventoryPath	src/Dodge/HeldUse.hs	1351;"	f
-dropItem	src/Dodge/Creature/Action.hs	168;"	f
+dropItem	src/Dodge/Creature/Action.hs	173;"	f
 dropper	src/Dodge/Item/Scope.hs	76;"	f
 drumMag	src/Dodge/Item/Ammo.hs	34;"	f
 dsZoneSize	src/Dodge/Zoning/Cloud.hs	42;"	f
@@ -3562,8 +3562,7 @@ foamSprayLoopS	src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs	554;"	f
 foldMTRS	src/Dodge/Room/Tutorial.hs	58;"	f
 foldPairs	src/ListHelp.hs	37;"	f
 foldrWhileArb	src/ListHelp.hs	110;"	f
-followImpulse	src/Dodge/Creature/Impulse.hs	30;"	f
-followImpulses	src/Dodge/Creature/Impulse.hs	24;"	f
+followImpulse	src/Dodge/Creature/Impulse.hs	23;"	f
 foot1S	src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs	486;"	f
 foot2S	src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs	510;"	f
 foot3S	src/Dodge/SoundLogic/ExternallyGeneratedSounds.hs	622;"	f
@@ -4392,11 +4391,11 @@ pedestalRoom	src/Dodge/Room/Containing.hs	50;"	f
 penThing	src/Dodge/Bullet.hs	210;"	f
 perMat	src/MatrixHelper.hs	49;"	f
 perceptionUpdate	src/Dodge/Creature/Perception.hs	24;"	f
-performAction	src/Dodge/Creature/Action.hs	88;"	f
-performActions	src/Dodge/Creature/Action.hs	36;"	f
-performAimAt	src/Dodge/Creature/Action.hs	44;"	f
-performPathTo	src/Dodge/Creature/Action.hs	57;"	f
-performTurnToA	src/Dodge/Creature/Action.hs	75;"	f
+performAction	src/Dodge/Creature/Action.hs	93;"	f
+performActions	src/Dodge/Creature/Action.hs	38;"	f
+performAimAt	src/Dodge/Creature/Action.hs	48;"	f
+performPathTo	src/Dodge/Creature/Action.hs	61;"	f
+performTurnToA	src/Dodge/Creature/Action.hs	80;"	f
 perspectiveMatrixb	src/MatrixHelper.hs	11;"	f
 pesNearCirc	src/Dodge/Zoning/Pathing.hs	43;"	f
 pesNearPoint	src/Dodge/Zoning/Pathing.hs	33;"	f
@@ -4470,7 +4469,7 @@ pointerToItemID	src/Dodge/Item/Location.hs	42;"	f
 pointerYourRootItem	src/Dodge/Item/Location.hs	33;"	f
 pointerYourSelectedItem	src/Dodge/Item/Location.hs	26;"	f
 pointsToPoly	src/Geometry/ConvexPoly.hs	37;"	f
-poisonSPic	src/Dodge/Creature/Update.hs	126;"	f
+poisonSPic	src/Dodge/Creature/Update.hs	125;"	f
 poisonSprayer	src/Dodge/Item/Held/SprayGuns.hs	17;"	f
 poke34	src/Shader/Poke.hs	506;"	f
 pokeArrayOff	src/Shader/Poke.hs	517;"	f
@@ -4834,7 +4833,7 @@ scaleSH	src/Shape.hs	269;"	f
 scalp	src/Dodge/Creature/Picture.hs	93;"	f
 scancodeToHotkey	src/Dodge/Creature/YourControl.hs	102;"	f
 scodeToChar	src/Dodge/ScodeToChar.hs	6;"	f
-scorchSPic	src/Dodge/Creature/Update.hs	123;"	f
+scorchSPic	src/Dodge/Creature/Update.hs	122;"	f
 screenBox	src/Dodge/Base/Window.hs	53;"	f
 screenPolygon	src/Dodge/Base/Window.hs	17;"	f
 screenPolygonBord	src/Dodge/Base/Window.hs	27;"	f
@@ -5233,7 +5232,7 @@ thingsHit	src/Dodge/WorldEvent/ThingsHit.hs	36;"	f
 thingsHitExceptCr	src/Dodge/WorldEvent/ThingsHit.hs	119;"	f
 thingsHitZ	src/Dodge/WorldEvent/ThingsHit.hs	44;"	f
 threeLineDecoration	src/Dodge/Placement/TopDecoration.hs	61;"	f
-throwItem	src/Dodge/Creature/Action.hs	204;"	f
+throwItem	src/Dodge/Creature/Action.hs	209;"	f
 tileTexCoords	src/Tile.hs	11;"	f
 tilesFromRooms	src/Dodge/Layout.hs	192;"	f
 tilesToLine	src/Shader/AuxAddition.hs	66;"	f
@@ -5406,8 +5405,8 @@ updateCloud	src/Dodge/Update.hs	798;"	f
 updateClouds	src/Dodge/Update.hs	669;"	f
 updateCombinePositioning	src/Dodge/DisplayInventory.hs	40;"	f
 updateCombineSections	src/Dodge/DisplayInventory.hs	47;"	f
-updateCreature	src/Dodge/Creature/Update.hs	33;"	f
-updateCreature'	src/Dodge/Creature/Update.hs	42;"	f
+updateCreature	src/Dodge/Creature/Update.hs	32;"	f
+updateCreature'	src/Dodge/Creature/Update.hs	41;"	f
 updateCreatureGroups	src/Dodge/Update.hs	537;"	f
 updateCreatureSoundPositions	src/Dodge/Update.hs	516;"	f
 updateDebris	src/Dodge/Update.hs	572;"	f
@@ -5464,7 +5463,7 @@ updatePastWorlds	src/Dodge/Update.hs	424;"	f
 updatePreload	src/Preload/Update.hs	20;"	f
 updateProjectile	src/Dodge/Projectile/Update.hs	25;"	f
 updateProp	src/Dodge/Prop/Update.hs	11;"	f
-updatePulse	src/Dodge/Creature/Update.hs	147;"	f
+updatePulse	src/Dodge/Creature/Update.hs	146;"	f
 updatePulseBall	src/Dodge/Update.hs	449;"	f
 updatePulseLaser	src/Dodge/Update.hs	612;"	f
 updatePulseLasers	src/Dodge/Update.hs	444;"	f
@@ -5659,7 +5658,7 @@ yIntercepts'	src/Dodge/Zoning/Base.hs	76;"	f
 yV2	src/Geometry/Vector.hs	205;"	f
 yellow	src/Color.hs	17;"	f
 you	src/Dodge/Base/You.hs	13;"	f
-youDropItem	src/Dodge/Creature/Action.hs	190;"	f
+youDropItem	src/Dodge/Creature/Action.hs	195;"	f
 yourAugmentedItem	src/Dodge/Render/HUD.hs	238;"	f
 yourControl	src/Dodge/Creature/YourControl.hs	28;"	f
 yourDefaultStrideLength	src/Dodge/Default/Creature.hs	110;"	f