check achievement robot requirements (#1751)

Closes #1726

There are now two entry points to obtain a `GameplayAchievement`:
* `grantAchievementForRobot`
* `grantAchievement`

The latter enforces that the achievement is applicable to the current game mode (i.e. creative), while the former makes an additional check for validity of system robots.

This is an improvement over the status quo, but note that it is still currently possible to make a coding error in which an achievement specifies a requirement of **not** being a system robot, but the site at which the achievement is granted only calls `grantAchievement`, bypassing the robot validity check.

src/swarm-engine/Swarm/Game/Achievement/Description.hs

@@ -103,3 +103,16 @@ describe = \case
       "`give` something to your`self`."
       Easy
       True
+
+-- | Validity conditions are required if-and-only-if the achievement
+-- category is 'GameplayAchievement'.
+getValidityRequirements :: GameplayAchievement -> ValidityConditions
+getValidityRequirements = \case
+  CraftedBitcoin -> ValidityConditions OnlyPlayerRobot ExcludesCreativeMode
+  RobotIntoWater -> ValidityConditions OnlyPlayerRobot ValidInCreativeMode
+  AttemptSelfDestructBase -> ValidityConditions OnlyPlayerRobot ExcludesCreativeMode
+  DestroyedBase -> ValidityConditions OnlyPlayerRobot ValidInCreativeMode
+  LoseScenario -> ValidityConditions OnlyPlayerRobot ExcludesCreativeMode
+  GetDisoriented -> ValidityConditions OnlyPlayerRobot ExcludesCreativeMode
+  SwapSame -> ValidityConditions OnlyPlayerRobot ExcludesCreativeMode
+  GaveToSelf -> ValidityConditions OnlyPlayerRobot ExcludesCreativeMode

src/swarm-engine/Swarm/Game/Step/Const.hs

@@ -323,7 +323,7 @@ execConst runChildProg c vs s k = do
         robotInventory %= delete e
 
         when (e == newE) $
-          grantAchievement SwapSame
+          grantAchievementForRobot SwapSame
 
         return $ mkReturn newE
       _ -> badConst
@@ -335,7 +335,7 @@ execConst runChildProg c vs s k = do
 
         inst <- use equippedDevices
         when (d == DRelative DDown && countByName "compass" inst == 0) $ do
-          grantAchievement GetDisoriented
+          grantAchievementForRobot GetDisoriented
 
         return $ mkReturn ()
       _ -> badConst
@@ -395,7 +395,7 @@ execConst runChildProg c vs s k = do
 
             -- Flag the UI for a redraw if we are currently showing either robot's inventory
             when (focusedID == myID || focusedID == otherID) flagRedraw
-          else grantAchievement GaveToSelf
+          else grantAchievementForRobot GaveToSelf
 
         return $ mkReturn ()
       _ -> badConst
@@ -430,7 +430,6 @@ execConst runChildProg c vs s k = do
       [VText name] -> do
         inv <- use robotInventory
         ins <- use equippedDevices
-        sys <- use systemRobot
         em <- use $ landscape . entityMap
         e <-
           lookupEntityName name em
@@ -473,7 +472,8 @@ execConst runChildProg c vs s k = do
         robotInventory .= invTaken
         traverse_ (updateDiscoveredEntities . snd) (recipe ^. recipeOutputs)
         -- Grant CraftedBitcoin achievement
-        when (name == "bitcoin" && not creative && not sys) $ grantAchievement CraftedBitcoin
+        when (name == "bitcoin") $
+          grantAchievementForRobot CraftedBitcoin
 
         finishCookingRecipe recipe VUnit [] (map (uncurry AddEntity) changeInv)
       _ -> badConst
@@ -1605,7 +1605,7 @@ execConst runChildProg c vs s k = do
       (mAch False)
 
     selfDestruct .= True
-    maybe (return ()) grantAchievement (mAch True)
+    maybe (return ()) grantAchievementForRobot (mAch True)
 
   moveInDirection :: (HasRobotStepState sig m, Has (Lift IO) sig m) => Heading -> m CESK
   moveInDirection orientation = do

src/swarm-engine/Swarm/Game/Step/Util/Command.hs

@@ -19,7 +19,7 @@ import Control.Effect.Error
 import Control.Effect.Lens
 import Control.Effect.Lift
 import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=))
