Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Fix capability checking, and refactor/add lots of comments #959

Merged
merged 7 commits into from
Jan 5, 2023
Merged
Show file tree
Hide file tree
Changes from all commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions data/scenarios/Testing/00-ORDER.txt
Original file line number Diff line number Diff line change
Expand Up @@ -17,3 +17,4 @@
710-multi-robot.yaml
920-meet.yaml
955-heading.yaml
397-wrong-missing.yaml
38 changes: 38 additions & 0 deletions data/scenarios/Testing/397-wrong-missing.yaml
Original file line number Diff line number Diff line change
@@ -0,0 +1,38 @@
version: 1
name: Test issue 397 (wrong device reported missing)
description: |
A scenario designed to trigger issue 397, where in certain
situations involving a capability with no candidate devices,
an incorrect error message was generated reporting some other
device to be missing.
https://github.com/swarm-game/swarm/issues/397
objectives:
- condition: |
t <- time; return (t == 2)
goal:
- |
This is a dummy condition that just ensures the base has had
time to run the problematic `build` command. The scenario
*should* generate an error message; what we really care about is
whether the generated error message is correct, which is checked
in test/integration/Main.hs .
solution: |
build {move; turn right; loc <- whereami}
robots:
- name: base
dir: [0,1]
devices:
- 3D printer
- logger
inventory:
- [1, treads]
- [1, solar panel]
world:
default: [blank]
palette:
'Ω': [grass, null, base]
'.': [grass]
upperleft: [0,1]
map: |
.
Ω
103 changes: 64 additions & 39 deletions src/Swarm/Game/Step.hs
Original file line number Diff line number Diff line change
Expand Up @@ -18,19 +18,19 @@
module Swarm.Game.Step where

import Control.Applicative (liftA2)
import Control.Arrow ((&&&))
import Control.Carrier.Error.Either (runError)
import Control.Carrier.State.Lazy
import Control.Carrier.Throw.Either (ThrowC, runThrow)
import Control.Effect.Error
import Control.Effect.Lens
import Control.Effect.Lift
import Control.Lens as Lens hiding (Const, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=))
import Control.Lens as Lens hiding (Const, distrib, from, parts, use, uses, view, (%=), (+=), (.=), (<+=), (<>=))
import Control.Monad (forM, forM_, guard, msum, unless, when)
import Data.Array (bounds, (!))
import Data.Bifunctor (second)
import Data.Bool (bool)
import Data.Char (chr, ord)
import Data.Containers.ListUtils (nubOrd)
import Data.Either (partitionEithers, rights)
import Data.Foldable (asum, traverse_)
import Data.Functor (void)
Expand All @@ -41,7 +41,7 @@ import Data.List qualified as L
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe)
import Data.Maybe (catMaybes, fromMaybe, isJust, isNothing, listToMaybe, mapMaybe)
import Data.Ord (Down (Down))
import Data.Sequence qualified as Seq
import Data.Set (Set)
Expand Down Expand Up @@ -1712,65 +1712,85 @@ execConst c vs s k = do
-- See #349
(R.Requirements (S.toList -> caps) (S.toList -> devNames) reqInvNames, _capCtx) = R.requirements currentContext cmd

-- Check that all required device names exist, and fail with
-- an exception if not
devs <- forM devNames $ \devName ->
-- Check that all required device names exist (fail with
-- an exception if not) and convert them to 'Entity' values.
(devs :: [Entity]) <- forM devNames $ \devName ->
E.lookupEntityName devName em `isJustOrFail` ["Unknown device required: " <> devName]

-- Check that all required inventory entity names exist, and fail
-- with an exception if not
reqElems <- forM (M.assocs reqInvNames) $ \(eName, n) ->
-- Check that all required inventory entity names exist (fail with
-- an exception if not) and convert them to 'Entity' values, with
-- an associated count for each.
(reqInv :: Inventory) <- fmap E.fromElems . forM (M.assocs reqInvNames) $ \(eName, n) ->
(n,)
<$> ( E.lookupEntityName eName em
`isJustOrFail` ["Unknown entity required: " <> eName]
)
let reqInv = E.fromElems reqElems

let -- List of possible devices per requirement. Devices for
-- required capabilities come first, then singleton devices
-- that are required directly. This order is important since
-- later we zip required capabilities with this list to figure
-- out which capabilities are missing.
capDevices = map (`deviceForCap` em) caps ++ map (: []) devs
let -- List of possible devices per requirement. For the
-- requirements that stem from a required capability, we
-- remember the capability alongside the possible devices, to
-- help with later error message generation.
possibleDevices :: [(Maybe Capability, [Entity])]
possibleDevices =
map (Just &&& (`deviceForCap` em)) caps -- Possible devices for capabilities
++ map ((Nothing,) . (: [])) devs -- Outright required devices

-- A device is OK if it is available in the inventory of the
-- parent robot, or already installed in the child robot.
deviceOK :: Entity -> Bool
deviceOK d = parentInventory `E.contains` d || childDevices `E.contains` d

