Add available commands help (#458)

This change adds a new help panel with the list of recently acquired commands. The panels currently shows `command name :: command type signature`, for each newly available command.

Fixes #436

Author: TristanCacqueray

src/Swarm/Game/State.hs

@@ -37,7 +37,7 @@ module Swarm.Game.State (
   robotsByLocation,
   activeRobots,
   availableRecipes,
-  availableRecipesNewCount,
+  availableCommands,
   allDiscoveredEntities,
   gensym,
   randGen,
@@ -57,6 +57,11 @@ module Swarm.Game.State (
   focusedRobotID,
   ticks,
 
+  -- ** Notifications
+  Notifications (..),
+  notificationsCount,
+  notificationsContent,
+
   -- ** GameState initialization
   initGameState,
   scenarioToGameState,
@@ -82,7 +87,7 @@ module Swarm.Game.State (
 
 import Control.Applicative ((<|>))
 import Control.Arrow (Arrow ((&&&)))
-import Control.Lens hiding (use, uses, view, (%=), (+=), (.=), (<+=), (<<.=))
+import Control.Lens hiding (Const, use, uses, view, (%=), (+=), (.=), (<+=), (<<.=))
 import Control.Monad.Except
 import Data.Array (Array, listArray)
 import Data.Int (Int64)
@@ -95,6 +100,7 @@ import Data.List (partition)
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.Maybe (fromMaybe)
+import qualified Data.Set as S
 import Data.Text (Text)
 import qualified Data.Text as T (lines)
 import qualified Data.Text.IO as T (readFile)
@@ -115,10 +121,11 @@ import Swarm.Game.Scenario
 import Swarm.Game.Value
 import qualified Swarm.Game.World as W
 import Swarm.Game.WorldGen (Seed)
+import Swarm.Language.Capability (constCaps)
 import qualified Swarm.Language.Context as Ctx
 import Swarm.Language.Pipeline (ProcessedTerm)
 import Swarm.Language.Pipeline.QQ (tmQ)
-import Swarm.Language.Syntax (Term (TString))
+import Swarm.Language.Syntax (Const, Term (TString), allConst)
 import Swarm.Language.Types
 import Swarm.Util
 
@@ -172,6 +179,21 @@ data RunStatus
     AutoPause
   deriving (Eq, Show)
 
+-- | A data type to keep track of discovered recipes and commands
+data Notifications a = Notifications
+  { _notificationsCount :: Int
+  , _notificationsContent :: [a]
+  }
+  deriving (Eq, Show)
+
+instance Semigroup (Notifications a) where
+  Notifications count1 xs1 <> Notifications count2 xs2 = Notifications (count1 + count2) (xs1 <> xs2)
+
+instance Monoid (Notifications a) where
+  mempty = Notifications 0 []
+
+makeLenses ''Notifications
+
 ------------------------------------------------------------
 -- The main GameState record type
 ------------------------------------------------------------
@@ -201,8 +223,8 @@ data GameState = GameState
     _waitingRobots :: Map Integer [RID]
   , _robotsByLocation :: Map (V2 Int64) IntSet
   , _allDiscoveredEntities :: Inventory
-  , _availableRecipes :: [Recipe Entity]
-  , _availableRecipesNewCount :: Int
+  , _availableRecipes :: Notifications (Recipe Entity)
+  , _availableCommands :: Notifications Const
   , _gensym :: Int
   , _randGen :: StdGen
   , _adjList :: Array Int Text
@@ -273,10 +295,10 @@ robotsByLocation :: Lens' GameState (Map (V2 Int64) IntSet)
 allDiscoveredEntities :: Lens' GameState Inventory
 
 -- | The list of available recipes.
-availableRecipes :: Lens' GameState [Recipe Entity]
+availableRecipes :: Lens' GameState (Notifications (Recipe Entity))
 
--- | The number of new recipes (reset to 0 when the player open the recipes view).
-availableRecipesNewCount :: Lens' GameState Int
+-- | The list of available commands.
+availableCommands :: Lens' GameState (Notifications Const)
 
 -- | The names of the robots that are currently not sleeping.
 activeRobots :: Getter GameState IntSet
@@ -528,7 +550,7 @@ initGameState = do
       , _robotMap = IM.empty
       , _robotsByLocation = M.empty
       , _availableRecipes = mempty
-      , _availableRecipesNewCount = 0
+      , _availableCommands = mempty
       , _allDiscoveredEntities = empty
       , _activeRobots = IS.empty
       , _waitingRobots = M.empty
@@ -572,6 +594,7 @@ scenarioToGameState scenario userSeed toRun g = do
           M.fromListWith IS.union $
             map (view robotLocation &&& (IS.singleton . view robotID)) robotList
       , _activeRobots = setOf (traverse . robotID) robotList
+      , _availableCommands = Notifications 0 initialCommands
       , _waitingRobots = M.empty
       , _gensym = initGensym
       , _randGen = mkStdGen seed
@@ -609,6 +632,12 @@ scenarioToGameState scenario userSeed toRun g = do
           False -> id
           True -> const (fromList devices)
 
+  initialCaps = mconcat $ map (^. robotCapabilities) robotList
+  initialCommands =
+    filter
+      (maybe False (`S.member` initialCaps) . constCaps)
+      allConst
+
   theWorld = W.newWorld . (scenario ^. scenarioWorld)
   theWinCondition = maybe NoWinCondition WinCondition (scenario ^. scenarioWin)
   initGensym = length robotList - 1

src/Swarm/Game/Step.hs

@@ -276,13 +276,15 @@ traceLogShow = traceLog . from . show
 --   (either because it has a device which gives it that capability,
 --   or it is a system robot, or we are in creative mode).
 ensureCanExecute :: (Has (State Robot) sig m, Has (State GameState) sig m, Has (Throw Exn) sig m) => Const -> m ()
-ensureCanExecute c = do
-  creative <- use creativeMode
-  sys <- use systemRobot
-  robotCaps <- use robotCapabilities
-  let missingCaps = constCaps c `S.difference` robotCaps
-  (sys || creative || S.null missingCaps)
-    `holdsOr` Incapable FixByInstall missingCaps (TConst c)
+ensureCanExecute c = case constCaps c of
+  Nothing -> pure ()
+  Just cap -> do
+    creative <- use creativeMode
+    sys <- use systemRobot
+    robotCaps <- use robotCapabilities
+    let hasCaps = cap `S.member` robotCaps
+    (sys || creative || hasCaps)
+      `holdsOr` Incapable FixByInstall (S.singleton cap) (TConst c)
 
 -- | Test whether the current robot has a given capability (either
 --   because it has a device which gives it that capability, or it is a
@@ -1660,6 +1662,7 @@ updateDiscoveredEntities e = do
     else do
       let newAllDiscovered = E.insertCount 1 e allDiscovered
       updateAvailableRecipes (newAllDiscovered, newAllDiscovered) e
+      updateAvailableCommands e
       allDiscoveredEntities .= newAllDiscovered
 
 -- | Update the availableRecipes list.
@@ -1675,8 +1678,20 @@ updateAvailableRecipes invs e = do
   allInRecipes <- use recipesIn
   let entityRecipes = recipesFor allInRecipes e
       usableRecipes = filter (knowsIngredientsFor invs) entityRecipes
-  knownRecipes <- use availableRecipes
+  knownRecipes <- use (availableRecipes . notificationsContent)
   let newRecipes = filter (`notElem` knownRecipes) usableRecipes
       newCount = length newRecipes
-  availableRecipes .= newRecipes <> knownRecipes
-  availableRecipesNewCount += newCount
+  availableRecipes %= mappend (Notifications newCount newRecipes)
+  updateAvailableCommands e
+
+updateAvailableCommands :: Has (State GameState) sig m => Entity -> m ()
+updateAvailableCommands e = do
+  let newCaps = S.fromList (e ^. entityCapabilities)
+      keepConsts = \case
+        Just cap -> cap `S.member` newCaps
+        Nothing -> False
+      entityConsts = filter (keepConsts . constCaps) allConst
+  knownCommands <- use (availableCommands . notificationsContent)
+  let newCommands = filter (`notElem` knownCommands) entityConsts
+      newCount = length newCommands
+  availableCommands %= mappend (Notifications newCount newCommands)

src/Swarm/Language/Capability.hs

@@ -202,7 +202,7 @@ requiredCaps' = go
     TBool _ -> S.empty
     -- Look up the capabilities required by a function/command
     -- constants using 'constCaps'.
-    TConst c -> constCaps c
+    TConst c -> maybe S.empty S.singleton (constCaps c)
     -- Note that a variable might not show up in the context, and
     -- that's OK.  In particular, only variables bound by 'TDef' go
     -- in the context; variables bound by a lambda or let will not
@@ -250,85 +250,84 @@ requiredCaps' = go
     TDef {} -> S.empty
 
 -- | Capabilities needed to evaluate or execute a constant.
-constCaps :: Const -> Set Capability
-constCaps =
-  S.fromList . \case
-    -- Some built-in constants that don't require any special capability.
-    Wait -> []
-    Noop -> []
-    AppF -> []
-    Force -> []
-    Return -> []
-    Parent -> []
-    Base -> []
-    Setname -> []
-    Undefined -> []
-    Fail -> []
-    -- Some straightforward ones.
-    Log -> [CLog]
-    Selfdestruct -> [CSelfdestruct]
-    Move -> [CMove]
-    Turn -> [CTurn]
-    Grab -> [CGrab]
-    Place -> [CPlace]
-    Give -> [CGive]
-    Install -> [CInstall]
-    Make -> [CMake]
-    Has -> []
-    Count -> [CCount]
-    If -> [CCond]
-    Blocked -> [CSensefront]
-    Scan -> [CScan]
-    Ishere -> [CSensehere]
-    Upload -> [CScan]
-    Build -> [CBuild]
-    Salvage -> [CSalvage]
-    Reprogram -> [CReprogram]
-    Drill -> [CDrill]
-    Neg -> [CArith]
-    Add -> [CArith]
-    Sub -> [CArith]
-    Mul -> [CArith]
-    Div -> [CArith]
-    Exp -> [CArith]
-    Whoami -> [CWhoami]
-    Self -> [CWhoami]
-    -- Some God-like abilities.
-    As -> [CGod]
-    RobotNamed -> [CGod]
-    RobotNumbered -> [CGod]
-    Create -> [CGod]
-    -- String operations, which for now are enabled by CLog
-    Format -> [CLog]
-    Concat -> [CLog]
-    -- Some additional straightforward ones, which however currently
-    -- cannot be used in classic mode since there is no craftable item
-    -- which conveys their capability.
-    Teleport -> [CTeleport] -- Some space-time machine like Tardis?
-    Appear -> [CAppear] -- paint?
-    Whereami -> [CSenseloc] -- GPS?
-    Random -> [CRandom] -- randomness device (with bitcoins)?
+constCaps :: Const -> Maybe Capability
+constCaps = \case
+  -- Some built-in constants that don't require any special capability.
+  Wait -> Nothing
+  Noop -> Nothing
+  AppF -> Nothing
+  Force -> Nothing
+  Return -> Nothing
+  Parent -> Nothing
+  Base -> Nothing
+  Setname -> Nothing
+  Undefined -> Nothing
+  Fail -> Nothing
+  -- Some straightforward ones.
+  Log -> Just CLog
+  Selfdestruct -> Just CSelfdestruct
+  Move -> Just CMove
+  Turn -> Just CTurn
+  Grab -> Just CGrab
+  Place -> Just CPlace
+  Give -> Just CGive
+  Install -> Just CInstall
+  Make -> Just CMake
+  Has -> Nothing
+  Count -> Just CCount
+  If -> Just CCond
+  Blocked -> Just CSensefront
+  Scan -> Just CScan
+  Ishere -> Just CSensehere
+  Upload -> Just CScan
+  Build -> Just CBuild
+  Salvage -> Just CSalvage
+  Reprogram -> Just CReprogram
+  Drill -> Just CDrill
+  Neg -> Just CArith
+  Add -> Just CArith
+  Sub -> Just CArith
+  Mul -> Just CArith
+  Div -> Just CArith
+  Exp -> Just CArith
+  Whoami -> Just CWhoami
+  Self -> Just CWhoami
+  -- Some God-like abilities.
+  As -> Just CGod
+  RobotNamed -> Just CGod
+  RobotNumbered -> Just CGod
+  Create -> Just CGod
+  -- String operations, which for now are enabled by CLog
+  Format -> Just CLog
+  Concat -> Just CLog
+  -- Some additional straightforward ones, which however currently
+  -- cannot be used in classic mode since there is no craftable item
+  -- which conveys their capability.
+  Teleport -> Just CTeleport -- Some space-time machine like Tardis?
+  Appear -> Just CAppear -- paint?
+  Whereami -> Just CSenseloc -- GPS?
+  Random -> Just CRandom -- randomness device (with bitcoins)?
 
-    -- comparator?
-    Eq -> [CCompare]
-    Neq -> [CCompare]
-    Lt -> [CCompare]
-    Gt -> [CCompare]
-    Leq -> [CCompare]
-    Geq -> [CCompare]
-    And -> []
-    Or -> []
-    -- Some more constants which *ought* to have their own capability but
-    -- currently don't.
-    Say -> []
-    View -> [] -- XXX this should also require something.
-    Run -> [] -- XXX this should also require a capability
-    -- which the base starts out with.
-    Not -> [] -- XXX some kind of boolean logic cap?
-    Inl -> [] -- XXX should require cap for sums
-    Inr -> []
-    Case -> []
-    Fst -> [] -- XXX should require cap for pairs
-    Snd -> []
-    Try -> [] -- XXX these definitely need to require something.
-    Knows -> []
+  -- comparator?
+  Eq -> Just CCompare
+  Neq -> Just CCompare
+  Lt -> Just CCompare
+  Gt -> Just CCompare
+  Leq -> Just CCompare
+  Geq -> Just CCompare
+  And -> Nothing
+  Or -> Nothing
+  -- Some more constants which *ought* to have their own capability but
+  -- currently don't.
+  Say -> Nothing
+  View -> Nothing -- XXX this should also require something.
+  Run -> Nothing -- XXX this should also require a capability
+  -- which the base starts out with.
+  Not -> Nothing -- XXX some kind of boolean logic cap?
+  Inl -> Nothing -- XXX should require cap for sums
+  Inr -> Nothing
+  Case -> Nothing
+  Fst -> Nothing -- XXX should require cap for pairs
+  Snd -> Nothing
+  Try -> Nothing -- XXX these definitely need to require something.
+  Knows -> Nothing

src/Swarm/TUI/Controller.hs

@@ -193,9 +193,12 @@ handleMainEvent s = \case
     | isJust (s ^. uiState . uiError) -> continue $ s & uiState . uiError .~ Nothing
     | isJust (s ^. uiState . uiModal) -> maybeUnpause s >>= (continue . (uiState . uiModal .~ Nothing))
   FKey 1 -> toggleModal s HelpModal >>= continue
-  FKey 2 | not (null (s ^. gameState . availableRecipes)) -> do
+  FKey 2 | not (null (s ^. gameState . availableRecipes . notificationsContent)) -> do
     s' <- toggleModal s RecipesModal
-    continue (s' & gameState . availableRecipesNewCount .~ 0)
+    continue (s' & gameState . availableRecipes . notificationsCount .~ 0)
+  FKey 3 | not (null (s ^. gameState . availableCommands . notificationsContent)) -> do
+    s' <- toggleModal s CommandsModal
+    continue (s' & gameState . availableCommands . notificationsCount .~ 0)
   ControlKey 'g' -> case s ^. uiState . uiGoal of
     NoGoal -> continueWithoutRedraw s
     UnreadGoal g -> toggleModal s (GoalModal g) >>= continue
@@ -295,6 +298,7 @@ handleModalEvent s = \case
     s' <- s & uiState . uiModal . _Just . modalDialog %%~ handleDialogEvent ev
     case s ^? uiState . uiModal . _Just . modalType of
       Just RecipesModal -> handleInfoPanelEvent s' recipesScroll (VtyEvent ev)
+      Just CommandsModal -> handleInfoPanelEvent s' commandsScroll (VtyEvent ev)
       _ -> continue s'
 
 -- | Quit a game.  Currently all it does is write out the updated REPL