[WIP] 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,101 @@
+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
+  - name: judge
+    dir: [1, 0]
+    system: true
+    display:
+      char: 'J'
+      invisible: true
+known: [flower, boulder]
+subworlds:
+  - name: underground
+    default: [blank]
+    palette:
+      '.': [dirt]
+      'f': [dirt, flower]
+      '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..f...P.
+      b..b..b..b
+world:
+  name: root
+  default: [blank]
+  palette:
+    '.': [grass]
+    'B': [grass, null, base]
+    't': [ice, null, judge]
+    '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.Bt...P.
+    ..........

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

@@ -6,7 +6,7 @@
 module Swarm.Game.Scenario.Topography.Navigation.Portal where
 
 import Control.Monad (forM, forM_, unless)
-import Data.Aeson (FromJSON)
+import Data.Aeson
 import Data.Bifunctor (first)
 import Data.Coerce
 import Data.Functor.Identity
@@ -24,6 +24,12 @@ import Swarm.Util (binTuples, 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 +40,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 +56,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 +129,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 +164,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 +176,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 +215,6 @@ 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 _x = return () -- TODO

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.