diff --git a/data/scenarios/Testing/144-subworlds/00-ORDER.txt b/data/scenarios/Testing/144-subworlds/00-ORDER.txt index c93126271d..59d8c8657f 100644 --- a/data/scenarios/Testing/144-subworlds/00-ORDER.txt +++ b/data/scenarios/Testing/144-subworlds/00-ORDER.txt @@ -2,3 +2,4 @@ basic-subworld.yaml subworld-shared-structures.yaml subworld-mapped-robots.yaml subworld-located-robots.yaml +spatial-consistency-enforcement.yaml diff --git a/data/scenarios/Testing/144-subworlds/spatial-consistency-enforcement.yaml b/data/scenarios/Testing/144-subworlds/spatial-consistency-enforcement.yaml new file mode 100644 index 0000000000..6e5a019bff --- /dev/null +++ b/data/scenarios/Testing/144-subworlds/spatial-consistency-enforcement.yaml @@ -0,0 +1,93 @@ +version: 1 +name: Subworld spatial consistency enforcement +description: | + Portals annotated to enforce spatial consistency between subworlds +attrs: + - name: portal_in + fg: "#ff9a00" + bg: "#ff5d00" + - name: portal_out + fg: "#00a2ff" + bg: "#0065ff" +entities: + - name: telepad entrance + display: + attr: portal_in + char: "o" + description: + - Portal entrance + properties: [known] + - name: telepad exit + display: + attr: portal_out + char: "o" + description: + - Portal exit + properties: [known] +robots: + - name: base + dir: [1, 0] + devices: + - ADT calculator + - branch predictor + - comparator + - compass + - dictionary + - GPS receiver + - grabber + - lambda + - lodestone + - logger + - strange loop + - treads +known: [boulder] +subworlds: + - name: underground + default: [blank] + palette: + '.': [dirt] + 'b': [dirt, boulder] + 'p': + cell: [dirt, telepad exit] + waypoint: + name: portal_out2 + 'P': + cell: [dirt, telepad entrance] + waypoint: + name: portal_in2 + portals: + - entrance: portal_in2 + exitInfo: + exit: portal_out1 + subworldName: root + consistent: true + upperleft: [-1, 1] + map: | + b..b..b..b + .p......P. + b..b..b..b +world: + name: root + default: [blank] + palette: + '.': [grass] + 'B': [grass, null, base] + 'p': + cell: [grass, telepad exit] + waypoint: + name: portal_out1 + 'P': + cell: [grass, telepad entrance] + waypoint: + name: portal_in1 + upperleft: [-1, 1] + portals: + - entrance: portal_in1 + exitInfo: + exit: portal_out2 + subworldName: underground + consistent: true + map: | + .......... + .p.B....P. + .......... diff --git a/data/scenarios/Testing/_Validation/144-spatial-consistency-enforcement.yaml b/data/scenarios/Testing/_Validation/144-spatial-consistency-enforcement.yaml new file mode 100644 index 0000000000..f0c219ed0a --- /dev/null +++ b/data/scenarios/Testing/_Validation/144-spatial-consistency-enforcement.yaml @@ -0,0 +1,93 @@ +version: 1 +name: Subworld spatial consistency enforcement +description: | + Portals annotated to enforce spatial consistency between subworlds +attrs: + - name: portal_in + fg: "#ff9a00" + bg: "#ff5d00" + - name: portal_out + fg: "#00a2ff" + bg: "#0065ff" +entities: + - name: telepad entrance + display: + attr: portal_in + char: "o" + description: + - Portal entrance + properties: [known] + - name: telepad exit + display: + attr: portal_out + char: "o" + description: + - Portal exit + properties: [known] +robots: + - name: base + dir: [1, 0] + devices: + - ADT calculator + - branch predictor + - comparator + - compass + - dictionary + - GPS receiver + - grabber + - lambda + - lodestone + - logger + - strange loop + - treads +known: [boulder] +subworlds: + - name: underground + default: [blank] + palette: + '.': [dirt] + 'b': [dirt, boulder] + 'p': + cell: [dirt, telepad exit] + waypoint: + name: portal_out2 + 'P': + cell: [dirt, telepad entrance] + waypoint: + name: portal_in2 + portals: + - entrance: portal_in2 + exitInfo: + exit: portal_out1 + subworldName: root + consistent: true + upperleft: [-1, 1] + map: | + b..b..b..b + .p.....P.. + b..b..b..b +world: + name: root + default: [blank] + palette: + '.': [grass] + 'B': [grass, null, base] + 'p': + cell: [grass, telepad exit] + waypoint: + name: portal_out1 + 'P': + cell: [grass, telepad entrance] + waypoint: + name: portal_in1 + upperleft: [-1, 1] + portals: + - entrance: portal_in1 + exitInfo: + exit: portal_out2 + subworldName: underground + consistent: true + map: | + .......... + .p.B....P. + .......... diff --git a/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs b/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs index c5f2903f68..768b4beb80 100644 --- a/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs +++ b/src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs @@ -5,10 +5,14 @@ -- SPDX-License-Identifier: BSD-3-Clause module Swarm.Game.Scenario.Topography.Navigation.Portal where +import Control.Arrow ((&&&)) +import Control.Lens (view) import Control.Monad (forM, forM_, unless) -import Data.Aeson (FromJSON) +import Data.Aeson import Data.Bifunctor (first) +import Data.BoolExpr (Signed (..)) import Data.Coerce +import Data.Function (on) import Data.Functor.Identity import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty ((:|))) @@ -16,14 +20,22 @@ import Data.List.NonEmpty qualified as NE import Data.Map qualified as M import Data.Maybe (fromMaybe, listToMaybe) import Data.Text qualified as T +import Data.Tuple (swap) import GHC.Generics (Generic) +import Linear (negated) import Swarm.Game.Location import Swarm.Game.Scenario.Topography.Navigation.Waypoint import Swarm.Game.Universe -import Swarm.Util (binTuples, quote) +import Swarm.Util (allEqual, binTuples, both, quote) type WaypointMap = M.Map WaypointName (NonEmpty Location) +data AnnotatedDestination a = AnnotatedDestination + { enforceConsistency :: Bool + , cosmoLocation :: Cosmo a + } + deriving (Show, Eq) + -- | Parameterized on the portal specification method. -- At the subworld parsing level, we only can obtain the planar location -- for portal /entrances/. At the Scenario-parsing level, we finally have @@ -34,7 +46,7 @@ data Navigation a b = Navigation -- ^ Note that waypoints defined at the "root" level are still relative to -- the top-left corner of the map rectangle; they are not in absolute world -- coordinates (as with applying the "ul" offset). - , portals :: M.Map (Cosmo Location) (Cosmo b) + , portals :: M.Map (Cosmo Location) (AnnotatedDestination b) } deriving instance (Eq (a WaypointMap), Eq b) => Eq (Navigation a b) @@ -50,9 +62,18 @@ data PortalExit = PortalExit data Portal = Portal { entrance :: WaypointName , exitInfo :: PortalExit - , consistent :: Maybe Bool + , consistent :: Bool } - deriving (Show, Eq, Generic, FromJSON) + deriving (Show, Eq) + +instance FromJSON Portal where + parseJSON = withObject "Portal" $ \v -> + Portal + <$> v + .: "entrance" + <*> v + .: "exitInfo" + <*> v .:? "consistent" .!= False failUponDuplication :: (MonadFail m, Show a, Show b) => @@ -114,7 +135,7 @@ validatePartialNavigation :: validatePartialNavigation currentSubworldName upperLeft unmergedWaypoints portalDefs = do failUponDuplication "is required to be unique, but is duplicated in:" waypointsWithUniqueFlag - nestedPortalPairs <- forM portalDefs $ \(Portal entranceName (PortalExit exitName maybeExitSubworldName) _) -> do + nestedPortalPairs <- forM portalDefs $ \(Portal entranceName (PortalExit exitName maybeExitSubworldName) isConsistent) -> do -- Portals can have multiple entrances but only a single exit. -- That is, the pairings of entries to exits must form a proper mathematical "function". -- Multiple occurrences of entrance waypoints of a given name will result in @@ -122,7 +143,7 @@ validatePartialNavigation currentSubworldName upperLeft unmergedWaypoints portal entranceLocs <- getLocs entranceName let sw = fromMaybe currentSubworldName maybeExitSubworldName - f = (,Cosmo sw exitName) . extractLoc + f = (,AnnotatedDestination isConsistent $ Cosmo sw exitName) . extractLoc return $ map f $ NE.toList entranceLocs let reconciledPortalPairs = concat nestedPortalPairs @@ -149,9 +170,9 @@ validatePartialNavigation currentSubworldName upperLeft unmergedWaypoints portal validatePortals :: MonadFail m => Navigation (M.Map SubworldName) WaypointName -> - m (M.Map (Cosmo Location) (Cosmo Location)) + m (M.Map (Cosmo Location) (AnnotatedDestination Location)) validatePortals (Navigation wpUniverse partialPortals) = do - portalPairs <- forM (M.toList partialPortals) $ \(portalEntrance, portalExit@(Cosmo swName (WaypointName rawExitName))) -> do + portalPairs <- forM (M.toList partialPortals) $ \(portalEntrance, AnnotatedDestination isConsistent portalExit@(Cosmo swName (WaypointName rawExitName))) -> do firstExitLoc :| otherExits <- getLocs portalExit unless (null otherExits) . fail @@ -161,7 +182,9 @@ validatePortals (Navigation wpUniverse partialPortals) = do , quote rawExitName , "for portal" ] - return (portalEntrance, Cosmo swName firstExitLoc) + return (portalEntrance, AnnotatedDestination isConsistent $ Cosmo swName firstExitLoc) + + ensureSpatialConsistency portalPairs return $ M.fromList portalPairs where @@ -198,6 +221,41 @@ validatePortals (Navigation wpUniverse partialPortals) = do -- * The resulting \"vector\" from every pair must be equal. ensureSpatialConsistency :: MonadFail m => - -- Navigation (M.Map SubworldName) WaypointName -> + [(Cosmo Location, AnnotatedDestination Location)] -> m () -ensureSpatialConsistency = return () -- TODO +ensureSpatialConsistency xs = + unless (null nonUniform) $ + fail $ + unwords + [ "Non-uniform portal distances:" + , show nonUniform + ] + where + consistentPairs :: [(Cosmo Location, Cosmo Location)] + consistentPairs = map (fmap cosmoLocation) $ filter (enforceConsistency . snd) xs + + interWorldPairs = filter (uncurry ((/=) `on` view subworld)) consistentPairs + normalizedOrdering = map normalizePairOrder interWorldPairs + + normalizePairOrder pair = + if uncurry ((>) `on` view subworld) pair + then Negative $ swap pair + else Positive pair + + tuplify = both (view subworld) &&& both (view planar) + + nest :: + Signed (b, a) -> + (b, Signed a) + nest = \case + Positive x -> fmap Positive x + Negative x -> fmap Negative x + + reExtract = \case + Positive x -> x + Negative x -> negated x + + groupedBySubworldPair = binTuples $ map (nest . fmap tuplify) normalizedOrdering + vectorized = M.map (NE.map (reExtract . fmap (uncurry (.-.)))) groupedBySubworldPair + + nonUniform = M.filter ((not . allEqual) . NE.toList) vectorized diff --git a/src/Swarm/Game/Step.hs b/src/Swarm/Game/Step.hs index e65628fbc0..fbc596eb40 100644 --- a/src/Swarm/Game/Step.hs +++ b/src/Swarm/Game/Step.hs @@ -75,7 +75,7 @@ import Swarm.Game.ResourceLoading (getDataFileNameSafe) import Swarm.Game.Robot import Swarm.Game.Scenario.Objective qualified as OB import Swarm.Game.Scenario.Objective.WinCheck qualified as WC -import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..)) +import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..), cosmoLocation) import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointName (..)) import Swarm.Game.State import Swarm.Game.Universe @@ -2749,7 +2749,7 @@ updateRobotLocation oldLoc newLoc where applyPortal loc = do lms <- use worldNavigation - return $ M.findWithDefault loc loc $ portals lms + return . M.findWithDefault loc loc . M.map cosmoLocation $ portals lms -- | Execute a stateful action on a target robot --- whether the -- current one or another. diff --git a/src/Swarm/Util.hs b/src/Swarm/Util.hs index 12883cff81..114d122ccc 100644 --- a/src/Swarm/Util.hs +++ b/src/Swarm/Util.hs @@ -21,6 +21,7 @@ module Swarm.Util ( histogram, findDup, both, + allEqual, -- * Directory utilities readFileMay, @@ -189,6 +190,9 @@ findDup = go S.empty both :: Bifunctor p => (a -> d) -> p a a -> p d d both f = bimap f f +allEqual :: (Ord a) => [a] -> Bool +allEqual = (== 1) . S.size . S.fromList + ------------------------------------------------------------ -- Directory stuff