Merge branch 'main' into refactor/extract-more-recognizer-logic

src/swarm-doc/Swarm/Doc/Gen.hs

@@ -14,6 +14,11 @@ module Swarm.Doc.Gen (
 
   -- ** Wiki pages
   PageAddress (..),
+
+  -- ** Recipe graph data
+  RecipeGraphData (..),
+  classicScenarioRecipeGraphData,
+  ignoredEntities,
 ) where
 
 import Control.Lens (view, (^.))
@@ -42,7 +47,7 @@ import Swarm.Game.Recipe (Recipe, recipeCatalysts, recipeInputs, recipeOutputs)
 import Swarm.Game.Robot (Robot, equippedDevices, robotInventory)
 import Swarm.Game.Scenario (GameStateInputs (..), ScenarioInputs (..), loadStandaloneScenario, scenarioLandscape)
 import Swarm.Game.World.Gen (extractEntities)
-import Swarm.Game.World.Typecheck (Some (..), TTerm)
+import Swarm.Game.World.Typecheck (Some (..))
 import Swarm.Language.Key (specialKeyNames)
 import Swarm.Util (both)
 import Text.Dot (Dot, NodeId, (.->.))
@@ -135,47 +140,47 @@ generateSpecialKeyNames =
 -- ----------------------------------------------------------------------------
 
 generateRecipe :: IO String
-generateRecipe = simpleErrorHandle $ do
-  (classic, GameStateInputs (ScenarioInputs worlds (TerrainEntityMaps _ entities)) recipes) <- loadStandaloneScenario "data/scenarios/classic.yaml"
-  baseRobot <- instantiateBaseRobot $ classic ^. scenarioLandscape
-  return . Dot.showDot $ recipesToDot baseRobot (worlds ! "classic") entities recipes
+generateRecipe = do
+  graphData <- classicScenarioRecipeGraphData
+  return . Dot.showDot $ recipesToDot graphData
 
