apply coord corrections

data/scenarios/Testing/144-subworlds/subworld.yaml

@@ -18,7 +18,7 @@ world:
     '┘': [stone, lower right corner]
     '─': [stone, horizontal wall]
     '│': [stone, vertical wall]
-  upperleft: [-1, 1]
+  upperleft: [-4, 7]
   structures:
     - name: bitpair
       structure:
@@ -28,6 +28,9 @@ world:
         map: |
           1
           0
+        waypoints:
+          - wpName: bitpair
+            wpLoc: [0, -1]
     - name: minibox
       structure:
         palette:
@@ -39,6 +42,9 @@ world:
         placements:
           - src: bitpair
             offset: [1, 0]
+        waypoints:
+          - wpName: minibox
+            wpLoc: [0, 0]
         map: |
           ┌.┐
           └.┘
@@ -47,6 +53,9 @@ world:
         palette:
           '.': [stone]
           'T': [stone, tree]
+        waypoints:
+          - wpName: foo
+            wpLoc: [2, -3]
         map: |
           TTTTTT
           T.T.T.

src/Swarm/Game/Scenario/Structure.hs

@@ -4,11 +4,11 @@
 -- SPDX-License-Identifier: BSD-3-Clause
 module Swarm.Game.Scenario.Structure where
 
-import Linear (V2 (..))
 import Control.Applicative ((<|>))
 import Control.Arrow ((&&&))
 import Data.Aeson.Key qualified as Key
 import Data.Aeson.KeyMap qualified as KeyMap
+import Data.Coerce
 import Data.List (transpose)
 import Data.Map qualified as M
 import Data.Maybe (mapMaybe)
@@ -28,6 +28,16 @@ import Witch (into)
 newtype WaypointName = WaypointName Text
   deriving (Show, Eq, Ord, Generic, FromJSON)
 
+data PlacementSource = Overlay Placement | Root
+  deriving (Show, Eq)
+
+-- | Indicates which structure something came from
+data Originated a = Originated
+  { structureSource :: PlacementSource
+  , value :: a
+  }
+  deriving (Show, Eq, Functor)
+
 -- |
 -- A parent world shouldn't have to know the exact layout of a subworld
 -- to specify where exactly a portal will deliver a robot to within the subworld.
@@ -65,7 +75,7 @@ data PStructure c = Structure
   }
   deriving (Eq, Show)
 
-data MergedStructure c = MergedStructure [[c]] (M.Map WaypointName Location)
+data MergedStructure c = MergedStructure [[c]] [Originated Waypoint]
 
 data Orientation = Orientation
   { up :: AbsoluteDir
@@ -93,19 +103,19 @@ overlaySingleStructure ::
   MergedStructure (Maybe a)
 overlaySingleStructure
   inheritedStrucDefs
-  (Placement _ (Location colOffset rowOffset) orientation, struc)
-  (MergedStructure inputArea waypointsMap) =
+  (p@(Placement _ loc@(Location colOffset rowOffset) orientation), struc)
+  (MergedStructure inputArea inputWaypoints) =
     MergedStructure mergedArea mergedWaypoints
    where
     mergedArea = zipWithPad mergeSingleRow inputArea paddedOverlayRows
-    mergedWaypoints = M.union waypointsMap $
-      M.map (applyLocOffset $ V2 colOffset rowOffset) overlayWaypoints
 
-    applyLocOffset locOffset originalLoc = originalLoc .+^ locOffset
+    mergedWaypoints = inputWaypoints ++ map (fmap $ applyLocOffset $ coerce loc) overlayWaypoints
+
+    applyLocOffset locOffset (Waypoint n originalLoc) = Waypoint n $ originalLoc .+^ locOffset
 
     zipWithPad f a b = zipWith f a $ b <> repeat Nothing
 
-    MergedStructure overlayArea overlayWaypoints = mergeStructures inheritedStrucDefs struc
+    MergedStructure overlayArea overlayWaypoints = mergeStructures inheritedStrucDefs (Overlay p) struc
     affineTransformedOverlay = getTransform orientation overlayArea
 
     mergeSingleRow inputRow maybeOverlayRow =
@@ -125,13 +135,14 @@ overlaySingleStructure
 -- | Overlays all of the "child placements", such that the
 -- earlier children supersede the later ones (due to use of "foldr" instead of "foldl").
 mergeStructures ::
-     M.Map StructureName (PStructure (Maybe a))
-  -> PStructure (Maybe a)
-  -> MergedStructure (Maybe a)
-mergeStructures inheritedStrucDefs (Structure origArea subStructures subPlacements subWaypoints) =
-  foldr (overlaySingleStructure structureMap) (MergedStructure origArea subWaypointsMap) overlays
+  M.Map StructureName (PStructure (Maybe a)) ->
+  PlacementSource ->
+  PStructure (Maybe a) ->
+  MergedStructure (Maybe a)
+mergeStructures inheritedStrucDefs placementSource (Structure origArea subStructures subPlacements subWaypoints) =
+  foldr (overlaySingleStructure structureMap) (MergedStructure origArea originatedWaypoints) overlays
  where
-  subWaypointsMap = M.fromList $ map (\(Waypoint n loc) -> (n, loc)) subWaypoints
+  originatedWaypoints = map (Originated placementSource) subWaypoints
 
   -- deeper definitions override the outer (toplevel) ones
   structureMap = M.union (M.fromList $ map (name &&& structure) subStructures) inheritedStrucDefs
@@ -167,7 +178,7 @@ data Placement = Placement
   , offset :: Location
   , orient :: Orientation
   }
