diff --git a/data/scenarios/Testing/00-ORDER.txt b/data/scenarios/Testing/00-ORDER.txt index 790917913b..9e1970a4fc 100644 --- a/data/scenarios/Testing/00-ORDER.txt +++ b/data/scenarios/Testing/00-ORDER.txt @@ -36,6 +36,7 @@ Achievements 1218-stride-command.yaml 1234-push-command.yaml 1256-halt-command.yaml +1262-display-device-commands.yaml 1295-density-command.yaml 1138-structures 1320-world-DSL diff --git a/data/scenarios/Testing/1262-display-device-commands.yaml b/data/scenarios/Testing/1262-display-device-commands.yaml new file mode 100644 index 0000000000..884d8758e3 --- /dev/null +++ b/data/scenarios/Testing/1262-display-device-commands.yaml @@ -0,0 +1,54 @@ +version: 1 +name: Device commands +description: | + Demo display of commands offered by each device, along with their cost. +creative: false +robots: + - name: base + dir: east + devices: + - treads + - logger + - Fresnel lens + - string + inventory: + - [1, flash bulb] + - [1, photographic plate] +entities: + - name: flash bulb + display: + char: 'f' + description: + - Consumables for a `Fresnel lens`{=entity} that enable `ignite`ing + properties: [known, pickable] + - name: photographic plate + display: + char: 'p' + description: + - Consumables for a `Fresnel lens`{=entity} that enable `scan`ning + properties: [known, pickable] + - name: Fresnel lens + display: + char: 'z' + description: + - Ignites things with sufficiently powerful light source + properties: [known, pickable] + capabilities: + - capability: ignite + cost: + - [1, "flash bulb"] + - capability: scan + cost: + - [2, "photographic plate"] +known: [water] +world: + dsl: | + {water} + palette: + 'B': [grass, erase, base] + '.': [grass, erase] + upperleft: [-1, 1] + map: | + ... + .B. + ... diff --git a/data/scenarios/Testing/1777-capability-cost.yaml b/data/scenarios/Testing/1777-capability-cost.yaml index aa79d33673..04006210d4 100644 --- a/data/scenarios/Testing/1777-capability-cost.yaml +++ b/data/scenarios/Testing/1777-capability-cost.yaml @@ -50,7 +50,7 @@ entities: display: char: 'f' description: - - Fuel for a Zippo + - Fuel for a `Zippo`{=entity} properties: [known, pickable] - name: Zippo display: diff --git a/src/Swarm/TUI/View.hs b/src/Swarm/TUI/View.hs index 927025534a..00964a6dc3 100644 --- a/src/Swarm/TUI/View.hs +++ b/src/Swarm/TUI/View.hs @@ -73,7 +73,7 @@ import Network.Wai.Handler.Warp (Port) import Numeric (showFFloat) import Swarm.Constant import Swarm.Game.CESK (CESK (..)) -import Swarm.Game.Device (getMap) +import Swarm.Game.Device (commandCost, commandsForDeviceCaps, enabledCommands, getMap, ingredients) import Swarm.Game.Display import Swarm.Game.Entity as E import Swarm.Game.Ingredients @@ -1210,6 +1210,7 @@ explainEntry s e = vBox $ [ displayProperties $ Set.toList (e ^. entityProperties) , drawMarkdown (e ^. entityDescription) + , explainCapabilities (s ^. gameState) e , explainRecipes s e ] <> [drawRobotMachine s False | CDebug `M.member` getMap (e ^. entityCapabilities)] @@ -1239,6 +1240,66 @@ displayProperties = displayList . mapMaybe showProperty , txt " " ] +-- | This widget can have potentially multiple "headings" +-- (one per capability), each with multiple commands underneath. +-- Directly below each heading there will be a "exercise cost" +-- description, unless the capability is free-to-exercise. +explainCapabilities :: GameState -> Entity -> Widget Name +explainCapabilities gs e + | null capabilitiesAndCommands = emptyWidget + | otherwise = + padBottom (Pad 1) $ + vBox + [ hBorderWithLabel (txt "Enabled commands") + , hCenter + . vBox + . L.intersperse (padTop (Pad 1) . hCenter . txt $ T.replicate 10 "*") + $ map drawSingleCapabilityWidget capabilitiesAndCommands + ] + where + eLookup = lookupEntityE $ entitiesByName $ gs ^. landscape . terrainAndEntities . entityMap + eitherCosts = (traverse . traverse) eLookup $ e ^. entityCapabilities + capabilitiesAndCommands = case eitherCosts of + Right eCaps -> M.elems . getMap . commandsForDeviceCaps $ eCaps + Left x -> + error $ + unwords + [ "Error: somehow an invalid entity reference escaped the parse-time check" + , T.unpack x + ] + + drawSingleCapabilityWidget cmdsAndCost = + vBox + [ costWidget cmdsAndCost + , padLeft (Pad 1) . vBox . map renderCmdInfo . NE.toList $ enabledCommands cmdsAndCost + ] + + renderCmdInfo c = + padTop (Pad 1) $ + vBox + [ hBox + [ padRight (Pad 1) (txt . syntax $ constInfo c) + , padRight (Pad 1) (txt ":") + , withAttr magentaAttr . txt . prettyText $ inferConst c + ] + , padTop (Pad 1) . padLeft (Pad 1) . txtWrap . briefDoc . constDoc $ constInfo c + ] + + costWidget cmdsAndCost = + if null ings + then emptyWidget + else padTop (Pad 1) $ vBox $ withAttr boldAttr (txt "Cost:") : map drawCost ings + where + ings = ingredients $ commandCost cmdsAndCost + + drawCost (n, ingr) = + padRight (Pad 1) (str (show n)) <+> eName + where + eName = applyEntityNameAttr Nothing missing ingr $ txt $ ingr ^. entityName + missing = E.lookup ingr robotInv < n + + robotInv = fromMaybe E.empty $ gs ^? to focusedRobot . _Just . robotInventory + explainRecipes :: AppState -> Entity -> Widget Name explainRecipes s e | null recipes = emptyWidget @@ -1350,16 +1411,21 @@ drawRecipe me inv (Recipe ins outs reqs time _weight) = -- If it's the focused entity, draw it highlighted. -- If the robot doesn't have any, draw it in red. - fmtEntityName missing ingr - | Just ingr == me = withAttr highlightAttr $ txtLines nm - | ingr == timeE = withAttr yellowAttr $ txtLines nm - | missing = withAttr invalidFormInputAttr $ txtLines nm - | otherwise = txtLines nm + fmtEntityName :: Bool -> Entity -> Widget n + fmtEntityName missing ingr = + applyEntityNameAttr me missing ingr $ txtLines nm where -- Split up multi-word names, one line per word nm = ingr ^. entityName txtLines = vBox . map txt . T.words +applyEntityNameAttr :: Maybe Entity -> Bool -> Entity -> (Widget n -> Widget n) +applyEntityNameAttr me missing ingr + | Just ingr == me = withAttr highlightAttr + | ingr == timeE = withAttr yellowAttr + | missing = withAttr invalidFormInputAttr + | otherwise = id + -- | Ad-hoc entity to represent time - only used in recipe drawing timeE :: Entity timeE = mkEntity (defaultEntityDisplay '.') "ticks" mempty [] mempty diff --git a/src/swarm-engine/Swarm/Game/Step/Util/Command.hs b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs index a754b8c8c3..cf716bb065 100644 --- a/src/swarm-engine/Swarm/Game/Step/Util/Command.hs +++ b/src/swarm-engine/Swarm/Game/Step/Util/Command.hs @@ -20,9 +20,9 @@ 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.IntSet qualified as IS import Data.List (find) import Data.List.NonEmpty qualified as NE -import Data.IntSet qualified as IS import Data.Map qualified as M import Data.Sequence qualified as Seq import Data.Set (Set) diff --git a/src/swarm-lang/Swarm/Language/Capability.hs b/src/swarm-lang/Swarm/Language/Capability.hs index 68a9e520c1..3fb4e3abe1 100644 --- a/src/swarm-lang/Swarm/Language/Capability.hs +++ b/src/swarm-lang/Swarm/Language/Capability.hs @@ -12,18 +12,24 @@ module Swarm.Language.Capability ( Capability (..), capabilityName, constCaps, + constByCaps, ) where +import Control.Arrow ((&&&)) import Data.Aeson (FromJSONKey, ToJSONKey) import Data.Char (toLower) import Data.Data (Data) import Data.Hashable (Hashable) +import Data.List.NonEmpty qualified as NE +import Data.Map (Map) +import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Text qualified as T +import Data.Tuple (swap) import Data.Yaml import GHC.Generics (Generic) import Swarm.Language.Syntax -import Swarm.Util (failT) +import Swarm.Util (binTuples, failT) import Text.Read (readMaybe) import Witch (from) import Prelude hiding (lookup) @@ -336,3 +342,10 @@ constCaps = \case -- currently don't. View -> Nothing -- TODO: #17 should require equipping an antenna Knows -> Nothing + +-- | Inverts the 'constCaps' mapping. +constByCaps :: Map Capability (NE.NonEmpty Const) +constByCaps = + binTuples $ + map swap $ + mapMaybe (sequenceA . (id &&& constCaps)) allConst diff --git a/src/swarm-scenario/Swarm/Game/Device.hs b/src/swarm-scenario/Swarm/Game/Device.hs index 65688a3ea6..e913a1127f 100644 --- a/src/swarm-scenario/Swarm/Game/Device.hs +++ b/src/swarm-scenario/Swarm/Game/Device.hs @@ -12,8 +12,10 @@ module Swarm.Game.Device ( Capabilities (..), DeviceUseCost (..), ExerciseCost (..), + CommandsAndCost (..), getCapabilitySet, zeroCostCapabilities, + commandsForDeviceCaps, ) where @@ -28,7 +30,8 @@ import Data.Vector qualified as V import Data.Yaml import GHC.Generics (Generic) import Swarm.Game.Ingredients -import Swarm.Language.Capability (Capability) +import Swarm.Language.Capability (Capability, constByCaps) +import Swarm.Language.Syntax (Const) -- This wrapper exists so that YAML can be parsed -- either as a list of 'Capability' or as a Map. @@ -40,13 +43,13 @@ newtype Capabilities e = Capabilities getCapabilitySet :: Capabilities e -> Set Capability getCapabilitySet (Capabilities m) = M.keysSet m -zeroCostCapabilities :: Set Capability -> Capabilities (ExerciseCost e) -zeroCostCapabilities = Capabilities . M.fromSet (const $ ExerciseCost []) - type SingleEntityCapabilities e = Capabilities (ExerciseCost e) type MultiEntityCapabilities e en = Capabilities (NonEmpty (DeviceUseCost e en)) +zeroCostCapabilities :: Set Capability -> SingleEntityCapabilities e +zeroCostCapabilities = Capabilities . M.fromSet (const $ ExerciseCost []) + -- | For JSON parsing only data CapabilityCost e = CapabilityCost { capability :: Capability @@ -85,3 +88,21 @@ data DeviceUseCost e en = DeviceUseCost , useCost :: ExerciseCost en } deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON, Functor, Foldable, Traversable) + +-- * Utils + +data CommandsAndCost e = CommandsAndCost + { commandCost :: ExerciseCost e + , enabledCommands :: NonEmpty Const + } + +-- | NOTE: Because each 'Const' is mapped to at most one +-- 'Capability' by the 'constCaps' function, we know that +-- a given 'Const' will not appear more than once as a value in the 'Map' produced by +-- this function, i.e. for the capabilities provided by a single 'Entity` +-- ('SingleEntityCapabilities'). +commandsForDeviceCaps :: SingleEntityCapabilities e -> Capabilities (CommandsAndCost e) +commandsForDeviceCaps = Capabilities . M.mapMaybeWithKey f . getMap + where + f cap xc = + CommandsAndCost xc <$> M.lookup cap constByCaps diff --git a/src/swarm-scenario/Swarm/Game/Robot.hs b/src/swarm-scenario/Swarm/Game/Robot.hs index a67671b525..50b0c25aa5 100644 --- a/src/swarm-scenario/Swarm/Game/Robot.hs +++ b/src/swarm-scenario/Swarm/Game/Robot.hs @@ -71,7 +71,6 @@ import Control.Applicative ((<|>)) import Control.Lens hiding (Const, contains) import Data.Hashable (hashWithSalt) import Data.Kind qualified -import Data.Set (Set) import Data.Text (Text) import Data.Yaml (FromJSON (parseJSON), (.!=), (.:), (.:?)) import GHC.Generics (Generic) @@ -84,7 +83,6 @@ import Swarm.Game.Land import Swarm.Game.Location (Heading, Location, toDirection, toHeading) import Swarm.Game.Robot.Walk import Swarm.Game.Universe -import Swarm.Language.Capability (Capability) import Swarm.Language.Pipeline (ProcessedTerm) import Swarm.Language.Syntax (Syntax) import Swarm.Language.Text.Markdown (Document)