-recipesToDot :: Robot -> Some (TTerm '[]) -> EntityMap -> [Recipe Entity] -> Dot ()
-recipesToDot baseRobot classicTerm emap recipes = do
+recipesToDot :: RecipeGraphData -> Dot ()
+recipesToDot graphData = do
   Dot.attribute ("rankdir", "LR")
   Dot.attribute ("ranksep", "2")
   world <- diamond "World"
   base <- diamond "Base"
   -- --------------------------------------------------------------------------
   -- add nodes with for all the known entities
-  let enames' = toList . Map.keysSet . entitiesByName $ emap
+  let enames' = map (view entityName) . toList $ rgAllEntities graphData
       enames = filter (`Set.notMember` ignoredEntities) enames'
   ebmap <- Map.fromList . zip enames <$> mapM (box . unpack) enames
   -- --------------------------------------------------------------------------
   -- getters for the NodeId based on entity name or the whole entity
-  let safeGetEntity m e = fromMaybe (error $ unpack e <> " is not an entity!?") $ m Map.!? e
+  let safeGetEntity m e = fromMaybe (error $ show e <> " is not an entity!?") $ m Map.!? e
       getE = safeGetEntity ebmap
       nid = getE . view entityName
   -- --------------------------------------------------------------------------
   -- Get the starting inventories, entities present in the world and compute
   -- how hard each entity is to get - see 'recipeLevels'.
-  let devs = startingDevices baseRobot
-      inv = startingInventory baseRobot
-      worldEntities = case classicTerm of Some _ t -> extractEntities t
-      levels = recipeLevels recipes (Set.unions [worldEntities, devs])
+  let devs = rgStartingDevices graphData
+      inv = rgStartingInventory graphData
+      worldEntities = rgWorldEntities graphData
+      levels = rgLevels graphData
+      recipes = rgRecipes graphData
   -- --------------------------------------------------------------------------
   -- Base inventory
   (_bc, ()) <- Dot.cluster $ do
     Dot.attribute ("style", "filled")
     Dot.attribute ("color", "lightgrey")
     mapM_ ((base ---<>) . nid) devs
-    mapM_ ((base .->.) . nid . fst) $ Map.toList inv
+    mapM_ ((base .->.) . nid) inv
   -- --------------------------------------------------------------------------
   -- World entities
   (_wc, ()) <- Dot.cluster $ do
     Dot.attribute ("style", "filled")
     Dot.attribute ("color", "forestgreen")
-    mapM_ (uncurry (Dot..->.) . (world,) . getE . view entityName) (toList worldEntities)
+    mapM_ (uncurry (Dot..->.) . (world,) . nid) worldEntities
   -- --------------------------------------------------------------------------
   let -- put a hidden node above and below entities and connect them by hidden edges
       wrapBelowAbove :: Set Entity -> Dot (NodeId, NodeId)
@@ -224,9 +229,37 @@ recipesToDot baseRobot classicTerm emap recipes = do
   mapM_ (uncurry (---<>)) (recipesToPairs recipeReqOut recipes)
   -- --------------------------------------------------------------------------
   -- also draw an edge for each entity that "yields" another entity
-  let yieldPairs = mapMaybe (\e -> (e ^. entityName,) <$> (e ^. entityYields)) . Map.elems $ entitiesByName emap
+  let yieldPairs = mapMaybe (\e -> (e ^. entityName,) <$> (e ^. entityYields)) . toList $ rgAllEntities graphData
   mapM_ (uncurry (.->.)) (both getE <$> yieldPairs)
 
+data RecipeGraphData = RecipeGraphData
+  { rgWorldEntities :: Set Entity
+  , rgStartingDevices :: Set Entity
+  , rgStartingInventory :: Set Entity
+  , rgLevels :: [Set Entity]
+  , rgAllEntities :: Set Entity
+  , rgRecipes :: [Recipe Entity]
+  }
+
+classicScenarioRecipeGraphData :: IO RecipeGraphData
+classicScenarioRecipeGraphData = simpleErrorHandle $ do
+  (classic, GameStateInputs (ScenarioInputs worlds (TerrainEntityMaps _ emap)) recipes) <-
+    loadStandaloneScenario "data/scenarios/classic.yaml"
+  baseRobot <- instantiateBaseRobot (classic ^. scenarioLandscape)
+  let classicTerm = worlds ! "classic"
+  let devs = startingDevices baseRobot
+  let inv = Map.keysSet $ startingInventory baseRobot
+  let worldEntities = case classicTerm of Some _ t -> extractEntities t
+  return
+    RecipeGraphData
+      { rgStartingDevices = devs
+      , rgStartingInventory = inv
+      , rgWorldEntities = worldEntities
+      , rgLevels = recipeLevels emap recipes (Set.unions [worldEntities, devs, inv])
+      , rgAllEntities = Set.fromList . Map.elems $ entitiesByName emap
+      , rgRecipes = recipes
+      }
+
 -- ----------------------------------------------------------------------------
 -- RECIPE LEVELS
 -- ----------------------------------------------------------------------------
@@ -235,16 +268,16 @@ recipesToDot baseRobot classicTerm emap recipes = do
 --
 -- So:
 --  * Level 0 - starting entities (for example those obtainable in the world)
---  * Level N+1 - everything possible to make (or drill) from Level N
+--  * Level N+1 - everything possible to make (or drill or harvest) from Level N
 --
 -- This is almost a BFS, but the requirement is that the set of entities
 -- required for recipe is subset of the entities known in Level N.
 --
 -- If we ever depend on some graph library, this could be rewritten
 -- as some BFS-like algorithm with added recipe nodes, but you would
 -- need to enforce the condition that recipes need ALL incoming edges.
-recipeLevels :: [Recipe Entity] -> Set Entity -> [Set Entity]
-recipeLevels recipes start = levels
+recipeLevels :: EntityMap -> [Recipe Entity] -> Set Entity -> [Set Entity]
+recipeLevels emap recipes start = levels
  where
   recipeParts r = ((r ^. recipeInputs) <> (r ^. recipeCatalysts), r ^. recipeOutputs)
   m :: [(Set Entity, Set Entity)]
@@ -253,7 +286,13 @@ recipeLevels recipes start = levels
   levels = reverse $ go [start] start
    where
     isKnown known (i, _o) = null $ i Set.\\ known
-    nextLevel known = Set.unions . map snd $ filter (isKnown known) m
+    lookupYield e = case view entityYields e of
+      Nothing -> e
+      Just yn -> case E.lookupEntityName yn emap of
+        Nothing -> error "unknown yielded entity"
+        Just ye -> ye
+    yielded = Set.map lookupYield
+    nextLevel known = Set.unions $ yielded known : map snd (filter (isKnown known) m)
     go ls known =
       let n = nextLevel known Set.\\ known
        in if null n
@@ -276,6 +315,10 @@ ignoredEntities =
     , "lower right corner"
     , "horizontal wall"
     , "vertical wall"
+    , "left and vertical wall"
+    , "up and horizontal wall"
+    , "right and vertical wall"
+    , "down and horizontal wall"
     ]
 
 -- ----------------------------------------------------------------------------

swarm.cabal

@@ -858,7 +858,6 @@ test-suite swarm-unit
     TestParse
     TestPedagogy
     TestPretty
-    TestRecipeCoverage
     TestRepl
     TestRequirements
     TestScoring
@@ -878,7 +877,6 @@ test-suite swarm-unit
     megaparsec,
     mtl,
     tasty >=0.10 && <1.6,
-    tasty-expected-failure >=0.12 && <0.13,
     tasty-hunit >=0.10 && <0.11,
     tasty-quickcheck >=0.10 && <0.11,
     text,
@@ -902,6 +900,7 @@ test-suite swarm-unit
 test-suite swarm-integration
   import: stan-config, common, ghc2021-extensions
   main-is: Main.hs
+  other-modules: TestRecipeCoverage
   type: exitcode-stdio-1.0
   build-depends:
     -- Imports shared with the library don't need bounds

