From 9971e36b5529a91acc5e752f9bd78e95bd5e4be3 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sat, 9 Sep 2023 19:29:49 -0500 Subject: [PATCH 1/6] Towards #1435. Refactoring + grant `RobotIntoWater` achievement --- src/Swarm/Game/Step.hs | 95 ++++++++++++++++++++++-------------------- 1 file changed, 50 insertions(+), 45 deletions(-) diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index 1e9fb8394..d7d349356 100644 --- a/src/Swarm/Game/Step.hs +++ b/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 From 46c0efe1eb98a4d755c707d6ff711fc4b5e9abf7 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sun, 10 Sep 2023 00:20:34 -0500 Subject: [PATCH 2/6] add test scenario + solution for `RobotIntoWater` achievement --- .../Testing/Achievements/RobotIntoWater.yaml | 37 +++++++++++++++++++ 1 file changed, 37 insertions(+) create mode 100644 data/scenarios/Testing/Achievements/RobotIntoWater.yaml diff --git a/data/scenarios/Testing/Achievements/RobotIntoWater.yaml b/data/scenarios/Testing/Achievements/RobotIntoWater.yaml new file mode 100644 index 000000000..f1e32944c --- /dev/null +++ b/data/scenarios/Testing/Achievements/RobotIntoWater.yaml @@ -0,0 +1,37 @@ +version: 1 +name: RobotIntoWater achievement test +description: Drive a robot into the water +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" From 0ae3296c4cc32ed24699096e3d8f593e46822a7b Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sun, 10 Sep 2023 00:34:34 -0500 Subject: [PATCH 3/6] add 00-ORDER.txt --- data/scenarios/Testing/Achievements/00-ORDER.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 data/scenarios/Testing/Achievements/00-ORDER.txt diff --git a/data/scenarios/Testing/Achievements/00-ORDER.txt b/data/scenarios/Testing/Achievements/00-ORDER.txt new file mode 100644 index 000000000..4fdfd2dec --- /dev/null +++ b/data/scenarios/Testing/Achievements/00-ORDER.txt @@ -0,0 +1 @@ +RobotIntoWater.yaml From 4d8d533c70a26ab79507371327d784952c221bf1 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sun, 10 Sep 2023 01:03:20 -0500 Subject: [PATCH 4/6] add Achievements directory to Testing/00-ORDER.txt --- data/scenarios/Testing/00-ORDER.txt | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/data/scenarios/Testing/00-ORDER.txt b/data/scenarios/Testing/00-ORDER.txt index 177e10b45..5f692881b 100644 --- a/data/scenarios/Testing/00-ORDER.txt +++ b/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 \ No newline at end of file +1430-built-robot-ownership.yaml From 17da990bdf29668cda9496e5ef0212baca9f6025 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sun, 10 Sep 2023 07:06:05 -0500 Subject: [PATCH 5/6] add integration test for `RobotIntoWater` achievement --- .../Testing/Achievements/RobotIntoWater.yaml | 11 +++++++++++ test/integration/Main.hs | 10 +++++++++- 2 files changed, 20 insertions(+), 1 deletion(-) diff --git a/data/scenarios/Testing/Achievements/RobotIntoWater.yaml b/data/scenarios/Testing/Achievements/RobotIntoWater.yaml index f1e32944c..cd6150d6b 100644 --- a/data/scenarios/Testing/Achievements/RobotIntoWater.yaml +++ b/data/scenarios/Testing/Achievements/RobotIntoWater.yaml @@ -1,6 +1,17 @@ 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: diff --git a/test/integration/Main.hs b/test/integration/Main.hs index fe939dc0c..e9ea453cc 100644 --- a/test/integration/Main.hs +++ b/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) @@ -47,6 +48,7 @@ import Swarm.Game.State ( waitingRobots, winCondition, winSolution, + gameAchievements, ) import Swarm.Game.Step (gameTick) import Swarm.Game.World.Typecheck (WorldMap) @@ -244,6 +246,12 @@ 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" From 010ee742069793da6ce209f2da77f33c2a99ccc2 Mon Sep 17 00:00:00 2001 From: "restyled-io[bot]" <32688539+restyled-io[bot]@users.noreply.github.com> Date: Sun, 10 Sep 2023 07:08:59 -0500 Subject: [PATCH 6/6] Restyled by fourmolu (#1511) Co-authored-by: Restyled.io --- test/integration/Main.hs | 17 +++++++++-------- 1 file changed, 9 insertions(+), 8 deletions(-) diff --git a/test/integration/Main.hs b/test/integration/Main.hs index e9ea453cc..9a8ededd5 100644 --- a/test/integration/Main.hs +++ b/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,7 +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.Achievement.Definitions (GameplayAchievement (..)) import Swarm.Game.CESK (emptyStore, getTickNumber, initMachine) import Swarm.Game.Entity (EntityMap, lookupByName) import Swarm.Game.Failure (SystemFailure) @@ -41,6 +41,7 @@ import Swarm.Game.State ( WinStatus (Won), activeRobots, baseRobot, + gameAchievements, messageQueue, notificationsContent, robotMap, @@ -48,7 +49,6 @@ import Swarm.Game.State ( waitingRobots, winCondition, winSolution, - gameAchievements, ) import Swarm.Game.Step (gameTick) import Swarm.Game.World.Typecheck (WorldMap) @@ -247,11 +247,12 @@ testScenarioSolutions rs ui = ] ] , testGroup - "Achievements" - [ testSolution' Default "Testing/Achievements/RobotIntoWater" CheckForBadErrors $ \g -> - assertBool "Did not get RobotIntoWater achievement!" - (isJust $ g ^? gameAchievements . at RobotIntoWater) - ] + "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"