Add subworlds

data/scenarios/Testing/00-ORDER.txt

@@ -38,3 +38,4 @@
 1295-density-command.yaml
 1138-structures
 1356-portals
+144-subworlds

src/Swarm/Doc/Gen.hs

@@ -32,6 +32,7 @@ import Data.Containers.ListUtils (nubOrd)
 import Data.Either.Extra (eitherToMaybe)
 import Data.Foldable (find, toList)
 import Data.List (transpose)
+import Data.List.NonEmpty qualified as NE
 import Data.Map.Lazy (Map)
 import Data.Map.Lazy qualified as Map
 import Data.Maybe (fromMaybe, isJust)
@@ -52,7 +53,7 @@ import Swarm.Game.Failure.Render qualified as F
 import Swarm.Game.Recipe (Recipe, loadRecipes, recipeInputs, recipeOutputs, recipeRequirements, recipeTime, recipeWeight)
 import Swarm.Game.ResourceLoading (getDataFileNameSafe)
 import Swarm.Game.Robot (equippedDevices, instantiateRobot, robotInventory)
-import Swarm.Game.Scenario (Scenario, loadScenario, scenarioRobots)
+import Swarm.Game.Scenario (Scenario, loadScenario, scenarioRobots, scenarioWorlds, worldName)
 import Swarm.Game.WorldGen (testWorld2Entites)
 import Swarm.Language.Capability (Capability)
 import Swarm.Language.Capability qualified as Capability
@@ -551,10 +552,10 @@ classicScenario = do
   fst <$> loadScenario "data/scenarios/classic.yaml" entities
 
 startingDevices :: Scenario -> Set Entity
-startingDevices = Set.fromList . map snd . E.elems . view equippedDevices . instantiateRobot 0 . head . view scenarioRobots
+startingDevices s = Set.fromList . map snd . E.elems . view equippedDevices . instantiateRobot (worldName $ NE.head $ view scenarioWorlds s) 0 . head . view scenarioRobots $ s
 
 startingInventory :: Scenario -> Map Entity Int
-startingInventory = Map.fromList . map swap . E.elems . view robotInventory . instantiateRobot 0 . head . view scenarioRobots
+startingInventory s = Map.fromList . map swap . E.elems . view robotInventory . instantiateRobot (worldName $ NE.head $ view scenarioWorlds s) 0 . head . view scenarioRobots $ s
 
 -- | Ignore utility entities that are just used for tutorials and challenges.
 ignoredEntities :: Set Text

src/Swarm/Game/Log.hs

@@ -34,6 +34,7 @@ import Data.Text (Text)
 import GHC.Generics (Generic)
 import Swarm.Game.CESK (TickNumber)
 import Swarm.Game.Location (Location)
+import Swarm.Game.Universe (Cosmo)
 
 -- | Severity of the error - critical errors are bugs
 --   and should be reported as Issues.
@@ -61,8 +62,9 @@ data LogEntry = LogEntry
   -- ^ The name of the robot that generated the entry.
   , _leRobotID :: Int
   -- ^ The ID of the robot that generated the entry.
-  , _leLocation :: Location
+  , _leLocation :: Maybe (Cosmo Location)
   -- ^ Location of the robot at log entry creation.
+  -- "Nothing" represents omnipresence for the purpose of proximity.
   , _leText :: Text
   -- ^ The text of the log entry.
   }

src/Swarm/Game/Robot.hs