-- take a pair of device sets providing capabilities that is
-- split into (AVAIL,MISSING) and if there are some available
-- ignore missing because we only need them for error message
ignoreOK ([], miss) = ([], miss)
ignoreOK (ds, _miss) = (ds, [])

(deviceSets, missingDeviceSets) =
Lens.over both (nubOrd . map S.fromList) . unzip $
Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The bug was in the fact that we did a nubOrd here --- which could change the length of the list...

map (ignoreOK . L.partition deviceOK) capDevices

formatDevices = T.intercalate " or " . map (^. entityName) . S.toList
-- capabilities not provided by any device in inventory
missingCaps = S.fromList . map fst . filter (null . snd) $ zip caps deviceSets
Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

... but here we zipped that possibly-shorter list with caps, which started out having the same length. But with repeated things that got nubbed away, the two lists were no longer aligned, which sometimes caused the wrong devices to be suggested for an unrelated missing capability.


-- Partition each list of possible devices into a set of
-- available devices and a set of unavailable devices.
-- There's a problem if some capability is required but no
-- devices that provide it are available. In that case we can
-- print an error message, using the second set as a list of
-- suggestions.
partitionedDevices :: [(Set Entity, Set Entity)]
partitionedDevices =
map (Lens.over both S.fromList . L.partition deviceOK . snd) possibleDevices

-- Devices installed on the child, as a Set instead of an
-- Inventory for convenience.
alreadyInstalled :: Set Entity
alreadyInstalled = S.fromList . map snd . E.elems $ childDevices

-- Figure out what is missing from the required inventory
-- Figure out what is still missing of the required inventory:
-- the required inventory, less any inventory the child robot
-- already has.
missingChildInv = reqInv `E.difference` childInventory

if creative
then -- In creative mode, just return ALL the devices
return (S.unions (map S.fromList capDevices) `S.difference` alreadyInstalled, missingChildInv)
then
return
( -- In creative mode, just install ALL the devices
-- providing each required capability (because, why
-- not?). But don't reinstall any that are already
-- installed.
S.unions (map (S.fromList . snd) possibleDevices) `S.difference` alreadyInstalled
, -- Conjure the necessary missing inventory out of thin
-- air.
missingChildInv
)
else do
-- check if robot has all devices to execute new command
all null missingDeviceSets
-- First, check that devices actually exist AT ALL to provide every
-- required capability. If not, we will generate an error message saying
-- something like "missing capability X but no device yet provides it".
let capsWithNoDevice = mapMaybe fst . filter (null . snd) $ possibleDevices
null capsWithNoDevice
`holdsOr` Incapable fixI (R.Requirements (S.fromList capsWithNoDevice) S.empty M.empty) cmd

-- Now, ensure there is at least one device available to be
-- installed for each requirement.
let missingDevices = map snd . filter (null . fst) $ partitionedDevices
null missingDevices
`holdsOrFail` ( singularSubjectVerb subject "do"
: "not have required devices, please"
: formatIncapableFix fixI <> ":"
: (("\n - " <>) . formatDevices <$> filter (not . null) missingDeviceSets)
: (("\n - " <>) . formatDevices <$> missingDevices)
)
-- check that there are in fact devices to provide every required capability
not (any null deviceSets) `holdsOr` Incapable fixI (R.Requirements missingCaps S.empty M.empty) cmd

let minimalInstallSet = smallHittingSet (filter (S.null . S.intersection alreadyInstalled) deviceSets)
let minimalInstallSet = smallHittingSet (filter (S.null . S.intersection alreadyInstalled) (map fst partitionedDevices))

-- Check that we have enough in our inventory to cover the
-- required installs PLUS what's missing from the child
Expand Down Expand Up @@ -1951,6 +1971,11 @@ verbedGrabbingCmd = \case
Grab' -> "grabbed"
Swap' -> "swapped"

-- | Format a set of suggested devices for use in an error message,
-- in the format @device1 or device2 or ... or deviceN@.
formatDevices :: Set Entity -> Text
formatDevices = T.intercalate " or " . map (^. entityName) . S.toList

-- | Give some entities from a parent robot (the robot represented by
-- the ambient @State Robot@ effect) to a child robot (represented
-- by the given 'RID') as part of a 'Build' or 'Reprogram' command.
Expand Down
33 changes: 24 additions & 9 deletions test/integration/Main.hs
Original file line number Diff line number Diff line change
Expand Up @@ -5,7 +5,7 @@
-- | Swarm integration tests
module Main where