-  deriving (Eq, Show)
+  deriving (Show, Eq)
 
 instance FromJSON Placement where
   parseJSON = withObject "structure placement" $ \v -> do

src/Swarm/Game/Scenario/Subworld.hs

@@ -5,11 +5,11 @@
 module Swarm.Game.Scenario.Subworld where
 
 import Data.Aeson
-import Swarm.Game.Scenario.Structure
 import Data.Text (Text)
 import GHC.Generics (Generic)
 import Swarm.Game.Entity
 import Swarm.Game.Scenario.RobotLookup
+import Swarm.Game.Scenario.Structure
 import Swarm.Game.Scenario.WorldDescription
 import Swarm.Util.Yaml
 

src/Swarm/Game/Scenario/WorldDescription.hs

@@ -46,7 +46,11 @@ instance FromJSONE (EntityMap, RobotMap) WorldDescription where
     initialArea <- liftE ((v .:? "map" .!= "") >>= Structure.paintMap Nothing pal)
 
     let struc = Structure.Structure initialArea structureDefs placementDefs waypointDefs
-        Structure.MergedStructure mergedArea mergedWaypoints = Structure.mergeStructures mempty struc
+        Structure.MergedStructure mergedArea unmergedWaypoints = Structure.mergeStructures mempty Structure.Root struc
+
+    -- TODO: Throw error upon overwrites
+    -- TODO: Add unit test for parse validation
+    let mergedWaypoints = M.fromList $ map (\(Structure.Originated _ (Structure.Waypoint n loc)) -> (n, loc)) unmergedWaypoints
 
     WorldDescription
       <$> v ..:? "default"

src/Swarm/Game/State.hs

@@ -60,6 +60,7 @@ module Swarm.Game.State (
   recipesReq,
   currentScenarioPath,
   knownEntities,
+  worldWaypoints,
   world,
   worldScrollable,
   viewCenterRule,
@@ -130,6 +131,7 @@ import Control.Monad.Except
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Array (Array, listArray)
 import Data.Bifunctor (first)
+import Data.Coerce
 import Data.Digest.Pure.SHA (sha1, showDigest)
 import Data.Foldable (toList)
 import Data.Int (Int32)
@@ -169,6 +171,7 @@ import Swarm.Game.Recipe (
 import Swarm.Game.Robot
 import Swarm.Game.Scenario.Objective
 import Swarm.Game.Scenario.Status
+import Swarm.Game.Scenario.Structure (WaypointName)
 import Swarm.Game.ScenarioInfo
 import Swarm.Game.Terrain (TerrainType (..))
 import Swarm.Game.World (Coords (..), WorldFun (..), locToCoords, worldFunFromArray)
@@ -398,6 +401,7 @@ data GameState = GameState
   , _recipesReq :: IntMap [Recipe Entity]
   , _currentScenarioPath :: Maybe FilePath
   , _knownEntities :: [Text]
+  , _worldWaypoints :: M.Map WaypointName Location
   , _world :: W.World Int Entity
   , _worldScrollable :: Bool
   , _viewCenterRule :: ViewCenterRule
@@ -559,6 +563,9 @@ currentScenarioPath :: Lens' GameState (Maybe FilePath)
 --   robots know what they are without having to scan them.
 knownEntities :: Lens' GameState [Text]
 
+-- | Dictionary of named locations
+worldWaypoints :: Lens' GameState (M.Map WaypointName Location)
+
 -- | The current state of the world (terrain and entities only; robots
 --   are stored in the 'robotMap').  Int is used instead of
 --   TerrainType because we need to be able to store terrain values in
@@ -995,6 +1002,7 @@ initGameState gsc =
     , _recipesReq = reqRecipeMap (initRecipes gsc)
     , _currentScenarioPath = Nothing
     , _knownEntities = []
+    , _worldWaypoints = mempty
     , _world = W.emptyWorld (fromEnum StoneT)
     , _worldScrollable = True
     , _viewCenterRule = VCRobot 0
@@ -1051,6 +1059,7 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun))
       & recipesIn %~ addRecipesWith inRecipeMap
       & recipesReq %~ addRecipesWith reqRecipeMap
       & knownEntities .~ scenario ^. scenarioKnown
