show devices that enable commands

src/Swarm/Game/Entity.hs

@@ -70,6 +70,7 @@ module Swarm.Game.Entity (
   isEmpty,
   inventoryCapabilities,
   extantElemsWithCapability,
+  entitiesByCapability,
 
   -- ** Modification
   insert,
@@ -94,6 +95,7 @@ import Data.IntMap qualified as IM
 import Data.IntSet (IntSet)
 import Data.IntSet qualified as IS
 import Data.List (foldl')
+import Data.List.NonEmpty qualified as NE
 import Data.Map (Map)
 import Data.Map qualified as M
 import Data.Maybe (fromMaybe, isJust, listToMaybe)
@@ -106,7 +108,7 @@ import GHC.Generics (Generic)
 import Linear (V2)
 import Swarm.Game.Display
 import Swarm.Language.Capability
-import Swarm.Util (dataNotFound, getDataFileNameSafe, plural, reflow, (?))
+import Swarm.Util (binTuples, dataNotFound, getDataFileNameSafe, plural, reflow, (?))
 import Swarm.Util.Yaml
 import Text.Read (readMaybe)
 import Witch
@@ -580,6 +582,14 @@ extantElemsWithCapability :: Capability -> Inventory -> [Entity]
 extantElemsWithCapability cap =
   filter (Set.member cap . (^. entityCapabilities)) . nonzeroEntities
 
+-- | Groups entities by the capabilities they offer.
+entitiesByCapability :: Inventory -> Map Capability (NE.NonEmpty Entity)
+entitiesByCapability inv =
+  binTuples entityCapabilityPairs
+ where
+  getCaps = Set.toList . (^. entityCapabilities)
+  entityCapabilityPairs = concatMap ((\e -> map (,e) $ getCaps e) . snd) $ elems inv
+
 -- | Delete a single copy of a certain entity from an inventory.
 delete :: Entity -> Inventory -> Inventory
 delete = deleteCount 1

src/Swarm/TUI/View.hs

@@ -88,6 +88,7 @@ import Swarm.Game.ScenarioInfo (
 import Swarm.Game.State
 import Swarm.Game.Terrain (terrainMap)
 import Swarm.Game.World qualified as W
+import Swarm.Language.Capability (constCaps)
 import Swarm.Language.Pretty (prettyText)
 import Swarm.Language.Syntax
 import Swarm.Language.Typecheck (inferConst)
@@ -458,7 +459,7 @@ drawModal s = \case
   HelpModal -> helpWidget (s ^. gameState . seed) (s ^. runtimeState . webPort)
   RobotsModal -> robotsListWidget s
   RecipesModal -> availableListWidget (s ^. gameState) RecipeList
-  CommandsModal -> availableListWidget (s ^. gameState) CommandList
+  CommandsModal -> commandsListWidget (s ^. gameState)
   MessagesModal -> availableListWidget (s ^. gameState) MessageList
   WinModal -> padBottom (Pad 1) $ hCenter $ txt "Congratulations!"
   DescriptionModal e -> descriptionWidget s e
@@ -594,18 +595,16 @@ helpWidget theSeed mport =
     , ("Meta-t", "focus on the info panel")
     ]
 
-data NotificationList = RecipeList | CommandList | MessageList
+data NotificationList = RecipeList | MessageList
 
 availableListWidget :: GameState -> NotificationList -> Widget Name
 availableListWidget gs nl = padTop (Pad 1) $ vBox widgetList
  where
   widgetList = case nl of
     RecipeList -> mkAvailableList gs availableRecipes renderRecipe
-    CommandList -> mkAvailableList gs availableCommands renderCommand & (<> constWiki) . (padLeftRight 18 constHeader :)
     MessageList -> messagesWidget gs
   renderRecipe = padLeftRight 18 . drawRecipe Nothing (fromMaybe E.empty inv)
   inv = gs ^? to focusedRobot . _Just . robotInventory
-  renderCommand = padLeftRight 18 . drawConst
 
 mkAvailableList :: GameState -> Lens' GameState (Notifications a) -> (a -> Widget Name) -> [Widget Name]
 mkAvailableList gs notifLens notifRender = map padRender news <> notifSep <> map padRender knowns
@@ -619,21 +618,55 @@ mkAvailableList gs notifLens notifRender = map padRender news <> notifSep <> map
         ]
     | otherwise = []
 
-constHeader :: Widget Name
-constHeader = padBottom (Pad 1) $ withAttr robotAttr $ padLeft (Pad 1) $ txt "command name : type"
+commandsListWidget :: GameState -> Widget Name
+commandsListWidget gs =
+  hCenter $
+    vBox
+      [ table
+      , padTop (Pad 1) $ txt "For the full list of available commands see the Wiki at:"
+      , txt "https://github.com/swarm-game/swarm/wiki/Commands-Cheat-Sheet"
+      ]
+ where
+  commands = gs ^. availableCommands . notificationsContent
+  table =
+    BT.renderTable
+      . BT.surroundingBorder False
+      . BT.columnBorders False
+      . BT.rowBorders False
+      . BT.setDefaultColAlignment BT.AlignLeft
+      . BT.alignRight 0
+      . BT.table
+      $ headers : commandsTable
+  headers =
+    withAttr robotAttr
+      <$> [ txt "command name"
+          , txt " : type"
+          , txt "Enabled by"
+          ]
 
-constWiki :: [Widget Name]
-constWiki =
-  padLeftRight 13
-    <$> [ padTop (Pad 2) $ txt "For the full list of available commands see the Wiki at:"
-        , txt "https://github.com/swarm-game/swarm/wiki/Commands-Cheat-Sheet"
-        ]
+  commandsTable = mkCmdRow <$> commands
+  mkCmdRow cmd =
+    map
+      (padTop $ Pad 1)
+      [ txt $ syntax $ constInfo cmd
+      , padRight (Pad 2) $ txt $ " : " <> prettyText (inferConst cmd)
+      , listDevices cmd
+      ]
 
-drawConst :: Const -> Widget Name
-drawConst c = hBox [padLeft (Pad $ 13 - T.length constName) (txt constName), txt constSig]
- where
-  constName = syntax . constInfo $ c
-  constSig = " : " <> prettyText (inferConst c)
+  base = gs ^? baseRobot
+  entsByCap = case base of
+    Just r ->
+      M.map NE.toList $
+        entitiesByCapability $
+          (r ^. installedDevices) `union` (r ^. robotInventory)
+    Nothing -> mempty
+
+  listDevices cmd = vBox $ map drawLabelledEntityName providerDevices
+   where
+    providerDevices =
+      concatMap (flip (M.findWithDefault []) entsByCap) $
+        maybeToList $
+          constCaps cmd
 
 -- | Generate a pop-up widget to display the description of an entity.
 descriptionWidget :: AppState -> Entity -> Widget Name

src/Swarm/Util.hs

@@ -21,6 +21,7 @@ module Swarm.Util (
   uniq,
   getElemsInArea,
   manhattan,
+  binTuples,
 
   -- * Directory utilities
   readFileMay,
@@ -84,6 +85,7 @@ import Data.Either.Validation
 import Data.Int (Int64)
 import Data.List (maximumBy, partition)
 import Data.List.NonEmpty (NonEmpty (..))
+import Data.List.NonEmpty qualified as NE
 import Data.Map (Map)
 import Data.Map qualified as M
 import Data.Maybe (fromMaybe, mapMaybe)
@@ -204,6 +206,16 @@ getElemsInArea o@(V2 x y) d m = M.elems sm'
       & fst -- B>
   sm' = M.filterWithKey (const . (<= d) . manhattan o) sm
 
+-- | Place the second element of the tuples into bins by
+-- the value of the first element.
+binTuples ::
+  (Foldable t, Ord a) =>
+  t (a, b) ->
+  Map a (NE.NonEmpty b)
+binTuples = foldr f mempty
+ where
+  f = uncurry (M.insertWith (<>)) . fmap pure
+
 ------------------------------------------------------------
 -- Directory stuff