import Control.Lens (Ixed (ix), to, use, view, (&), (.~), (<&>), (^.), (^?!))
import Control.Lens (Ixed (ix), to, use, view, (&), (.~), (<&>), (^.), (^..), (^?!))
import Control.Monad (filterM, forM_, unless, void, when)
import Control.Monad.State (StateT (runStateT), gets)
import Control.Monad.Trans.Except (runExceptT)
Expand All @@ -15,6 +15,7 @@ import Data.Foldable (Foldable (toList), find)
import Data.IntSet qualified as IS
import Data.Map qualified as M
import Data.Maybe (isJust)
import Data.Sequence (Seq)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.IO qualified as T
Expand All @@ -23,7 +24,7 @@ import Swarm.DocGen (EditorType (..))
import Swarm.DocGen qualified as DocGen
import Swarm.Game.CESK (emptyStore, initMachine)
import Swarm.Game.Entity (EntityMap, loadEntities)
import Swarm.Game.Robot (defReqs, leText, machine, robotContext, robotLog, waitingUntil)
import Swarm.Game.Robot (LogEntry, defReqs, leText, machine, robotContext, robotLog, waitingUntil)
import Swarm.Game.Scenario (Scenario)
import Swarm.Game.State (
GameState,
Expand Down Expand Up @@ -123,6 +124,8 @@ time = \case
sec :: Int
sec = 10 ^ (6 :: Int)

data ShouldCheckBadErrors = CheckForBadErrors | AllowBadErrors deriving (Eq, Show)

testScenarioSolution :: Bool -> EntityMap -> TestTree
testScenarioSolution _ci _em =
testGroup
Expand All @@ -139,7 +142,7 @@ testScenarioSolution _ci _em =
, testSolution Default "Tutorials/install"
, testSolution Default "Tutorials/build"
, testSolution Default "Tutorials/bind2"
, testSolution' Default "Tutorials/crash" $ \g -> do
, testSolution' Default "Tutorials/crash" CheckForBadErrors $ \g -> do
let rs = toList $ g ^. robotMap
let hints = any (T.isInfixOf "you will win" . view leText) . toList . view robotLog
let win = isJust $ find hints rs
Expand Down Expand Up @@ -176,7 +179,7 @@ testScenarioSolution _ci _em =
[ testSolution Default "Testing/394-build-drill"
, testSolution Default "Testing/373-drill"
, testSolution Default "Testing/428-drowning-destroy"
, testSolution' Default "Testing/475-wait-one" $ \g -> do
, testSolution' Default "Testing/475-wait-one" CheckForBadErrors $ \g -> do
let t = g ^. ticks
r1Waits = g ^?! robotMap . ix 1 . to waitingUntil
active = IS.member 1 $ g ^. activeRobots
Expand Down Expand Up @@ -216,17 +219,27 @@ testScenarioSolution _ci _em =
, testSolution Default "Testing/710-multi-robot"
, testSolution Default "Testing/920-meet"
, testSolution Default "Testing/955-heading"
, testSolution' Default "Testing/397-wrong-missing" AllowBadErrors $ \g -> do
let msgs =
(g ^. messageQueue . to seqToTexts)
<> (g ^.. robotMap . traverse . robotLog . to seqToTexts . traverse)
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Those are some impressive optics. 🤓

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Haha, thanks, though I don't think it's that bad: ^.. means to list all the targets of a Traversal instead of just projecting out a single value. traverse just gets all the sub-things. So this means "get the robot map, then get all the robots out of it, and for each one get its log, convert it to a list of texts..." The last traverse is just so we get a single list of texts instead of a list of lists.


assertBool "Should be some messages" (not (null msgs))
assertBool "Error messages should not mention treads" $
not (any ("treads" `T.isInfixOf`) msgs)
assertBool "Error message should mention no device provides senseloc" $
any ("senseloc" `T.isInfixOf`) msgs
]
]
where
-- expectFailIf :: Bool -> String -> TestTree -> TestTree
-- expectFailIf b = if b then expectFailBecause else (\_ x -> x)

testSolution :: Time -> FilePath -> TestTree
testSolution s p = testSolution' s p (const $ pure ())
testSolution s p = testSolution' s p CheckForBadErrors (const $ pure ())

testSolution' :: Time -> FilePath -> (GameState -> Assertion) -> TestTree
testSolution' s p verify = testCase p $ do
testSolution' :: Time -> FilePath -> ShouldCheckBadErrors -> (GameState -> Assertion) -> TestTree
testSolution' s p shouldCheckBadErrors verify = testCase p $ do
out <- runExceptT $ initGameStateForScenario p Nothing Nothing
case out of
Left x -> assertFailure $ unwords ["Failure in initGameStateForScenario:", T.unpack x]
Expand All @@ -246,7 +259,7 @@ testScenarioSolution _ci _em =
Just g -> do
-- When debugging, try logging all robot messages.
-- printAllLogs
noBadErrors g
when (shouldCheckBadErrors == CheckForBadErrors) $ noBadErrors g
verify g

playUntilWin :: StateT GameState IO ()
Expand All @@ -269,9 +282,11 @@ badErrorsInLogs g =
(g ^. robotMap)
<> filter isBad (seqToTexts $ g ^. messageQueue)
where
seqToTexts = map (view leText) . toList
isBad m = "Fatal error:" `T.isInfixOf` m || "swarm/issues" `T.isInfixOf` m

seqToTexts :: Seq LogEntry -> [Text]
seqToTexts = map (view leText) . toList

printAllLogs :: GameState -> IO ()
printAllLogs g =
mapM_
Expand Down