diff --git a/src/swarm-doc/Swarm/Doc/Gen.hs b/src/swarm-doc/Swarm/Doc/Gen.hs index 86572ed57..cf4136d99 100644 --- a/src/swarm-doc/Swarm/Doc/Gen.hs +++ b/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,7 +268,7 @@ 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. @@ -243,8 +276,8 @@ recipesToDot baseRobot classicTerm emap recipes = do -- 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" ] -- ---------------------------------------------------------------------------- diff --git a/swarm.cabal b/swarm.cabal index cea4bb1eb..148fadf94 100644 --- a/swarm.cabal +++ b/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 diff --git a/test/integration/Main.hs b/test/integration/Main.hs index 2c7d62e20..05cad46ed 100644 --- a/test/integration/Main.hs +++ b/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 diff --git a/test/integration/TestRecipeCoverage.hs b/test/integration/TestRecipeCoverage.hs new file mode 100644 index 000000000..4bf3dcce1 --- /dev/null +++ b/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) diff --git a/test/unit/Main.hs b/test/unit/Main.hs index 41f7e6222..d67f9d696 100644 --- a/test/unit/Main.hs +++ b/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 diff --git a/test/unit/TestRecipeCoverage.hs b/test/unit/TestRecipeCoverage.hs deleted file mode 100644 index c668a352f..000000000 --- a/test/unit/TestRecipeCoverage.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | --- SPDX-License-Identifier: BSD-3-Clause --- --- Ensure recipe coverage for all entities that --- grant capabilities (aka "devices"). -module TestRecipeCoverage where - -import Control.Lens ((^.)) -import Data.List.NonEmpty qualified as NE -import Data.Map qualified as M -import Data.Set qualified as Set -import Data.Text qualified as T -import Swarm.Game.Device -import Swarm.Game.Entity (EntityMap (entitiesByCap), entityName) -import Swarm.Game.Land -import Swarm.Game.Recipe (recipeOutputs) -import Swarm.Game.Scenario (GameStateInputs (..), initEntityTerrain) -import Swarm.Util (commaList, quote) -import Test.Tasty -import Test.Tasty.ExpectedFailure (expectFailBecause) -import Test.Tasty.HUnit - -testDeviceRecipeCoverage :: GameStateInputs -> TestTree -testDeviceRecipeCoverage gsi = - testGroup - "Recipe coverage" - [ expectFailBecause "Need to come up with more recipes" checkCoverage - ] - where - checkCoverage :: TestTree - checkCoverage = - testCase - "Ensure all devices have recipes (#1268)" - $ assertBool errMessage - $ null nonCoveredEntities - where - errMessage = - T.unpack $ - T.unwords - [ "Missing recipes for:" - , commaList $ map quote $ Set.toList nonCoveredEntities - ] - - -- Only include entities that grant a capability: - entityNames = - Set.fromList . map ((^. entityName) . device) . concatMap NE.toList . M.elems . getMap . entitiesByCap $ - initEntityTerrain (gsiScenarioInputs gsi) ^. entityMap - - getOutputsForRecipe r = map ((^. entityName) . snd) $ r ^. recipeOutputs - recipeOutputEntities = Set.fromList . concatMap getOutputsForRecipe $ gsiRecipes gsi - nonCoveredEntities = Set.difference entityNames recipeOutputEntities