-import Control.Monad (forM_, unless)
+import Control.Monad (forM_, unless, when)
 import Data.Map qualified as M
 import Data.Sequence qualified as Seq
 import Data.Set (Set)
@@ -30,6 +30,7 @@ import Data.Time (getZonedTime)
 import Linear (zero)
 import Swarm.Game.Achievement.Attainment
 import Swarm.Game.Achievement.Definitions
+import Swarm.Game.Achievement.Description (getValidityRequirements)
 import Swarm.Game.CESK
 import Swarm.Game.Display
 import Swarm.Game.Entity hiding (empty, lookup, singleton, union)
@@ -151,18 +152,42 @@ onTarget rid act = do
               then deleteRobot rid
               else robotMap . ix rid .= tgt'
 
+grantAchievementForRobot ::
+  (HasRobotStepState sig m, Has (Lift IO) sig m) =>
+  GameplayAchievement ->
+  m ()
+grantAchievementForRobot a = do
+  sys <- use systemRobot
+  let isValidRobotType = not sys || robotTypeRequired == ValidForSystemRobot
+  when isValidRobotType $
+    grantAchievement a
+ where
+  ValidityConditions robotTypeRequired _ = getValidityRequirements a
+
+checkGameModeAchievementValidity ::
+  Has (State GameState) sig m =>
+  GameplayAchievement ->
+  m Bool
+checkGameModeAchievementValidity a = do
+  creative <- use creativeMode
+  return $ not creative || gameplayModeRequired == ValidInCreativeMode
+ where
+  ValidityConditions _ gameplayModeRequired = getValidityRequirements a
+
 grantAchievement ::
   (Has (State GameState) sig m, Has (Lift IO) sig m) =>
   GameplayAchievement ->
   m ()
 grantAchievement a = do
-  currentTime <- sendIO getZonedTime
-  scenarioPath <- use currentScenarioPath
-  discovery . gameAchievements
-    %= M.insertWith
-      (<>)
-      a
-      (Attainment (GameplayAchievement a) scenarioPath currentTime)
+  isGameModeValid <- checkGameModeAchievementValidity a
+  when isGameModeValid $ do
+    currentTime <- sendIO getZonedTime
+    scenarioPath <- use currentScenarioPath
+    discovery . gameAchievements
+      %= M.insertWith
+        (<>)
+        a
+        (Attainment (GameplayAchievement a) scenarioPath currentTime)
 
 -- | Capabilities needed for a specific robot to evaluate or execute a
 --   constant.  Right now, the only difference is whether the robot is

src/swarm-scenario/Swarm/Game/Achievement/Definitions.hs

@@ -15,6 +15,9 @@ module Swarm.Game.Achievement.Definitions (
   Quotation (..),
   FlavorText (..),
   AchievementInfo (..),
+  ValidityConditions (..),
+  SystemTypeValidity (..),
+  GameplayModeValidity (..),
 ) where
 
 import Data.Aeson
@@ -46,6 +49,19 @@ data FlavorText
   | FTQuotation Quotation
   deriving (Eq, Show, Generic, FromJSON, ToJSON)
 
+data SystemTypeValidity
+  = ValidForSystemRobot
+  | OnlyPlayerRobot
+  deriving (Eq, Show, Generic, FromJSON, ToJSON)
+
+data GameplayModeValidity
+  = ValidInCreativeMode
+  | ExcludesCreativeMode
+  deriving (Eq, Show, Generic, FromJSON, ToJSON)
+
+data ValidityConditions = ValidityConditions SystemTypeValidity GameplayModeValidity
+  deriving (Eq, Show, Generic, FromJSON, ToJSON)
+
 -- | Information about an achievement.  See
 --   "Swarm.Game.Achievement.Description" for a mapping from
 --   achievements to an corresponding 'AchievementInfo' record.