Grant RobotIntoWater achievement (#1504)

Towards #1435.  Some refactoring, + grant `RobotIntoWater` achievement when a robot dies in the water.

data/scenarios/Testing/00-ORDER.txt

@@ -1,3 +1,4 @@
+Achievements
 373-drill.yaml
 394-build-drill.yaml
 428-drowning-destroy.yaml
@@ -44,4 +45,4 @@
 1355-combustion.yaml
 1379-single-world-portal-reorientation.yaml
 1399-backup-command.yaml
-1430-built-robot-ownership.yaml
+1430-built-robot-ownership.yaml

data/scenarios/Testing/Achievements/00-ORDER.txt

@@ -0,0 +1 @@
+RobotIntoWater.yaml

data/scenarios/Testing/Achievements/RobotIntoWater.yaml

@@ -0,0 +1,48 @@
+version: 1
+name: RobotIntoWater achievement test
+description: Drive a robot into the water
+objectives:
+  - id: build
+    goal:
+      - Build a robot
+    condition: |
+      try {robotNumbered 1; return True} {return False}
+  - goal:
+      - Drown it
+    prerequisite: build
+    condition: |
+      try {robotNumbered 1; return False} {return True}
+solution: |
+  build { turn right; move; move; move }
+robots:
+  - name: base
+    loc: [0,0]
+    dir: [0,1]
+    heavy: true
+    display:
+      char: Ω
+      attr: robot
+    devices:
+      - 3D printer
+      - dictionary
+      - grabber
+      - welder
+      - life support system
+      - logger
+      - toolkit
+      - solar panel
+      - workbench
+      - clock
+    inventory:
+      - [5, 3D printer]
+      - [100, treads]
+      - [70, grabber]
+      - [100, solar panel]
+      - [50, scanner]
+      - [50, clock]
+      - [5, toolkit]
+seed: 0
+world:
+  offset: true
+  dsl: |
+    "classic"

src/Swarm/Game/Step.hs

@@ -1024,7 +1024,7 @@ execConst c vs s k = do
         return $ Waiting (addTicks d time) (Out VUnit s k)
       _ -> badConst
     Selfdestruct -> do
-      destroyIfNotBase $ Just AttemptSelfDestructBase
+      destroyIfNotBase $ \case False -> Just AttemptSelfDestructBase; _ -> Nothing
       flagRedraw
       return $ Out VUnit s k
     Move -> do
@@ -1092,11 +1092,9 @@ execConst c vs s k = do
         failureMaybes <- mapM checkMoveFailure locsInDirection
         let maybeFirstFailure = asum failureMaybes
 
-        applyMoveFailureEffect maybeFirstFailure $
-          MoveFailure
-            { failIfBlocked = ThrowExn
-            , failIfDrown = Destroy
-            }
+        applyMoveFailureEffect maybeFirstFailure $ \case
+          PathBlocked -> ThrowExn
+          PathLiquid -> Destroy
 
         let maybeLastLoc = do
               guard $ null maybeFirstFailure
@@ -1115,11 +1113,9 @@ execConst c vs s k = do
             nextLoc = fmap (const $ Location (fromIntegral x) (fromIntegral y)) oldLoc
 
         onTarget rid $ do
-          checkMoveAhead nextLoc $
-            MoveFailure
-              { failIfBlocked = Destroy
-              , failIfDrown = Destroy
-              }
+          checkMoveAhead nextLoc $ \case
+            PathBlocked -> Destroy
+            PathLiquid -> Destroy
           updateRobotLocation oldLoc nextLoc
 
         return $ Out VUnit s k
@@ -2345,25 +2341,37 @@ execConst c vs s k = do
 
         return (minimalEquipSet, missingChildInv)
 
-  destroyIfNotBase :: HasRobotStepState sig m => Maybe GameplayAchievement -> m ()
+  -- Destroy the current robot, as long as it is not the base robot.
+  --
+  -- Depending on whether we destroy (True) or do not destroy
+  -- (False) the current robot, possibly grant an achievement.
+  --
+  -- Note we cannot simply return a Boolean and grant achievements
+  -- at call sites, because in the case that we do not destroy the
+  -- base we actually throw an exception, so we do not return to the
+  -- original call site.
+  destroyIfNotBase ::
+    (HasRobotStepState sig m, Has (Lift IO) sig m) =>
+    (Bool -> Maybe GameplayAchievement) ->
+    m ()
   destroyIfNotBase mAch = do
     rid <- use robotID
     holdsOrFailWithAchievement
       (rid /= 0)
       ["You consider destroying your base, but decide not to do it after all."]
-      mAch
+      (mAch False)
+
     selfDestruct .= True
+    maybe (return ()) grantAchievement (mAch True)
 
   moveInDirection :: (HasRobotStepState sig m, Has (Lift IO) sig m) => Heading -> m CESK
   moveInDirection orientation = do
     -- Figure out where we're going
     loc <- use robotLocation
     let nextLoc = loc `offsetBy` orientation
-    checkMoveAhead nextLoc $
-      MoveFailure
-        { failIfBlocked = ThrowExn
-        , failIfDrown = Destroy
-        }
+    checkMoveAhead nextLoc $ \case
+      PathBlocked -> ThrowExn
+      PathLiquid -> Destroy
     updateRobotLocation loc nextLoc
     return $ Out VUnit s k
 
@@ -2388,33 +2396,32 @@ execConst c vs s k = do
       | otherwise = Nothing
 
   applyMoveFailureEffect ::
-    HasRobotStepState sig m =>
+    (HasRobotStepState sig m, Has (Lift IO) sig m) =>
     Maybe MoveFailureDetails ->
-    MoveFailure ->
+    MoveFailureHandler ->
     m ()
-  applyMoveFailureEffect maybeFailure MoveFailure {..} =
+  applyMoveFailureEffect maybeFailure failureHandler =
     case maybeFailure of
       Nothing -> return ()
-      Just (MoveFailureDetails e failureMode) -> case failureMode of
-        PathBlocked ->
-          handleFailure
-            failIfBlocked
-            ["There is a", e ^. entityName, "in the way!"]
-        PathLiquid ->
-          handleFailure
-            failIfDrown
-            ["There is a dangerous liquid", e ^. entityName, "in the way!"]
-   where
-    handleFailure behavior message = case behavior of
-      Destroy -> destroyIfNotBase Nothing
-      ThrowExn -> throwError $ cmdExn c message
-      IgnoreFail -> return ()
+      Just (MoveFailureDetails e failureMode) -> case failureHandler failureMode of
+        IgnoreFail -> return ()
+        Destroy -> destroyIfNotBase $ \b -> case (b, failureMode) of
+          (True, PathLiquid) -> Just RobotIntoWater -- achievement for drowning
+          _ -> Nothing
+        ThrowExn -> throwError . cmdExn c $
+          case failureMode of
+            PathBlocked -> ["There is a", e ^. entityName, "in the way!"]
+            PathLiquid -> ["There is a dangerous liquid", e ^. entityName, "in the way!"]
 
   -- Determine the move failure mode and apply the corresponding effect.
-  checkMoveAhead :: HasRobotStepState sig m => Cosmic Location -> MoveFailure -> m ()
-  checkMoveAhead nextLoc failureHandlers = do
+  checkMoveAhead ::
+    (HasRobotStepState sig m, Has (Lift IO) sig m) =>
+    Cosmic Location ->
+    MoveFailureHandler ->
+    m ()
+  checkMoveAhead nextLoc failureHandler = do
     maybeFailure <- checkMoveFailure nextLoc
-    applyMoveFailureEffect maybeFailure failureHandlers
+    applyMoveFailureEffect maybeFailure failureHandler
 
   getRobotWithinTouch :: HasRobotStepState sig m => RID -> m Robot
   getRobotWithinTouch rid = do
@@ -2572,11 +2579,9 @@ data MoveFailureDetails = MoveFailureDetails Entity MoveFailureMode
 -- | How to handle failure, for example when moving to blocked location
 data RobotFailure = ThrowExn | Destroy | IgnoreFail
 
--- | How to handle failure when moving/teleporting to a location.
-data MoveFailure = MoveFailure
-  { failIfBlocked :: RobotFailure
-  , failIfDrown :: RobotFailure
-  }
+-- | How to handle different types of failure when moving/teleporting
+--   to a location.
+type MoveFailureHandler = MoveFailureMode -> RobotFailure
 
 data GrabbingCmd = Grab' | Harvest' | Swap' | Push' deriving (Eq, Show)
 
@@ -2657,9 +2662,9 @@ updateRobotLocation oldLoc newLoc
 -- | Execute a stateful action on a target robot --- whether the
 --   current one or another.
 onTarget ::
-  HasRobotStepState sig m =>
+  (HasRobotStepState sig m, Has (Lift IO) sig m) =>
   RID ->
-  (forall sig' m'. (HasRobotStepState sig' m') => m' ()) ->
+  (forall sig' m'. (HasRobotStepState sig' m', Has (Lift IO) sig' m') => m' ()) ->
   m ()
 onTarget rid act = do
   myID <- use robotID

test/integration/Main.hs

@@ -11,7 +11,7 @@ module Main where
 
 import Control.Carrier.Lift (runM)
 import Control.Carrier.Throw.Either (runThrow)
-import Control.Lens (Ixed (ix), at, to, use, view, (&), (.~), (<>~), (^.), (^..), (^?!))
+import Control.Lens (Ixed (ix), at, to, use, view, (&), (.~), (<>~), (^.), (^..), (^?), (^?!))
 import Control.Monad (forM_, unless, when)
 import Control.Monad.State (StateT (runStateT), gets)
 import Data.Char (isSpace)
@@ -28,6 +28,7 @@ import Data.Text.IO qualified as T
 import Data.Yaml (ParseException, prettyPrintParseException)
 import Swarm.Doc.Gen (EditorType (..))
 import Swarm.Doc.Gen qualified as DocGen
+import Swarm.Game.Achievement.Definitions (GameplayAchievement (..))
 import Swarm.Game.CESK (emptyStore, getTickNumber, initMachine)
 import Swarm.Game.Entity (EntityMap, lookupByName)
 import Swarm.Game.Failure (SystemFailure)
@@ -40,6 +41,7 @@ import Swarm.Game.State (
   WinStatus (Won),
   activeRobots,
   baseRobot,
+  gameAchievements,
   messageQueue,
   notificationsContent,
   robotMap,
@@ -244,6 +246,13 @@ testScenarioSolutions rs ui =
             [ testSolution Default "Mechanics/active-trapdoor.yaml"
             ]
         ]
+    , testGroup
+        "Achievements"
+        [ testSolution' Default "Testing/Achievements/RobotIntoWater" CheckForBadErrors $ \g ->
+            assertBool
+              "Did not get RobotIntoWater achievement!"
+              (isJust $ g ^? gameAchievements . at RobotIntoWater)
+        ]
     , testGroup
         "Regression tests"
         [ testSolution Default "Testing/394-build-drill"