@@ -94,6 +94,7 @@ import Swarm.Game.Display (Display, curOrientation, defaultRobotDisplay, invisib
 import Swarm.Game.Entity hiding (empty)
 import Swarm.Game.Location (Heading, Location, toDirection)
 import Swarm.Game.Log
+import Swarm.Game.Universe
 import Swarm.Language.Capability (Capability)
 import Swarm.Language.Context qualified as Ctx
 import Swarm.Language.Requirement (ReqCtx)
@@ -167,7 +168,7 @@ data RobotPhase
 --   concrete robot we must have a location.
 type family RobotLocation (phase :: RobotPhase) :: * where
   RobotLocation 'TemplateRobot = Maybe Location
-  RobotLocation 'ConcreteRobot = Location
+  RobotLocation 'ConcreteRobot = Cosmo Location
 
 -- | Robot templates have no ID; concrete robots definitely do.
 type family RobotID (phase :: RobotPhase) :: * where
@@ -269,13 +270,13 @@ robotDisplay = lens getDisplay setDisplay
 --   a getter, since when changing a robot's location we must remember
 --   to update the 'robotsByLocation' map as well.  You can use the
 --   'updateRobotLocation' function for this purpose.
-robotLocation :: Getter Robot Location
+robotLocation :: Getter Robot (Cosmo Location)
 
 -- | Set a robot's location.  This is unsafe and should never be
 --   called directly except by the 'updateRobotLocation' function.
 --   The reason is that we need to make sure the 'robotsByLocation'
 --   map stays in sync.
-unsafeSetRobotLocation :: Location -> Robot -> Robot
+unsafeSetRobotLocation :: Cosmo Location -> Robot -> Robot
 unsafeSetRobotLocation loc r = r {_robotLocation = loc}
 
 -- | A template robot's location.  Unlike 'robotLocation', this is a
@@ -308,11 +309,11 @@ robotID :: Getter Robot RID
 --    if the robot template didn't have a location already, just set
 --    the location to (0,0) by default.  If you want a different location,
 --    set it via 'trobotLocation' before calling 'instantiateRobot'.
-instantiateRobot :: RID -> TRobot -> Robot
-instantiateRobot i r =
+instantiateRobot :: SubworldName -> RID -> TRobot -> Robot
+instantiateRobot swName i r =
   r
     { _robotID = i
-    , _robotLocation = fromMaybe zero (_robotLocation r)
+    , _robotLocation = Cosmo swName $ fromMaybe zero $ _robotLocation r
     }
 
 -- | The ID number of the robot's parent, that is, the robot that

src/Swarm/Game/Scenario.hs

@@ -33,7 +33,8 @@ module Swarm.Game.Scenario (
   scenarioEntities,
   scenarioRecipes,
   scenarioKnown,
-  scenarioWorld,
+  scenarioWorlds,
+  scenarioNavigation,
   scenarioRobots,
   scenarioObjectives,
   scenarioSolution,
@@ -45,18 +46,23 @@ module Swarm.Game.Scenario (
   getScenarioPath,
 ) where
 
+import Control.Arrow ((&&&))
 import Control.Lens hiding (from, (.=), (<.>))
 import Control.Monad (filterM)
 import Control.Monad.Except (ExceptT (..), MonadIO, liftIO, runExceptT, withExceptT)
 import Control.Monad.Trans.Except (except)
 import Data.Aeson
 import Data.Either.Extra (eitherToMaybe, maybeToEither)
+import Data.List.NonEmpty (NonEmpty ((:|)))
+import Data.List.NonEmpty qualified as NE
+import Data.Map qualified as M
 import Data.Maybe (catMaybes, isNothing, listToMaybe)
 import Data.Text (Text)
 import Data.Text qualified as T
 import Swarm.Game.Entity
 import Swarm.Game.Failure
 import Swarm.Game.Failure.Render
+import Swarm.Game.Location
 import Swarm.Game.Recipe
 import Swarm.Game.ResourceLoading (getDataFileNameSafe)
 import Swarm.Game.Robot (TRobot)
@@ -65,7 +71,9 @@ import Swarm.Game.Scenario.Objective.Validation
 import Swarm.Game.Scenario.RobotLookup
 import Swarm.Game.Scenario.Style
 import Swarm.Game.Scenario.Topography.Cell
+import Swarm.Game.Scenario.Topography.Navigation.Portal
 import Swarm.Game.Scenario.Topography.WorldDescription
+import Swarm.Game.Universe
 import Swarm.Language.Pipeline (ProcessedTerm)
 import Swarm.Util (failT)
 import Swarm.Util.Lens (makeLensesNoSigs)
@@ -91,7 +99,8 @@ data Scenario = Scenario
   , _scenarioEntities :: EntityMap
   , _scenarioRecipes :: [Recipe Entity]
   , _scenarioKnown :: [Text]
-  , _scenarioWorld :: WorldDescription
+  , _scenarioWorlds :: NonEmpty WorldDescription
+  , _scenarioNavigation :: Navigation (M.Map SubworldName) Location
   , _scenarioRobots :: [TRobot]
   , _scenarioObjectives :: [Objective]
   , _scenarioSolution :: Maybe ProcessedTerm
@@ -122,6 +131,24 @@ instance FromJSONE EntityMap Scenario where
       rs <- v ..: "robots"
       let rsMap = buildRobotMap rs
 
+      rootWorld <- localE (,rsMap) (v ..: "world")
+      subworlds <- localE (,rsMap) (v ..:? "subworlds" ..!= [])
+
+      let allWorlds = rootWorld :| subworlds
+      let mergedWaypoints =
+            M.fromList $
+              map (worldName &&& runIdentity . waypoints . navigation) $
+                NE.toList allWorlds
+
+      mergedPortals <-
+        validatePortals
+          . Navigation mergedWaypoints
+          . M.unions
+          $ map (portals . navigation)
+          $ NE.toList allWorlds
+
+      let mergedNavigation = Navigation mergedWaypoints mergedPortals
+
       Scenario
         <$> liftE (v .: "version")
         <*> liftE (v .: "name")
@@ -133,7 +160,8 @@ instance FromJSONE EntityMap Scenario where
         <*> pure em
         <*> v ..:? "recipes" ..!= []
         <*> pure known
-        <*> localE (,rsMap) (v ..: "world")
+        <*> pure allWorlds
+        <*> pure mergedNavigation
         <*> pure rs
         <*> (liftE (v .:? "objectives" .!= []) >>= validateObjectives)
         <*> liftE (v .:? "solution")
@@ -178,8 +206,11 @@ scenarioRecipes :: Lens' Scenario [Recipe Entity]
 --   not have to scan them.
 scenarioKnown :: Lens' Scenario [Text]
 
--- | The starting world for the scenario.
-scenarioWorld :: Lens' Scenario WorldDescription
+-- | The subworlds of the scenario.
+scenarioWorlds :: Lens' Scenario (NonEmpty WorldDescription)
+
+-- | Waypoints and inter-world portals
+scenarioNavigation :: Lens' Scenario (Navigation (M.Map SubworldName) Location)
 
 -- | The starting robots for the scenario.  Note this should
 --   include the base.

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

@@ -1,38 +1,45 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 -- |
 -- SPDX-License-Identifier: BSD-3-Clause
 module Swarm.Game.Scenario.Topography.Navigation.Portal where
 
 import Control.Monad (forM, forM_, unless)
 import Data.Aeson (FromJSON)
+import Data.Bifunctor (first)
+import Data.Functor.Identity
 import Data.Int (Int32)
 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 (listToMaybe)
-import Data.Text (Text)
+import Data.Maybe (fromMaybe, listToMaybe)
 import Data.Text qualified as T
 import GHC.Generics (Generic)
 import Linear (V2)
 import Swarm.Game.Location
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint
+import Swarm.Game.Universe
 import Swarm.Util (binTuples, quote)
 
--- | Note: The primary overworld shall use
--- the reserved name \"root\".
-newtype SubworldName = SubworldName Text
-  deriving (Show, Eq, Ord, Generic, FromJSON)
+type WaypointMap = M.Map WaypointName (NonEmpty Location)
 
-data Navigation = Navigation
-  { waypoints :: M.Map WaypointName (NonEmpty Location)
+-- | 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
+-- access to the waypoints across all subworlds, and can therefore translate
+-- the portal exits to concrete planar locations.
+data Navigation a b = Navigation
+  { waypoints :: a WaypointMap
   -- ^ 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 Location Location
+  , portals :: M.Map (Cosmo Location) (Cosmo b)
   }
-  deriving (Eq, Show)
+
+deriving instance (Eq (a WaypointMap), Eq b) => Eq (Navigation a b)
+deriving instance (Show (a WaypointMap), Show b) => Show (Navigation a b)
 
 data PortalExit = PortalExit
   { exit :: WaypointName
@@ -64,31 +71,59 @@ failUponDuplication message binnedMap =
  where
   duplicated = M.filter ((> 1) . NE.length) binnedMap
 
--- | Enforces the following constraints:
--- * portals can have multiple entrances but only a single exit
+failWaypointLookup :: MonadFail m => WaypointName -> Maybe a -> m a
+failWaypointLookup (WaypointName rawName) lookupResult = case lookupResult of
+  Nothing ->
+    fail $
+      T.unpack $
+        T.unwords
+          [ "No waypoint named"
+          , quote rawName
+          ]
+  Just xs -> return xs
+
+-- |
+-- The following constraints must be enforced:
+-- * portals based on plural waypoint multiplicity can have multiple entrances but only a single exit
 -- * no two portals share the same entrance location
--- * global waypoint uniqueness when the "unique" flag is specified
+-- * waypoint uniqueness within a subworld when the "unique" flag is specified
+--
+-- == Data flow:
+--
+-- Waypoints are defined within a subworld and are namespaced by it.
+-- Optional intra-subworld uniqueness of Waypoints is enforced at WorldDescription
+-- parse time.
+-- Portals are declared within a subworld. The portal entrance must be a waypoint
+-- within this subworld.
+-- They can reference waypoints in other subworlds as exits, but these references
+-- are not validated until the Scenario parse level.
+--
+-- * Since portal /entrances/ are specified at the subworld level, validation that
+--   no entrances overlap can also be performed at that level.
+-- * However, enforcement of single-multiplicity on portal /exits/ must be performed
+--   at scenario-parse level, because for a portal exit that references a waypoint in
+--   another subworld, we can't know at the single-WorldDescription level whether
+--   that waypoint has plural multiplicity.
 validateNavigation ::
   (MonadFail m, Traversable t) =>
+  SubworldName ->
   V2 Int32 ->
   [Originated Waypoint] ->
   t Portal ->
-  m Navigation
-validateNavigation upperLeft unmergedWaypoints portalDefs = do
+  m (Navigation Identity WaypointName)
+validateNavigation currentSubworldName upperLeft unmergedWaypoints portalDefs = do
   failUponDuplication "is required to be unique, but is duplicated in:" waypointsWithUniqueFlag
 
-  -- TODO(#144) Currently ignores subworld references
-  nestedPortalPairs <- forM portalDefs $ \(Portal entranceName (PortalExit exitName@(WaypointName rawExitName) _)) -> do
+  nestedPortalPairs <- forM portalDefs $ \(Portal entranceName (PortalExit exitName maybeExitSubworldName)) -> 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 replicate portal entrances.
+    -- Multiple occurrences of entrance waypoints of a given name will result in
+    -- multiple portal entrances.
     entranceLocs <- getLocs entranceName
-    firstExitLoc :| otherExits <- getLocs exitName
-    unless (null otherExits)
-      . fail
-      . T.unpack
-      $ T.unwords ["Ambiguous exit waypoints named", quote rawExitName, "for portal"]
-    return $ map ((,extractLoc firstExitLoc) . extractLoc) $ NE.toList entranceLocs
+
+    let sw = fromMaybe currentSubworldName maybeExitSubworldName
+        f = (,Cosmo sw exitName) . extractLoc
+    return $ map f $ NE.toList entranceLocs
 
   let reconciledPortalPairs = concat nestedPortalPairs
 
@@ -97,17 +132,10 @@ validateNavigation upperLeft unmergedWaypoints portalDefs = do
   failUponDuplication "has overlapping portal entrances exiting to" $
     binTuples reconciledPortalPairs
 
-  return $ Navigation bareWaypoints $ M.fromList reconciledPortalPairs
+  return . Navigation (pure bareWaypoints) . M.fromList $
+    map (first $ Cosmo currentSubworldName) reconciledPortalPairs
  where
-  getLocs wpWrapper@(WaypointName rawName) = case M.lookup wpWrapper correctedWaypoints of
-    Nothing ->
-      fail $
-        T.unpack $
-          T.unwords
-            [ "No waypoint named"
-            , quote rawName
-            ]
-    Just xs -> return xs
+  getLocs wpWrapper = failWaypointLookup wpWrapper $ M.lookup wpWrapper correctedWaypoints
 
   extractLoc (Originated _ (Waypoint _ loc)) = loc
   correctedWaypoints =
@@ -116,5 +144,40 @@ validateNavigation upperLeft unmergedWaypoints portalDefs = do
         (\x -> (wpName $ wpConfig $ value x, fmap (offsetWaypoint upperLeft) x))
         unmergedWaypoints
   bareWaypoints = M.map (NE.map extractLoc) correctedWaypoints
-
   waypointsWithUniqueFlag = M.filter (any $ wpUnique . wpConfig . value) correctedWaypoints
+
+validatePortals ::
+  MonadFail m =>
+  Navigation (M.Map SubworldName) WaypointName ->
+  m (M.Map (Cosmo Location) (Cosmo Location))
+validatePortals (Navigation wpUniverse partialPortals) = do
+  portalPairs <- forM (M.toList partialPortals) $ \(portalEntrance, portalExit@(Cosmo swName (WaypointName rawExitName))) -> do
+    firstExitLoc :| otherExits <- getLocs portalExit
+    unless (null otherExits)
+      . fail
+      . T.unpack
+      $ T.unwords
+        [ "Ambiguous exit waypoints named"
+        , quote rawExitName
+        , "for portal"
+        ]
+    return (portalEntrance, Cosmo swName firstExitLoc)
+
+  return $ M.fromList portalPairs
+ where
+  getLocs (Cosmo swName@(SubworldName rawSwName) wpWrapper@(WaypointName exitName)) = do
+    subworldWaypoints <- case M.lookup swName wpUniverse of
+      Just x -> return x
+      Nothing ->
+        fail $
+          T.unpack $
+            T.unwords
+              [ "Could not lookup waypoint"
+              , quote exitName
+              , "for portal exit because subworld"
+              , quote rawSwName
+              , "does not exist"
+              ]
+
+    failWaypointLookup wpWrapper $
+      M.lookup wpWrapper subworldWaypoints