diff --git a/app/doc/Swarm/Doc/Wiki/Cheatsheet.hs b/app/doc/Swarm/Doc/Wiki/Cheatsheet.hs index fc365caf46..2b5b27e86a 100644 --- a/app/doc/Swarm/Doc/Wiki/Cheatsheet.hs +++ b/app/doc/Swarm/Doc/Wiki/Cheatsheet.hs @@ -174,7 +174,7 @@ capabilityRow PageAddress {..} em cap = $ constSyntax c cs = [c | c <- Syntax.allConst, let mcap = Capability.constCaps c, isJust $ find (== cap) mcap] - es = maybe [] (map D.device) $ E.entitiesByCap em Map.!? cap + es = E.devicesForCap cap em capabilityTable :: PageAddress -> EntityMap -> [Capability] -> Text capabilityTable a em cs = T.unlines $ header <> map (listToRow mw) capabilityRows diff --git a/data/scenarios/Testing/1777-capability-cost.yaml b/data/scenarios/Testing/1777-capability-cost.yaml index 174ec58fe1..5f723b4a99 100644 --- a/data/scenarios/Testing/1777-capability-cost.yaml +++ b/data/scenarios/Testing/1777-capability-cost.yaml @@ -20,9 +20,10 @@ robots: dir: east devices: - treads + - logger - Zippo inventory: - - [1, lighter fluid] + - [0, lighter fluid] - name: judge dir: east system: true @@ -43,7 +44,7 @@ entities: - capability: ignite cost: - [1, "lighter fluid"] -known: [ash] +known: [paper, ash] world: dsl: | {grass} diff --git a/src/Swarm/TUI/Controller.hs b/src/Swarm/TUI/Controller.hs index 506a6992e8..47a9d1ba5e 100644 --- a/src/Swarm/TUI/Controller.hs +++ b/src/Swarm/TUI/Controller.hs @@ -89,7 +89,7 @@ import Swarm.Game.State.Robot import Swarm.Game.State.Runtime import Swarm.Game.State.Substate import Swarm.Game.Step (finishGameTick, gameTick) -import Swarm.Language.Capability (Capability (CDebug, CGod, CMake), constCaps) +import Swarm.Language.Capability (Capability (CGod, CMake), constCaps) import Swarm.Language.Context import Swarm.Language.Key (KeyCombo, mkKeyCombo) import Swarm.Language.Module @@ -307,7 +307,7 @@ handleMainEvent ev = do let isRunning = maybe True isRunningModal mt let isPaused = s ^. gameState . temporal . paused let isCreative = s ^. gameState . creativeMode - let hasDebug = fromMaybe isCreative $ s ^? gameState . to focusedRobot . _Just . robotCapabilities . Lens.contains CDebug + let hasDebug = hasDebugCapability isCreative s case ev of AppEvent ae -> case ae of Frame diff --git a/src/Swarm/TUI/Controller/Util.hs b/src/Swarm/TUI/Controller/Util.hs index 88950aac0e..5683f4d9a3 100644 --- a/src/Swarm/TUI/Controller/Util.hs +++ b/src/Swarm/TUI/Controller/Util.hs @@ -10,13 +10,17 @@ import Control.Lens import Control.Monad (forM_, unless) import Control.Monad.IO.Class (liftIO) import Data.Map qualified as M +import Data.Set qualified as S import Graphics.Vty qualified as V +import Swarm.Game.Device +import Swarm.Game.Robot (robotCapabilities) import Swarm.Game.State import Swarm.Game.State.Landscape import Swarm.Game.State.Robot import Swarm.Game.State.Substate import Swarm.Game.Universe import Swarm.Game.World qualified as W +import Swarm.Language.Capability (Capability (CDebug)) import Swarm.TUI.Model import Swarm.TUI.Model.UI import Swarm.TUI.View.Util (generateModal) @@ -97,3 +101,8 @@ mouseLocToWorldCoords (Brick.Location mouseLoc) = do mx = snd mouseLoc' + fst regionStart my = fst mouseLoc' + snd regionStart in pure . Just $ Cosmic (region ^. subworld) $ W.Coords (mx, my) + +hasDebugCapability :: Bool -> AppState -> Bool +hasDebugCapability isCreative s = + maybe isCreative (S.member CDebug . getCapabilitySet) $ + s ^? gameState . to focusedRobot . _Just . robotCapabilities diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs index 6522e44cbf..8975303c12 100644 --- a/src/Swarm/TUI/View.hs +++ b/src/Swarm/TUI/View.hs @@ -122,6 +122,7 @@ import Swarm.Language.Typecheck (inferConst) import Swarm.Log import Swarm.TUI.Border import Swarm.TUI.Controller (ticksPerFrameCap) +import Swarm.TUI.Controller.Util (hasDebugCapability) import Swarm.TUI.Editor.Model import Swarm.TUI.Editor.View qualified as EV import Swarm.TUI.Inventory.Sorting (renderSortMethod) @@ -995,7 +996,7 @@ drawKeyMenu s = isReplWorking = s ^. gameState . gameControls . replWorking isPaused = s ^. gameState . temporal . paused - hasDebug = fromMaybe creative $ s ^? gameState . to focusedRobot . _Just . robotCapabilities . Lens.contains CDebug + hasDebug = hasDebugCapability creative s viewingBase = (s ^. gameState . robotInfo . viewCenterRule) == VCRobot 0 creative = s ^. gameState . creativeMode cheat = s ^. uiState . uiCheatMode diff --git a/src/swarm-engine/Swarm/Game/Exception.hs b/src/swarm-engine/Swarm/Game/Exception.hs index f1b9571172..7910f91a5c 100644 --- a/src/swarm-engine/Swarm/Game/Exception.hs +++ b/src/swarm-engine/Swarm/Game/Exception.hs @@ -9,6 +9,7 @@ module Swarm.Game.Exception ( Exn (..), IncapableFix (..), formatExn, + IncapableFixWords (..), -- * Helper functions formatIncapable, @@ -25,7 +26,7 @@ import Data.Text qualified as T import GHC.Generics (Generic) import Swarm.Constant import Swarm.Game.Achievement.Definitions -import Swarm.Game.Entity (EntityMap, deviceForCap, entityName) +import Swarm.Game.Entity (EntityMap, devicesForCap, entityName) import Swarm.Language.Capability (Capability (CGod), capabilityName) import Swarm.Language.Pretty (prettyText) import Swarm.Language.Requirement (Requirements (..)) @@ -54,7 +55,9 @@ data IncapableFix = -- | 'Swarm.Language.Syntax.Equip' the missing device on yourself/target FixByEquip | -- | Add the missing device to your inventory - FixByObtain + FixByObtainDevice + | -- | Add the missing consumables to your inventory + FixByObtainConsumables deriving (Eq, Show, Generic, FromJSON, ToJSON) -- | The type of exceptions that can be thrown by robot programs. @@ -99,11 +102,17 @@ formatExn em = \case -- INCAPABLE HELPERS -- ------------------------------------------------------------------ +data IncapableFixWords = IncapableFixWords + { fixVerb :: Text + , fixNoun :: Text + } + -- | Pretty-print an 'IncapableFix': either "equip" or "obtain". -formatIncapableFix :: IncapableFix -> Text +formatIncapableFix :: IncapableFix -> IncapableFixWords formatIncapableFix = \case - FixByEquip -> "equip" - FixByObtain -> "obtain" + FixByEquip -> IncapableFixWords "equip" "device" + FixByObtainDevice -> IncapableFixWords "obtain" "device" + FixByObtainConsumables -> IncapableFixWords "obtain" "consumables" -- | Pretty print the incapable exception with an actionable suggestion -- on how to fix it. @@ -156,12 +165,13 @@ formatIncapable em f (Requirements caps _ inv) tm , swarmRepoUrl <> "issues/26" ] | not (S.null caps) = - unlinesExText - ( "You do not have the devices required for:" - :| squote (prettyText tm) - : "Please " <> formatIncapableFix f <> ":" - : (("- " <>) . formatDevices <$> filter (not . null) deviceSets) - ) + let IncapableFixWords fVerb fNoun = formatIncapableFix f + in unlinesExText + ( T.unwords ["You do not have the", fNoun, "required for:"] + :| squote (prettyText tm) + : "Please " <> fVerb <> ":" + : (("- " <>) . formatDevices <$> filter (not . null) deviceSets) + ) | otherwise = unlinesExText ( "You are missing required inventory for:" @@ -171,7 +181,7 @@ formatIncapable em f (Requirements caps _ inv) tm ) where capList = S.toList caps - deviceSets = map (`deviceForCap` em) capList + deviceSets = map (`devicesForCap` em) capList devicePerCap = zip capList deviceSets -- capabilities not provided by any device capsNone = map (capabilityName . fst) $ filter (null . snd) devicePerCap diff --git a/src/swarm-engine/Swarm/Game/Robot/Concrete.hs b/src/swarm-engine/Swarm/Game/Robot/Concrete.hs index 3604deed67..f176fd75cd 100644 --- a/src/swarm-engine/Swarm/Game/Robot/Concrete.hs +++ b/src/swarm-engine/Swarm/Game/Robot/Concrete.hs @@ -98,6 +98,7 @@ instance ToSample Robot where sampleBase = instantiateRobot (Just $ C.initMachine [tmQ| move |] mempty C.emptyStore) 0 $ mkRobot + mempty Nothing "base" "The starting robot." diff --git a/src/swarm-engine/Swarm/Game/State.hs b/src/swarm-engine/Swarm/Game/State.hs index 49605fedea..5932ece535 100644 --- a/src/swarm-engine/Swarm/Game/State.hs +++ b/src/swarm-engine/Swarm/Game/State.hs @@ -99,7 +99,7 @@ import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding qualified as TL import Linear (V2 (..)) import Swarm.Game.CESK (emptyStore, finalValue, initMachine) -import Swarm.Game.Device (getMap) +import Swarm.Game.Device (getCapabilitySet, getMap) import Swarm.Game.Entity import Swarm.Game.Failure (SystemFailure (..)) import Swarm.Game.Location @@ -639,9 +639,9 @@ pureScenarioToGameState scenario theSeed now toRun gsc = -- devices in inventory or equipped; and commands that require no -- capability. allCapabilities r = - inventoryCapabilities (r ^. equippedDevices) - <> inventoryCapabilities (r ^. robotInventory) - initialCaps = mconcat $ map allCapabilities robotList + inventoryCapabilities em (r ^. equippedDevices) + <> inventoryCapabilities em (r ^. robotInventory) + initialCaps = getCapabilitySet $ mconcat $ map allCapabilities robotList initialCommands = filter (maybe True (`S.member` initialCaps) . constCaps) diff --git a/src/swarm-engine/Swarm/Game/Step.hs b/src/swarm-engine/Swarm/Game/Step.hs index 8c011cbee0..8512dd9316 100644 --- a/src/swarm-engine/Swarm/Game/Step.hs +++ b/src/swarm-engine/Swarm/Game/Step.hs @@ -157,7 +157,13 @@ insertBackRobot rn rob = do unless (isActive rob) (sleepForever rn) -- Run a set of robots - this is used to run robots before/after the focused one. -runRobotIDs :: (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => IS.IntSet -> m () +runRobotIDs :: + ( Has (State GameState) sig m + , Has (Lift IO) sig m + , Has Effect.Time sig m + ) => + IS.IntSet -> + m () runRobotIDs robotNames = forM_ (IS.toList robotNames) $ \rn -> do mr <- uses (robotInfo . robotMap) (IM.lookup rn) forM_ mr (stepOneRobot rn) @@ -165,9 +171,22 @@ runRobotIDs robotNames = forM_ (IS.toList robotNames) $ \rn -> do stepOneRobot rn rob = tickRobot rob >>= insertBackRobot rn -- This is a helper function to do one robot step or run robots before/after. -singleStep :: (Has (State GameState) sig m, Has (Lift IO) sig m, Has Effect.Time sig m) => SingleStep -> RID -> IS.IntSet -> m Bool +singleStep :: + ( Has (State GameState) sig m + , Has (Lift IO) sig m + , Has Effect.Time sig m + ) => + SingleStep -> + RID -> + IS.IntSet -> + m Bool singleStep ss focRID robotSet = do let (preFoc, focusedActive, postFoc) = IS.splitMember focRID robotSet + em <- use $ landscape . entityMap + let h = hypotheticalRobot em (Out VUnit emptyStore []) 0 + debugLog txt = do + m <- evalState @Robot h $ createLogEntry RobotError Debug txt + emitMessage m case ss of ---------------------------------------------------------------------------- -- run robots from the beginning until focused robot @@ -225,11 +244,6 @@ singleStep ss focRID robotSet = do -- go to single step if new robot is focused let (_pre, postRID) = IS.split rid robotSet singleStep SBefore focRID postRID - where - h = hypotheticalRobot (Out VUnit emptyStore []) 0 - debugLog txt = do - m <- evalState @Robot h $ createLogEntry RobotError Debug txt - emitMessage m -- | An accumulator for folding over the incomplete -- objectives to evaluate for their completion @@ -345,7 +359,7 @@ hypotheticalWinCheck em g ws oc = do m <- evalState @Robot h $ createLogEntry RobotError Critical exnText emitMessage m where - h = hypotheticalRobot (Out VUnit emptyStore []) 0 + h = hypotheticalRobot em (Out VUnit emptyStore []) 0 evalPT :: ( Has Effect.Time sig m @@ -360,10 +374,11 @@ evalPT t = evaluateCESK (initMachine t empty emptyStore) -- | Create a special robot to check some hypothetical, for example the win condition. -- -- Use ID (-1) so it won't conflict with any robots currently in the robot map. -hypotheticalRobot :: CESK -> TimeSpec -> Robot -hypotheticalRobot m = +hypotheticalRobot :: EntityMap -> CESK -> TimeSpec -> Robot +hypotheticalRobot em m = instantiateRobot (Just m) (-1) . mkRobot + em Nothing "hypothesis" mempty @@ -387,7 +402,8 @@ evaluateCESK :: m Value evaluateCESK cesk = do createdAt <- getNow - let r = hypotheticalRobot cesk createdAt + em <- use $ landscape . entityMap + let r = hypotheticalRobot em cesk createdAt zoomRobots $ addRobot r -- Add the special robot to the robot map, so it can look itself up if needed evalState r . runCESK $ cesk @@ -625,7 +641,7 @@ stepCESK cesk = case cesk of devicesForCaps, requiredDevices :: Set (Set Text) -- possible devices to provide each required capability - devicesForCaps = S.map (S.fromList . map (^. entityName) . (`deviceForCap` em)) caps + devicesForCaps = S.map (S.fromList . map (^. entityName) . (`devicesForCap` em)) caps -- outright required devices requiredDevices = S.map S.singleton devs diff --git a/src/swarm-engine/Swarm/Game/Step/Combustion.hs b/src/swarm-engine/Swarm/Game/Step/Combustion.hs index 17513fdac7..58f36839cd 100644 --- a/src/swarm-engine/Swarm/Game/Step/Combustion.hs +++ b/src/swarm-engine/Swarm/Game/Step/Combustion.hs @@ -21,6 +21,7 @@ import Control.Carrier.State.Lazy import Control.Effect.Lens import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=)) import Control.Monad (forM_, when) +import Data.Maybe (fromMaybe) import Data.Text qualified as T import Linear (zero) import Swarm.Effect as Effect (Time, getNow) @@ -88,16 +89,17 @@ addCombustionBot :: Cosmic Location -> m Integer addCombustionBot inputEntity combustibility ts loc = do - botInventory <- case maybeCombustionProduct of - Nothing -> return [] - Just n -> do - maybeE <- uses (landscape . entityMap) (lookupEntityName n) - return $ maybe [] (pure . (1,)) maybeE + em <- use $ landscape . entityMap + let botInventory = fromMaybe [] $ do + n <- maybeCombustionProduct + e <- lookupEntityName n em + return $ pure (1, e) combustionDurationRand <- uniform durationRange let combustionProg = combustionProgram combustionDurationRand combustibility zoomRobots . addTRobot (initMachine combustionProg empty emptyStore) $ mkRobot + em Nothing "fire" (Markdown.fromText $ T.unwords ["A burning", (inputEntity ^. entityName) <> "."]) @@ -180,9 +182,10 @@ igniteNeighbor :: m () igniteNeighbor creationTime sourceDuration loc = do maybeEnt <- entityAt loc - forM_ maybeEnt igniteEntity + em <- use $ landscape . entityMap + forM_ maybeEnt $ igniteEntity em where - igniteEntity e = + igniteEntity em e = when (e `hasProperty` Combustible) $ do threshold <- uniform (0, 1) when (probabilityOfIgnition >= threshold) $ do @@ -192,7 +195,7 @@ igniteNeighbor creationTime sourceDuration loc = do . min (fromIntegral sourceDuration) . negate $ log ignitionDelayRand / rate - zoomRobots $ addIgnitionBot ignitionDelay e creationTime loc + zoomRobots $ addIgnitionBot em ignitionDelay e creationTime loc where neighborCombustibility = (e ^. entityCombustion) ? defaultCombustibility rate = E.ignition neighborCombustibility @@ -203,14 +206,16 @@ igniteNeighbor creationTime sourceDuration loc = do -- that has been a priori determined that it shall be ignited. addIgnitionBot :: Has (State Robots) sig m => + EntityMap -> Integer -> Entity -> TimeSpec -> Cosmic Location -> m () -addIgnitionBot ignitionDelay inputEntity ts loc = +addIgnitionBot em ignitionDelay inputEntity ts loc = addTRobot (initMachine (ignitionProgram ignitionDelay) empty emptyStore) $ mkRobot + em Nothing "firestarter" (Markdown.fromText $ T.unwords ["Delayed ignition of", (inputEntity ^. entityName) <> "."]) diff --git a/src/swarm-engine/Swarm/Game/Step/Const.hs b/src/swarm-engine/Swarm/Game/Step/Const.hs index 119671ddc4..a990c5c874 100644 --- a/src/swarm-engine/Swarm/Game/Step/Const.hs +++ b/src/swarm-engine/Swarm/Game/Step/Const.hs @@ -1030,7 +1030,7 @@ execConst runChildProg c vs s k = do (childRobot ^. equippedDevices) cmd "The target robot" - FixByObtain + FixByObtainDevice -- update other robot's CESK machine, environment and context -- the childRobot inherits the parent robot's environment @@ -1077,7 +1077,7 @@ execConst runChildProg c vs s k = do pid <- use robotID (toEquip, toGive) <- - checkRequirements (r ^. robotInventory) E.empty E.empty cmd "You" FixByObtain + checkRequirements (r ^. robotInventory) E.empty E.empty cmd "You" FixByObtainDevice -- Pick a random display name. displayName <- randomName @@ -1086,9 +1086,11 @@ execConst runChildProg c vs s k = do -- Construct the new robot and add it to the world. parentCtx <- use robotContext + em <- use $ landscape . entityMap newRobot <- zoomRobots . addTRobotWithContext parentCtx (In cmd e s [FExec]) $ mkRobot + em (Just pid) displayName (Markdown.fromText $ "A robot built by the robot named " <> (r ^. robotName) <> ".") @@ -1497,7 +1499,7 @@ execConst runChildProg c vs s k = do -- help with later error message generation. possibleDevices :: [(Maybe Capability, [Entity])] possibleDevices = - map (Just &&& (`deviceForCap` em)) caps -- Possible devices for capabilities + map (Just &&& (`devicesForCap` em)) caps -- Possible devices for capabilities ++ map ((Nothing,) . (: [])) devs -- Outright required devices -- A device is OK if it is available in the inventory of the @@ -1548,10 +1550,11 @@ execConst runChildProg c vs s k = do -- Now, ensure there is at least one device available to be -- equipped for each requirement. let missingDevices = map snd . filter (null . fst) $ partitionedDevices + let IncapableFixWords fVerb fNoun = formatIncapableFix fixI null missingDevices `holdsOrFail` ( singularSubjectVerb subject "do" - : "not have required devices, please" - : formatIncapableFix fixI <> ":" + : "not have required " <> fNoun <> ", please" + : fVerb <> ":" : (("\n - " <>) . formatDevices <$> missingDevices) ) diff --git a/src/swarm-engine/Swarm/Game/Step/Util.hs b/src/swarm-engine/Swarm/Game/Step/Util.hs index eef6ec3346..6e93327ef4 100644 --- a/src/swarm-engine/Swarm/Game/Step/Util.hs +++ b/src/swarm-engine/Swarm/Game/Step/Util.hs @@ -22,6 +22,7 @@ import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T import Linear (zero) +import Swarm.Game.Device import Swarm.Game.Entity hiding (empty, lookup, singleton, union) import Swarm.Game.Exception import Swarm.Game.Location @@ -91,7 +92,7 @@ hasCapability :: (Has (State Robot) sig m, Has (State GameState) sig m) => Capab hasCapability cap = do isPrivileged <- isPrivilegedBot caps <- use robotCapabilities - return (isPrivileged || cap `S.member` caps) + return (isPrivileged || cap `S.member` getCapabilitySet caps) -- | Ensure that either a robot has a given capability, OR we are in creative -- mode. diff --git a/src/swarm-engine/Swarm/Game/Step/Util/Command.hs b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs index 2995de7d52..31e6a3ccf1 100644 --- a/src/swarm-engine/Swarm/Game/Step/Util/Command.hs +++ b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs @@ -20,6 +20,8 @@ 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, when) +import Data.List (find) +import Data.List.NonEmpty qualified as NE import Data.Map qualified as M import Data.Sequence qualified as Seq import Data.Set (Set) @@ -27,12 +29,13 @@ import Data.Set qualified as S import Data.Text (Text) import Data.Text qualified as T import Data.Time (getZonedTime) +import Data.Tuple (swap) 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.Device (getMap) +import Swarm.Game.Device import Swarm.Game.Display import Swarm.Game.Entity hiding (empty, lookup, singleton, union) import Swarm.Game.Entity qualified as E @@ -58,7 +61,6 @@ import Swarm.Language.Requirement qualified as R import Swarm.Language.Syntax import Swarm.Language.Text.Markdown qualified as Markdown import Swarm.Log -import Swarm.Util hiding (both) import System.Clock (TimeSpec) import Prelude hiding (Applicative (..), lookup) @@ -86,8 +88,6 @@ data GrabbingCmd -- Since this function has the side-effect of removing items from the -- robot's inventory, we must be careful that it is executed exactly -- once per command. --- --- TODO: Finish this ensureCanExecute :: ( Has (State Robot) sig m , Has (State GameState) sig m @@ -100,10 +100,30 @@ ensureCanExecute c = Nothing -> pure () Just cap -> do isPrivileged <- isPrivilegedBot - robotCaps <- use robotCapabilities - let hasCaps = cap `S.member` robotCaps - (isPrivileged || hasCaps) - `holdsOr` Incapable FixByEquip (R.singletonCap cap) (TConst c) + -- Privileged robots can execute commands regardless + -- of equipped devices, and without expending + -- a capability's exercise cost. + unless isPrivileged $ do + robotCaps <- use robotCapabilities + let capProviders = M.lookup cap $ getMap robotCaps + case capProviders of + Nothing -> throwError $ Incapable FixByEquip (R.singletonCap cap) (TConst c) + Just costs -> do + inv <- use robotInventory + let getMissingIngredients = findLacking inv . ingredients . useCost + maybeFeasibleRecipe = find (null . getMissingIngredients) $ NE.sort costs + case maybeFeasibleRecipe of + Nothing -> + throwError $ + Incapable FixByObtainConsumables (expenseToRequirement $ NE.head costs) (TConst c) + -- TODO: Consume the inventory + Just _feasibleRecipe -> return () + +expenseToRequirement :: DeviceUseCost Entity -> R.Requirements +expenseToRequirement (DeviceUseCost (ExerciseCost ingdts) d) = + R.Requirements S.empty (S.singleton $ d ^. entityName) ingdtsMap + where + ingdtsMap = M.fromListWith (+) $ map (swap . fmap (view entityName)) ingdts -- | Clear watches that are out of range purgeFarAwayWatches :: @@ -426,10 +446,12 @@ addSeedBot :: Cosmic Location -> TimeSpec -> m () -addSeedBot e (minT, maxT) loc ts = +addSeedBot e (minT, maxT) loc ts = do + em <- use $ landscape . entityMap zoomRobots . addTRobot (initMachine (seedProgram minT (maxT - minT) (e ^. entityName)) empty emptyStore) $ mkRobot + em Nothing "seed" (Markdown.fromText $ T.unwords ["A growing", e ^. entityName, "seed."]) diff --git a/src/swarm-scenario/Swarm/Game/Device.hs b/src/swarm-scenario/Swarm/Game/Device.hs index 01c49c271c..cff91ed683 100644 --- a/src/swarm-scenario/Swarm/Game/Device.hs +++ b/src/swarm-scenario/Swarm/Game/Device.hs @@ -7,9 +7,10 @@ module Swarm.Game.Device where import Control.Applicative ((<|>)) import Data.Function (on) import Data.Hashable +import Data.List.NonEmpty (NonEmpty (..)) import Data.Map (Map) import Data.Map qualified as M -import Data.Semigroup (Min (..)) +import Data.Set (Set) import Data.Vector qualified as V import Data.Yaml import GHC.Generics (Generic) @@ -19,9 +20,16 @@ import Swarm.Language.Capability (Capability) -- This wrapper exists so that YAML can be parsed -- either as a list of 'Capability' or as a Map. newtype Capabilities e = Capabilities - { getMap :: Map Capability (Min (ExerciseCost e)) + { getMap :: Map Capability e } - deriving (Show, Eq, Generic, ToJSON, Hashable) + deriving (Show, Eq, Generic, ToJSON, Hashable, Functor) + +getCapabilitySet :: Capabilities e -> Set Capability +getCapabilitySet (Capabilities m) = M.keysSet m + +type SingleEntityCapabilities e = Capabilities (ExerciseCost e) + +type MultiEntityCapabilities e = Capabilities (NonEmpty (DeviceUseCost e)) -- | For JSON parsing only data CapabilityCost e = CapabilityCost @@ -30,13 +38,13 @@ data CapabilityCost e = CapabilityCost } deriving (Generic, FromJSON) -instance (FromJSON e) => FromJSON (Capabilities e) where +instance (FromJSON e) => FromJSON (SingleEntityCapabilities e) where parseJSON x = Capabilities <$> (simpleList <|> costMap) where - simpleList = M.fromSet (const $ pure $ ExerciseCost []) <$> parseJSON x + simpleList = M.fromSet (const $ ExerciseCost []) <$> parseJSON x costMap = withArray "Capabilities" (fmap (M.fromList . map toMapEntry) . mapM parseJSON . V.toList) x - toMapEntry (CapabilityCost a b) = (a, pure $ ExerciseCost b) + toMapEntry (CapabilityCost a b) = (a, ExerciseCost b) instance (Ord e, Semigroup e) => Semigroup (Capabilities e) where Capabilities c1 <> Capabilities c2 = @@ -49,15 +57,13 @@ instance (Ord e, Semigroup e) => Monoid (Capabilities e) where newtype ExerciseCost e = ExerciseCost { ingredients :: IngredientList e } - deriving (Eq, Show, Generic, FromJSON, ToJSON, Hashable) + deriving (Eq, Show, Generic, FromJSON, ToJSON, Hashable, Functor) instance (Eq e) => Ord (ExerciseCost e) where compare = compare `on` (getCost . ingredients) --- TODO Intended to be used as follows: --- Map Capability [DeviceUseCost Entity EntityName] -data DeviceUseCost e en = DeviceUseCost - { useCost :: ExerciseCost en +data DeviceUseCost e = DeviceUseCost + { useCost :: ExerciseCost e , device :: e } - deriving (Eq, Show, Generic, FromJSON, ToJSON) + deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON) diff --git a/src/swarm-scenario/Swarm/Game/Entity.hs b/src/swarm-scenario/Swarm/Game/Entity.hs index 142266c194..dbf30263e7 100644 --- a/src/swarm-scenario/Swarm/Game/Entity.hs +++ b/src/swarm-scenario/Swarm/Game/Entity.hs @@ -51,7 +51,7 @@ module Swarm.Game.Entity ( loadEntities, allEntities, lookupEntityName, - deviceForCap, + devicesForCap, -- * Inventories Inventory, @@ -94,6 +94,8 @@ import Control.Lens (Getter, Lens', lens, to, view, (^.)) import Control.Monad (forM_, unless, (<=<)) import Data.Bifunctor (first) import Data.Char (toLower) +import Data.Either (fromRight) +import Data.Either.Extra (maybeToEither) import Data.Function (on) import Data.Hashable import Data.IntMap (IntMap) @@ -105,9 +107,8 @@ import Data.List.NonEmpty qualified as NE import Data.Map (Map) import Data.Map qualified as M import Data.Maybe (isJust, listToMaybe) -import Data.Semigroup (getMin) import Data.Set (Set) -import Data.Set qualified as Set (fromList, member, unions) +import Data.Set qualified as Set (fromList, member) import Data.Text (Text) import Data.Text qualified as T import Data.Yaml @@ -279,7 +280,7 @@ data Entity = Entity -- grabbed. , _entityProperties :: Set EntityProperty -- ^ Properties of the entity. - , _entityCapabilities :: Capabilities EntityName + , _entityCapabilities :: SingleEntityCapabilities EntityName -- ^ Capabilities provided by this entity. , _entityInventory :: Inventory -- ^ Inventory of other entities held by this entity. @@ -349,7 +350,7 @@ mkEntity disp nm descr props caps = Nothing Nothing (Set.fromList props) - (Capabilities $ M.fromSet (const $ pure $ ExerciseCost []) caps) + (Capabilities $ M.fromSet (const $ ExerciseCost []) caps) empty ------------------------------------------------------------ @@ -366,10 +367,10 @@ mkEntity disp nm descr props caps = -- the 'Swarm.Language.Syntax.TagMembers' command. data EntityMap = EntityMap { entitiesByName :: Map EntityName Entity - , entitiesByCap :: Map Capability [DeviceUseCost Entity EntityName] + , entitiesByCap :: MultiEntityCapabilities Entity , entityDefinitionOrder :: [Entity] } - deriving (Eq, Show, Generic, FromJSON, ToJSON) + deriving (Eq, Show, Generic, ToJSON) -- | -- Note that duplicates in a single 'EntityMap' are precluded by the @@ -384,11 +385,11 @@ instance Semigroup EntityMap where EntityMap n1 c1 d1 <> EntityMap n2 c2 d2 = EntityMap (n1 <> n2) - (M.unionWith (<>) c1 c2) + (c1 <> c2) (filter ((`M.notMember` n2) . view entityName) d1 <> d2) instance Monoid EntityMap where - mempty = EntityMap M.empty M.empty [] + mempty = EntityMap M.empty mempty [] mappend = (<>) -- | Get a list of all the entities in the entity map. @@ -401,8 +402,8 @@ lookupEntityName nm = M.lookup nm . entitiesByName -- | Find all entities which are devices that provide the given -- capability. -deviceForCap :: Capability -> EntityMap -> [Entity] -deviceForCap cap = maybe [] (map device) . M.lookup cap . entitiesByCap +devicesForCap :: Capability -> EntityMap -> [Entity] +devicesForCap cap = maybe [] (NE.toList . NE.map device) . M.lookup cap . getMap . entitiesByCap -- | Validates references to 'Display' attributes validateAttrRefs :: Has (Throw LoadingFailure) sig m => Set WorldAttr -> [Entity] -> m () @@ -431,16 +432,48 @@ buildEntityMap es = do case findDup (map fst namedEntities) of Nothing -> return () Just duped -> throwError $ Duplicate Entities duped - return $ - EntityMap - { entitiesByName = entsByName - , entitiesByCap = entsByCap - , entityDefinitionOrder = es - } + + case combineEntityCaps entsByName es of + -- TODO Add unit test for this validation + Left x -> throwError $ CustomMessage x + Right ebc -> + return $ + EntityMap + { entitiesByName = entsByName + , entitiesByCap = ebc + , entityDefinitionOrder = es + } where - entsByName = M.fromList namedEntities - entsByCap = M.fromListWith (<>) . concatMap (\e -> map (\(cap, itemCost) -> (cap, pure $ DeviceUseCost (getMin itemCost) e)) (M.toList $ getMap $ e ^. entityCapabilities)) $ es namedEntities = map (view entityName &&& id) es + entsByName = M.fromList namedEntities + +combineEntityCaps :: + Map EntityName Entity -> + [Entity] -> + Either Text (MultiEntityCapabilities Entity) +combineEntityCaps em es = do + miniThings <- mapM mkForEntity es + return $ mconcat miniThings + where + transformCaps (Capabilities m) = do + newMap <- mapM doLookup m + return $ Capabilities newMap + where + doLookup (ExerciseCost ings) = do + newIngs <- mapM finalLookup ings + return $ ExerciseCost newIngs + + finalLookup (c, en) = do + e <- maybeToEither "bad thing" $ M.lookup en em + return (c, e) + + mkForEntity e = do + betterCaps <- transformCaps originalCaps + return $ f <$> betterCaps + where + originalCaps = e ^. entityCapabilities + + f itemCost = pure $ DeviceUseCost itemCost e ------------------------------------------------------------ -- Serialization @@ -460,7 +493,7 @@ instance FromJSON Entity where <*> v .:? "combustion" <*> v .:? "yields" <*> v .:? "properties" .!= mempty - <*> v .:? "capabilities" .!= mempty + <*> v .:? "capabilities" .!= Capabilities mempty <*> pure empty ) @@ -583,7 +616,7 @@ hasProperty :: Entity -> EntityProperty -> Bool hasProperty e p = p `elem` (e ^. entityProperties) -- | The capabilities this entity provides when equipped. -entityCapabilities :: Lens' Entity (Capabilities EntityName) +entityCapabilities :: Lens' Entity (SingleEntityCapabilities EntityName) entityCapabilities = hashedLens _entityCapabilities (\e x -> e {_entityCapabilities = x}) -- | The inventory of other entities carried by this entity. @@ -707,10 +740,9 @@ isEmpty :: Inventory -> Bool isEmpty = all ((== 0) . fst) . elems -- | Compute the set of capabilities provided by the devices in an inventory. --- TODO --- inventoryCapabilities :: Inventory -> Capabilities EntityName -inventoryCapabilities :: Inventory -> Set Capability -inventoryCapabilities = Set.unions . map (M.keysSet . getMap . (^. entityCapabilities)) . nonzeroEntities +inventoryCapabilities :: EntityMap -> Inventory -> MultiEntityCapabilities Entity +inventoryCapabilities em = + fromRight mempty . combineEntityCaps (entitiesByName em) . nonzeroEntities -- | List elements that have at least one copy in the inventory. nonzeroEntities :: Inventory -> [Entity] diff --git a/src/swarm-scenario/Swarm/Game/Recipe.hs b/src/swarm-scenario/Swarm/Game/Recipe.hs index 840c20aefe..e55b858680 100644 --- a/src/swarm-scenario/Swarm/Game/Recipe.hs +++ b/src/swarm-scenario/Swarm/Game/Recipe.hs @@ -47,6 +47,7 @@ module Swarm.Game.Recipe ( recipesFor, make, make', + findLacking, ) where import Control.Algebra (Has) @@ -215,6 +216,13 @@ data MissingIngredient = MissingIngredient MissingType Count Entity data MissingType = MissingInput | MissingCatalyst deriving (Show, Eq) +-- | Determines whether recipe inputs are satisfied by a +-- robot's inventory. +findLacking :: Inventory -> [(Count, Entity)] -> [(Count, Entity)] +findLacking robotInventory = filter ((> 0) . fst) . map countNeeded + where + countNeeded (need, entity) = (need - E.lookup entity robotInventory, entity) + -- | Figure out which ingredients (if any) are lacking from an -- inventory to be able to carry out the recipe. Catalysts are not -- consumed and so can be used even when equipped. @@ -224,8 +232,6 @@ missingIngredientsFor (inv, ins) (Recipe inps _ cats _ _) = <> mkMissing MissingCatalyst (findLacking ins (findLacking inv cats)) where mkMissing k = map (uncurry (MissingIngredient k)) - findLacking inven = filter ((> 0) . fst) . map (countNeeded inven) - countNeeded inven (need, entity) = (need - E.lookup entity inven, entity) -- | Figure out if a recipe is available, /i.e./ if we at least know -- about all the ingredients. Note it does not matter whether we have @@ -254,7 +260,12 @@ make invs r = finish <$> make' invs r finish (invTaken, out) = (invTaken, out, r) -- | Try to make a recipe, but do not insert it yet. -make' :: (Inventory, Inventory) -> Recipe Entity -> Either [MissingIngredient] (Inventory, IngredientList Entity) +make' :: + (Inventory, Inventory) -> + Recipe Entity -> + Either + [MissingIngredient] + (Inventory, IngredientList Entity) make' invs@(inv, _) r = case missingIngredientsFor invs r of [] -> diff --git a/src/swarm-scenario/Swarm/Game/Robot.hs b/src/swarm-scenario/Swarm/Game/Robot.hs index 9368f8ff43..3a43121d97 100644 --- a/src/swarm-scenario/Swarm/Game/Robot.hs +++ b/src/swarm-scenario/Swarm/Game/Robot.hs @@ -78,6 +78,7 @@ import Data.Text (Text) import Data.Yaml (FromJSON (parseJSON), (.!=), (.:), (.:?)) import GHC.Generics (Generic) import Linear +import Swarm.Game.Device import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay, invisible) import Swarm.Game.Entity hiding (empty) import Swarm.Game.Ingredients @@ -135,7 +136,17 @@ type instance RobotLogUpdatedMember 'TemplateRobot = () data RobotR (phase :: RobotPhase) = RobotR { _robotEntity :: Entity , _equippedDevices :: Inventory - , _robotCapabilities :: Set Capability + , _globalEntityMap :: EntityMap + -- ^ A cached reference to the global entity map, which is static + -- from scenario parse time. + -- This is used to convert entity names in + -- "capability exercise" recipes to actual entities. + -- We need "actual entities" instead of mere entity names + -- to make use of the 'Swarm.Game.Recipe.findLacking' function + -- that determines whether recipe inputs are satisfied by a + -- robot's inventory. + -- TODO: Are we sure we need this after all? + , _robotCapabilities :: MultiEntityCapabilities Entity -- ^ A cached view of the capabilities this robot has. -- Automatically generated from '_equippedDevices'. , _robotLog :: RobotLogMember phase @@ -161,7 +172,7 @@ deriving instance (Eq (RobotLocation phase), Eq (RobotID phase), Eq (RobotMachin -- See https://byorgey.wordpress.com/2021/09/17/automatically-updated-cached-views-with-lens/ -- for the approach used here with lenses. -makeLensesExcluding ['_robotCapabilities, '_equippedDevices, '_robotLog, '_robotLogUpdated, '_robotContext, '_machine, '_activityCounts] ''RobotR +makeLensesExcluding ['_globalEntityMap, '_robotCapabilities, '_equippedDevices, '_robotLog, '_robotLogUpdated, '_robotContext, '_machine, '_activityCounts] ''RobotR -- | A template robot, i.e. a template robot record without a unique ID number, -- and possibly without a location. @@ -272,7 +283,7 @@ equippedDevices = lens _equippedDevices setEquipped setEquipped r inst = r { _equippedDevices = inst - , _robotCapabilities = inventoryCapabilities inst + , _robotCapabilities = inventoryCapabilities (_globalEntityMap r) inst } -- | A hash of a robot's entity record and equipped devices, to @@ -289,7 +300,7 @@ robotKnows r e = contains0plus e (r ^. robotInventory) || contains0plus e (r ^. -- getter, not a lens, because it is automatically generated from -- the 'equippedDevices'. The only way to change a robot's -- capabilities is to modify its 'equippedDevices'. -robotCapabilities :: Getter Robot (Set Capability) +robotCapabilities :: Getter Robot (MultiEntityCapabilities Entity) robotCapabilities = to _robotCapabilities -- | Is this robot a "system robot"? System robots are generated by @@ -313,10 +324,11 @@ data WalkabilityContext walkabilityContext :: Getter Robot WalkabilityContext walkabilityContext = to $ - \x -> WalkabilityContext (_robotCapabilities x) (_unwalkableEntities x) + \x -> WalkabilityContext (getCapabilitySet $ _robotCapabilities x) (_unwalkableEntities x) -- | A general function for creating robots. mkRobot :: + EntityMap -> Maybe Int -> -- | Name of the robot. Text -> @@ -343,14 +355,15 @@ mkRobot :: -- | Creation date TimeSpec -> TRobot -mkRobot pid name descr loc dir disp m devs inv sys heavy unwalkables ts = +mkRobot em pid name descr loc dir disp m devs inv sys heavy unwalkables ts = RobotR { _robotEntity = mkEntity disp name descr [] mempty & entityOrientation ?~ dir & entityInventory .~ fromElems inv , _equippedDevices = inst - , _robotCapabilities = inventoryCapabilities inst + , _globalEntityMap = em + , _robotCapabilities = inventoryCapabilities em inst , _robotLog = () , _robotLogUpdated = () , _robotLocation = loc @@ -385,8 +398,9 @@ instance FromJSONE EntityMap TRobot where -- filled in later when adding the robot to the world. sys <- liftE $ v .:? "system" .!= False let defDisplay = defaultRobotDisplay & invisible .~ sys + em <- getE - mkRobot Nothing + mkRobot em Nothing <$> liftE (v .: "name") <*> liftE (v .:? "description" .!= mempty) <*> liftE (v .:? "loc") diff --git a/test/unit/TestRecipeCoverage.hs b/test/unit/TestRecipeCoverage.hs index 77cd394851..ab30836a9a 100644 --- a/test/unit/TestRecipeCoverage.hs +++ b/test/unit/TestRecipeCoverage.hs @@ -7,11 +7,12 @@ -- grant capabilities (aka "devices"). module TestRecipeCoverage where -import Swarm.Game.Device import Control.Lens ((^.)) +import Data.List.NonEmpty qualified as NE import Data.Map qualified as M import Data.Set qualified as Set import Data.Text qualified as T +import Swarm.Game.Device import Swarm.Game.Entity (EntityMap (entitiesByCap), entityName) import Swarm.Game.Recipe (recipeOutputs) import Swarm.Game.State.Runtime (RuntimeState, stdEntityMap, stdRecipes) @@ -42,7 +43,8 @@ testDeviceRecipeCoverage rs = ] -- Only include entities that grant a capability: - entityNames = Set.fromList . map ((^. entityName) . device) . concat . M.elems . entitiesByCap $ rs ^. stdEntityMap + entityNames = + Set.fromList . map ((^. entityName) . device) . concatMap NE.toList . M.elems . getMap . entitiesByCap $ rs ^. stdEntityMap getOutputsForRecipe r = map ((^. entityName) . snd) $ r ^. recipeOutputs recipeOutputEntities = Set.fromList . concatMap getOutputsForRecipe $ rs ^. stdRecipes diff --git a/test/unit/TestUtil.hs b/test/unit/TestUtil.hs index 922a2285ce..476ffd19b1 100644 --- a/test/unit/TestUtil.hs +++ b/test/unit/TestUtil.hs @@ -59,7 +59,10 @@ play g = either (return . (,g) . Left) playPT . processTerm1 playPT pt = runStateT (playUntilDone (hr ^. robotID)) gs where cesk = initMachine pt empty emptyStore - hr = hypotheticalRobot cesk 0 + + em = g ^. landscape . entityMap + + hr = hypotheticalRobot em cesk 0 hid = hr ^. robotID gs = g