Restyle subworlds

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
@@ -312,7 +313,7 @@ instantiateRobot :: RID -> TRobot -> Robot
 instantiateRobot i r =
   r
     { _robotID = i
-    , _robotLocation = fromMaybe zero (_robotLocation r)
+    , _robotLocation = Cosmo rootSubworldName $ fromMaybe zero (_robotLocation r)
     }
 
 -- | The ID number of the robot's parent, that is, the robot that

src/Swarm/Game/Scenario.hs

@@ -33,6 +33,7 @@ module Swarm.Game.Scenario (
   scenarioEntities,
   scenarioRecipes,
   scenarioKnown,
+  secenarioSubworlds,
   scenarioWorld,
   scenarioRobots,
   scenarioObjectives,
@@ -65,6 +66,7 @@ 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.Subworld
 import Swarm.Game.Scenario.Topography.WorldDescription
 import Swarm.Language.Pipeline (ProcessedTerm)
 import Swarm.Util (failT)
@@ -91,6 +93,7 @@ data Scenario = Scenario
   , _scenarioEntities :: EntityMap
   , _scenarioRecipes :: [Recipe Entity]
   , _scenarioKnown :: [Text]
+  , _secenarioSubworlds :: [Subworld]
   , _scenarioWorld :: WorldDescription
   , _scenarioRobots :: [TRobot]
   , _scenarioObjectives :: [Objective]
@@ -110,6 +113,8 @@ instance FromJSONE EntityMap Scenario where
       Left x -> failT [x]
     -- extend ambient EntityMap with custom entities
 
+    subworlds <- v ..:? "subworlds" ..!= []
+
     withE em $ do
       -- parse 'known' entity names and make sure they exist
       known <- liftE (v .:? "known" .!= [])
@@ -133,6 +138,7 @@ instance FromJSONE EntityMap Scenario where
         <*> pure em
         <*> v ..:? "recipes" ..!= []
         <*> pure known
+        <*> pure subworlds
         <*> localE (,rsMap) (v ..: "world")
         <*> pure rs
         <*> (liftE (v .:? "objectives" .!= []) >>= validateObjectives)
@@ -178,6 +184,9 @@ scenarioRecipes :: Lens' Scenario [Recipe Entity]
 --   not have to scan them.
 scenarioKnown :: Lens' Scenario [Text]
 
+-- | The subworlds of the scenario.
+secenarioSubworlds :: Lens' Scenario [Subworld]
+
 -- | The starting world for the scenario.
 scenarioWorld :: Lens' Scenario WorldDescription
 

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

@@ -6,31 +6,27 @@ module Swarm.Game.Scenario.Topography.Navigation.Portal where
 
 import Control.Monad (forM, forM_, unless)
 import Data.Aeson (FromJSON)
+import Data.Bifunctor (first)
 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)
-
 data Navigation = Navigation
-  { waypoints :: M.Map WaypointName (NonEmpty Location)
+  { waypoints :: M.Map WaypointName (NonEmpty (Cosmo Location))
   -- ^ 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 Location)
   }
   deriving (Eq, Show)
 
@@ -70,15 +66,15 @@ failUponDuplication message binnedMap =
 -- * global waypoint uniqueness when the "unique" flag is specified
 validateNavigation ::
   (MonadFail m, Traversable t) =>
+  SubworldName ->
   V2 Int32 ->
   [Originated Waypoint] ->
   t Portal ->
   m Navigation
-validateNavigation upperLeft unmergedWaypoints portalDefs = do
+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@(WaypointName rawExitName) 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.
@@ -87,8 +83,14 @@ validateNavigation upperLeft unmergedWaypoints portalDefs = do
     unless (null otherExits)
       . fail
       . T.unpack
-      $ T.unwords ["Ambiguous exit waypoints named", quote rawExitName, "for portal"]
-    return $ map ((,extractLoc firstExitLoc) . extractLoc) $ NE.toList entranceLocs
+      $ T.unwords
+        [ "Ambiguous exit waypoints named"
+        , quote rawExitName
+        , "for portal"
+        ]
+    let sw = fromMaybe currentSubworldName maybeExitSubworldName
+        f = (,Cosmo sw $ extractLoc firstExitLoc) . extractLoc
+    return $ map f $ NE.toList entranceLocs
 
   let reconciledPortalPairs = concat nestedPortalPairs
 
@@ -97,7 +99,8 @@ validateNavigation upperLeft unmergedWaypoints portalDefs = do
   failUponDuplication "has overlapping portal entrances exiting to" $
     binTuples reconciledPortalPairs
 
-  return $ Navigation bareWaypoints $ M.fromList reconciledPortalPairs
+  return . Navigation bareWaypoints . M.fromList $
+    map (first $ Cosmo currentSubworldName) reconciledPortalPairs
  where
   getLocs wpWrapper@(WaypointName rawName) = case M.lookup wpWrapper correctedWaypoints of
     Nothing ->
@@ -115,6 +118,6 @@ validateNavigation upperLeft unmergedWaypoints portalDefs = do
       map
         (\x -> (wpName $ wpConfig $ value x, fmap (offsetWaypoint upperLeft) x))
         unmergedWaypoints
-  bareWaypoints = M.map (NE.map extractLoc) correctedWaypoints
+  bareWaypoints = M.map (NE.map $ Cosmo currentSubworldName . extractLoc) correctedWaypoints
 
   waypointsWithUniqueFlag = M.filter (any $ wpUnique . wpConfig . value) correctedWaypoints

src/Swarm/Game/Scenario/Topography/Subworld.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+module Swarm.Game.Scenario.Topography.Subworld where
+
+import Data.Aeson
+import Swarm.Game.Entity
+import Swarm.Game.Scenario.RobotLookup
+import Swarm.Game.Scenario.Topography.WorldDescription
+import Swarm.Game.Universe
+import Swarm.Util.Yaml
+
+data Subworld = Subworld
+  { name :: SubworldName
+  , world :: WorldDescription
+  }
+  deriving (Eq, Show)
+
+instance FromJSONE EntityMap Subworld where
+  parseJSONE = withObjectE "subworld" $ \v -> do
+    n <- liftE (v .: "name")
+    let rsMap = buildRobotMap []
+    w <- localE (,rsMap) (v ..: "world")
+    return $ Subworld n w

src/Swarm/Game/Scenario/Topography/WorldDescription.hs

@@ -16,6 +16,7 @@ import Swarm.Game.Scenario.Topography.EntityFacade
 import Swarm.Game.Scenario.Topography.Navigation.Portal
 import Swarm.Game.Scenario.Topography.Structure qualified as Structure
 import Swarm.Game.Scenario.Topography.WorldPalette
+import Swarm.Game.Universe
 import Swarm.Util.Yaml
 
 ------------------------------------------------------------
@@ -52,7 +53,12 @@ instance FromJSONE (EntityMap, RobotMap) WorldDescription where
     let struc = Structure.Structure initialArea structureDefs placementDefs $ waypointDefs <> mapWaypoints
         Structure.MergedStructure mergedArea unmergedWaypoints = Structure.mergeStructures mempty Nothing struc
 
-    validatedLandmarks <- validateNavigation (coerce upperLeft) unmergedWaypoints portalDefs
+    validatedLandmarks <-
+      validateNavigation
+        rootSubworldName -- TODO: Replace with actual subworld name
+        (coerce upperLeft)
+        unmergedWaypoints
+        portalDefs
 
     WorldDescription
       <$> v ..:? "default"