+      & worldWaypoints .~ getCorrectedWaypoints (scenario ^. scenarioWorld)
       & world .~ theWorld theSeed
       & worldScrollable .~ scenario ^. scenarioWorld . to scrollable
       & viewCenterRule .~ VCRobot baseID
@@ -1060,6 +1069,11 @@ scenarioToGameState scenario (LaunchParams (Identity userSeed) (Identity toRun))
         True -> REPLWorking (Typed Nothing PolyUnit mempty)
       & robotStepsPerTick .~ ((scenario ^. scenarioStepsPerTick) ? defaultRobotStepsPerTick)
  where
+  getCorrectedWaypoints w =
+    M.map (.+^ offset) (waypoints w)
+   where
+    offset = coerce $ ul w
+
   em = initEntities gsc <> scenario ^. scenarioEntities
   baseID = 0
   (things, devices) = partition (null . view entityCapabilities) (M.elems (entitiesByName em))

src/Swarm/Game/Step.hs

@@ -74,6 +74,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.Structure (WaypointName (..))
 import Swarm.Game.State
 import Swarm.Game.Value
 import Swarm.Game.World qualified as W
@@ -1398,9 +1399,13 @@ execConst c vs s k = do
     Whereami -> do
       loc <- use robotLocation
       return $ Out (asValue loc) s k
-    Waypoint -> do
-      loc <- use robotLocation
-      return $ Out (asValue loc) s k
+    Waypoint -> case vs of
+      [VText name] -> do
+        wps <- use worldWaypoints
+        case M.lookup (WaypointName name) wps of
+          Nothing -> throwError $ CmdFailed Waypoint (T.unwords ["No waypoint named", name]) Nothing
+          Just wp -> return $ Out (asValue wp) s k
+      _ -> badConst
     Detect -> case vs of
       [VText name, VRect x1 y1 x2 y2] -> do
         loc <- use robotLocation

src/Swarm/Language/Syntax.hs

@@ -666,7 +666,7 @@ constInfo c = case c of
       , T.unwords ["Has a max range of", T.pack $ show maxScoutRange, "units."]
       ]
   Whereami -> command 0 Intangible "Get the current x and y coordinates."
-  Waypoint -> command 0 Intangible "Get the x, y coordinates of a named waypoint."
+  Waypoint -> command 1 Intangible "Get the x, y coordinates of a named waypoint."
   Detect ->
     command 2 Intangible . doc "Detect an entity within a rectangle." $
       ["Locate the closest instance of a given entity within the rectangle specified by opposite corners, relative to the current location."]

src/Swarm/Language/Typecheck.hs

@@ -731,7 +731,7 @@ inferConst c = case c of
   Time -> [tyQ| cmd int |]
   Scout -> [tyQ| dir -> cmd bool |]
   Whereami -> [tyQ| cmd (int * int) |]
-  Waypoint -> [tyQ| cmd (int * int) |]
+  Waypoint -> [tyQ| text -> cmd (int * int) |]
   Detect -> [tyQ| text -> ((int * int) * (int * int)) -> cmd (unit + (int * int)) |]
   Resonate -> [tyQ| text -> ((int * int) * (int * int)) -> cmd int |]
   Density -> [tyQ| ((int * int) * (int * int)) -> cmd int |]