From 7547adcfa682f342f81a2bf195c0c5e3a126d96f Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Fri, 27 Dec 2024 21:10:02 -0600 Subject: [PATCH 1/4] add test scenario for #2240 --- data/scenarios/Testing/00-ORDER.txt | 1 + .../2240-overridden-entity-capabilities.yaml | 49 +++++++++++++++++++ test/integration/Main.hs | 6 +++ 3 files changed, 56 insertions(+) create mode 100644 data/scenarios/Testing/2240-overridden-entity-capabilities.yaml diff --git a/data/scenarios/Testing/00-ORDER.txt b/data/scenarios/Testing/00-ORDER.txt index 5c9e4dc25..a7f60f0dd 100644 --- a/data/scenarios/Testing/00-ORDER.txt +++ b/data/scenarios/Testing/00-ORDER.txt @@ -71,3 +71,4 @@ Achievements 2085-toplevel-mask.yaml 2086-structure-palette.yaml 2239-custom-entity.yaml +2240-overridden-entity-capabilities.yaml diff --git a/data/scenarios/Testing/2240-overridden-entity-capabilities.yaml b/data/scenarios/Testing/2240-overridden-entity-capabilities.yaml new file mode 100644 index 000000000..06264912a --- /dev/null +++ b/data/scenarios/Testing/2240-overridden-entity-capabilities.yaml @@ -0,0 +1,49 @@ +version: 1 +name: Overridden entity capabilities +description: | + Overridden standard entity should not still be suggested for its + capabilities. The error message should suggest "- tank treads", not + "- treads or tank treads". +creative: false +objectives: + - goal: + - Place a rock + condition: | + as base { + isHere "rock" + }; +entities: + - name: treads + display: + char: '#' + attr: red + description: + - Broken treads + properties: [known, pickable] +robots: + - name: base + dir: east + devices: + - logger + - clock + - grabber + inventory: + - [1, rock] + - name: crasher + dir: east + devices: + - logger + - treads + program: | + move +solution: | + wait 5; place "rock" +world: + dsl: | + {grass} + palette: + 'C': [grass, null, crasher] + 'B': [grass, null, base] + upperleft: [0, 0] + map: | + BC diff --git a/test/integration/Main.hs b/test/integration/Main.hs index fd53247dd..26d8e1b6f 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -500,6 +500,12 @@ testScenarioSolutions rs ui key = assertEqual "Incorrect step count." 62 $ view lifetimeStepCount counters , expectFailBecause "Awaiting fix for #231" $ testSolution Default "Testing/231-requirements/231-command-transformer-reqs" + , testSolution Default "Testing/2239-custom-entity" + , testSolution' Default "Testing/2240-overridden-entity-capabilities" CheckForBadErrors $ \g -> do + let msgs = g ^.. robotInfo . robotMap . traverse . robotLog . to logToText . traverse + assertBool "Error message should mention tank treads but not treads" $ + not (any ("- treads" `T.isInfixOf`) msgs) + && (any ("- tank treads" `T.isInfixOf`) msgs) ] where -- expectFailIf :: Bool -> String -> TestTree -> TestTree From d81be842b357aba0ac41d0b39693bc23cf429a3c Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Fri, 27 Dec 2024 21:32:47 -0600 Subject: [PATCH 2/4] fix Semigroup EntityMap instance to update Capabilities map properly when there are overridden devices --- src/swarm-scenario/Swarm/Game/Entity.hs | 33 ++++++++++++++++++++----- 1 file changed, 27 insertions(+), 6 deletions(-) diff --git a/src/swarm-scenario/Swarm/Game/Entity.hs b/src/swarm-scenario/Swarm/Game/Entity.hs index 56dac3c57..3f57a2fc1 100644 --- a/src/swarm-scenario/Swarm/Game/Entity.hs +++ b/src/swarm-scenario/Swarm/Game/Entity.hs @@ -104,6 +104,7 @@ import Data.Char (toLower) import Data.Either.Extra (maybeToEither) import Data.Foldable (Foldable (..)) import Data.Function (on) +import Data.Functor.Identity import Data.Hashable import Data.IntMap (IntMap) import Data.IntMap qualified as IM @@ -429,16 +430,36 @@ data EntityMap = EntityMap -- Note that duplicates in a single 'EntityMap' are precluded by the -- 'buildEntityMap' function. But it is possible for the right-hand -- 'EntityMap' to override members of the left-hand with the same name. --- This replacement happens automatically with 'Map', but needs to --- be explicitly handled for the list concatenation of --- 'entityDefinitionOrder' (overridden entries are removed from the --- former 'EntityMap'). +-- For example, this is how custom entities defined in a scenario +-- can override standard entities. This replacement happens +-- automatically with 'Map' (as long as we keep in mind that Map +-- union is *left*-biased), but needs to be explicitly handled for the +-- list concatenation of 'entityDefinitionOrder' (overridden entries +-- are removed from the former 'EntityMap'), and for 'entitiesByCap', +-- which are organized by capability rather than by entity. instance Semigroup EntityMap where EntityMap n1 c1 d1 <> EntityMap n2 c2 d2 = EntityMap (n2 <> n1) - (c1 <> c2) - (filter ((`M.notMember` n2) . view entityName) d1 <> d2) + (removeOverriddenDevices c1 <> c2) + (filter notOverridden d1 <> d2) + where + notOverridden :: Entity -> Bool + notOverridden = (`M.notMember` n2) . view entityName + removeOverriddenDevices (Capabilities m) = + Capabilities + . runIdentity + -- traverseMaybeWithKey allows us in one operation to filter + -- the NonEmpty list of devices for each capability, turn the + -- resulting lists into Maybe NonEmpty, and then remove from + -- the map any that became Nothing. However, it is more + -- general than we need: it gives us access to the key which + -- we don't need (this explains the call to 'const'), and runs + -- in an arbitrary Applicative which we also don't need (this + -- explains the Identity). + . M.traverseMaybeWithKey + (const (Identity . NE.nonEmpty . NE.filter (notOverridden . device))) + $ m instance Monoid EntityMap where mempty = EntityMap M.empty mempty [] From 44a3fc914273bc111be71428173ab6975a575b20 Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Sat, 28 Dec 2024 10:18:44 -0600 Subject: [PATCH 3/4] remove redundant parens and apply style fix --- test/integration/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/integration/Main.hs b/test/integration/Main.hs index 26d8e1b6f..517f8a016 100644 --- a/test/integration/Main.hs +++ b/test/integration/Main.hs @@ -505,7 +505,7 @@ testScenarioSolutions rs ui key = let msgs = g ^.. robotInfo . robotMap . traverse . robotLog . to logToText . traverse assertBool "Error message should mention tank treads but not treads" $ not (any ("- treads" `T.isInfixOf`) msgs) - && (any ("- tank treads" `T.isInfixOf`) msgs) + && any ("- tank treads" `T.isInfixOf`) msgs ] where -- expectFailIf :: Bool -> String -> TestTree -> TestTree From ceb855e24fb6aa693b5ddc1e042e338825a63acc Mon Sep 17 00:00:00 2001 From: Brent Yorgey Date: Mon, 30 Dec 2024 19:59:26 -0600 Subject: [PATCH 4/4] simplify: use mapMaybe instead of traverseMaybeWithKey --- src/swarm-scenario/Swarm/Game/Entity.hs | 13 +------------ 1 file changed, 1 insertion(+), 12 deletions(-) diff --git a/src/swarm-scenario/Swarm/Game/Entity.hs b/src/swarm-scenario/Swarm/Game/Entity.hs index 3f57a2fc1..42d3f095c 100644 --- a/src/swarm-scenario/Swarm/Game/Entity.hs +++ b/src/swarm-scenario/Swarm/Game/Entity.hs @@ -104,7 +104,6 @@ import Data.Char (toLower) import Data.Either.Extra (maybeToEither) import Data.Foldable (Foldable (..)) import Data.Function (on) -import Data.Functor.Identity import Data.Hashable import Data.IntMap (IntMap) import Data.IntMap qualified as IM @@ -448,17 +447,7 @@ instance Semigroup EntityMap where notOverridden = (`M.notMember` n2) . view entityName removeOverriddenDevices (Capabilities m) = Capabilities - . runIdentity - -- traverseMaybeWithKey allows us in one operation to filter - -- the NonEmpty list of devices for each capability, turn the - -- resulting lists into Maybe NonEmpty, and then remove from - -- the map any that became Nothing. However, it is more - -- general than we need: it gives us access to the key which - -- we don't need (this explains the call to 'const'), and runs - -- in an arbitrary Applicative which we also don't need (this - -- explains the Identity). - . M.traverseMaybeWithKey - (const (Identity . NE.nonEmpty . NE.filter (notOverridden . device))) + . M.mapMaybe (NE.nonEmpty . NE.filter (notOverridden . device)) $ m instance Monoid EntityMap where