test/integration/Main.hs

@@ -85,6 +85,7 @@ import System.Timeout (timeout)
 import Test.Tasty (TestTree, defaultMain, testGroup)
 import Test.Tasty.ExpectedFailure (expectFailBecause)
 import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase)
+import TestRecipeCoverage
 import Witch (into)
 
 isUnparseableTest :: FilePath -> Bool
@@ -101,6 +102,7 @@ main = do
     either (assertFailure . prettyString) return out
   let scenarioInputs = gsiScenarioInputs $ initState $ rs ^. stdGameConfigInputs
       rs' = rs & eventLog .~ mempty
+  recipeTests <- testRecipeCoverage
   defaultMain $
     testGroup
       "Tests"
@@ -111,6 +113,7 @@ main = do
       , scenarioParseInvalidTests scenarioInputs unparseableScenarios
       , testScenarioSolutions rs' ui key
       , testEditorFiles
+      , recipeTests
       ]
 
 testNoLoadingErrors :: RuntimeState -> TestTree

test/integration/TestRecipeCoverage.hs

@@ -0,0 +1,68 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- Ensure recipe coverage for all entities.
+module TestRecipeCoverage (testRecipeCoverage) where
+
+import Control.Lens (view)
+import Data.List qualified as List
+import Data.Set qualified as Set
+import Data.Text qualified as T
+import Swarm.Doc.Gen
+import Swarm.Game.Entity (Entity, EntityName, entityName)
+import Swarm.Util (quote)
+import Test.Tasty
+import Test.Tasty.ExpectedFailure (expectFailBecause)
+import Test.Tasty.HUnit
+
+-- | Generate test tree to check that each entity either has a reachable
+--   recipe or is in the world or starting base robot inventory.
+--
+-- If you added a recipe, thank you, please remove the entity from the list
+-- of known uncraftable entities.
+-- If you are not sure why an entity with a recipe is unreachable, check out
+-- the dot graph of entity recipes in 'Swarm.Doc.Gen' that this test uses.
+testRecipeCoverage :: IO TestTree
+testRecipeCoverage = do
+  graphData <- classicScenarioRecipeGraphData
+  let sortE = List.sortOn (T.unpack . view entityName)
+      allEntities = sortE . Set.toList $ rgAllEntities graphData
+      nonCovered = getNonCoveredEntities graphData
+  return . testGroup "Ensure all entities have recipes" $
+    map (\e -> expectNonCovered e $ checkCoverage nonCovered e) allEntities
+ where
+  checkCoverage :: Set.Set Entity -> Entity -> TestTree
+  checkCoverage s e =
+    let name = view entityName e
+     in testCase (T.unpack name) $ do
+          assertBool (errMessage name) (name `elem` ignoredEntities || e `Set.notMember` s)
+   where
+    errMessage missing = T.unpack $ "Can not make " <> quote missing <> " from starting entities."
+
+expectNonCovered :: Entity -> TestTree -> TestTree
+expectNonCovered e =
+  let name = T.toCaseFold (view entityName e)
+   in if name `elem` nonCoveredList
+        then expectFailBecause "More recipes needed (#1268)"
+        else id
+
+-- | Known non-covered entities that need a recipe.
+nonCoveredList :: [EntityName]
+nonCoveredList =
+  map
+    T.toCaseFold
+    [ "Elmer's glue"
+    , "ash"
+    , "binoculars"
+    , "blueprint"
+    , "caliper"
+    , "decoder ring"
+    , "linotype"
+    , "tape drive"
+    , "wedge"
+    ]
+
+getNonCoveredEntities :: RecipeGraphData -> Set.Set Entity
+getNonCoveredEntities graphData = rgAllEntities graphData `Set.difference` Set.unions (rgLevels graphData)

test/unit/Main.hs

@@ -13,8 +13,6 @@ import Control.Monad.Except (runExceptT)
 import Data.List (subsequences)
 import Data.Set (Set)
 import Data.Set qualified as S
-import Swarm.Game.State.Runtime (stdGameConfigInputs)
-import Swarm.Game.State.Substate (initState)
 import Swarm.TUI.Model (AppState, gameState, runtimeState)
 import Swarm.TUI.Model.StateUpdate (classicGame0)
 import Swarm.Util (removeSupersets, smallHittingSet)
@@ -40,7 +38,6 @@ import TestOverlay (testOverlay)
 import TestParse (testParse)
 import TestPedagogy (testPedagogy)
 import TestPretty (testPrettyConst)
-import TestRecipeCoverage (testDeviceRecipeCoverage)
 import TestRepl (testRepl)
 import TestRequirements (testRequirements)
 import TestScoring (testHighScores)
@@ -62,7 +59,6 @@ tests s =
     , testPrettyConst
     , testBoolExpr
     , testCommands
-    , testDeviceRecipeCoverage (initState $ s ^. runtimeState . stdGameConfigInputs)
     , testHighScores
     , testEval (s ^. gameState)
     , testRepl