Show exercise cost in UI

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

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.
+    ...

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:

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

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

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