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