enforce spatial consistency

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

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.
+    ..........

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.
+    ..........

src/Swarm/Game/Scenario/Topography/Navigation/Portal.hs

@@ -5,25 +5,37 @@
 -- 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 ((:|)))
 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,15 +135,15 @@ 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
     -- multiple portal entrances.
     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

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.

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