Automatic re-orientation via portal

data/scenarios/Testing/00-ORDER.txt

@@ -39,3 +39,4 @@
 1138-structures
 1356-portals
 144-subworlds
+1379-single-world-portal-reorientation.yaml

data/scenarios/Testing/1379-single-world-portal-reorientation.yaml

@@ -0,0 +1,101 @@
+version: 1
+name: Portal reorientation within a single subworld
+description: |
+  Turning without turning
+attrs:
+  - name: portal_in
+    fg: "#ff9a00"
+    bg: "#ff5d00"
+objectives:
+  - goal:
+    - |
+      `place` the "flower" on the white cell.
+    condition: |
+      j <- robotnamed "judge";
+      as j {ishere "flower"}
+solution: |
+    def doN = \n. \f. if (n > 0) {f; doN (n - 1) f} {}; end;
+    doN 23 move;
+    f <- grab;
+    doN 23 move;
+    place f;
+entities:
+  - name: telepad entrance
+    display:
+      attr: portal_in
+      char: "o"
+    description:
+    - Portal entrance
+    properties: [known]
+robots:
+  - name: base
+    dir: [0, 1]
+    devices:
+      - branch predictor
+      - calculator
+      - comparator
+      - dictionary
+      - grabber
+      - lambda
+      - logger
+      - strange loop
+      - treads
+  - name: judge
+    dir: [1, 0]
+    system: true
+    display:
+      char: 'J'
+      invisible: true
+known: [flower]
+world:
+  name: root
+  default: [blank]
+  palette:
+    '.': [grass]
+    'f': [grass, flower]
+    'g': [ice, null, judge]
+    'B': [grass, null, base]
+    '0':
+      cell: [grass, telepad entrance]
+      waypoint:
+        name: wp0
+    '1':
+      cell: [grass, telepad entrance]
+      waypoint:
+        name: wp1
+    '2':
+      cell: [grass, telepad entrance]
+      waypoint:
+        name: wp2
+    '3':
+      cell: [grass, telepad entrance]
+      waypoint:
+        name: wp3
+  upperleft: [-1, 1]
+  portals:
+    - entrance: wp0
+      exitInfo:
+        exit: wp0
+      reorient: right
+    - entrance: wp1
+      exitInfo:
+        exit: wp1
+      reorient: right
+    - entrance: wp2
+      exitInfo:
+        exit: wp2
+      reorient: right
+    - entrance: wp3
+      exitInfo:
+        exit: wp3
+      reorient: right
+  map: |
+    .........
+    .1.....2.
+    .........
+    .B.......
+    .f.......
+    .g.......
+    .........
+    .0.....3.
+    .........

data/scenarios/Testing/144-subworlds/spatial-consistency-enforcement.yaml

@@ -61,6 +61,7 @@ subworlds:
           exit: portal_out1
           subworldName: root
         consistent: true
+        reorient: back
     upperleft: [-1, 1]
     map: |
       b..b..b..b
@@ -87,6 +88,7 @@ world:
         exit: portal_out2
         subworldName: underground
       consistent: true
+      reorient: back
   map: |
     ..........
     .p.B....P.

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

@@ -26,13 +26,15 @@ import Linear (V2, negated)
 import Swarm.Game.Location
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint
 import Swarm.Game.Universe
+import Swarm.Language.Direction
 import Swarm.Util (allEqual, binTuples, both, failT, quote, showT)
 
 type WaypointMap = M.Map WaypointName (NonEmpty Location)
 
 data AnnotatedDestination a = AnnotatedDestination
   { enforceConsistency :: Bool
-  , cosmoLocation :: Cosmic a
+  , reorientation :: Direction
+  , destination :: Cosmic a
   }
   deriving (Show, Eq)
 
@@ -72,6 +74,7 @@ data Portal = Portal
   { entrance :: WaypointName
   , exitInfo :: PortalExit
   , consistent :: Bool
+  , reorient :: PlanarRelativeDir
   }
   deriving (Show, Eq)
 
@@ -83,6 +86,7 @@ instance FromJSON Portal where
       <*> v
         .: "exitInfo"
       <*> v .:? "consistent" .!= False
+      <*> v .:? "reorient" .!= DForward
 
 failUponDuplication ::
   (MonadFail m, Show a, Show b) =>
@@ -136,15 +140,16 @@ 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) isConsistent) -> do
+  nestedPortalPairs <- forM portalDefs $ \p -> do
+    let Portal entranceName (PortalExit exitName maybeExitSubworldName) isConsistent reOrient = p
     -- 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 = (,AnnotatedDestination isConsistent $ Cosmic sw exitName) . extractLoc
+        f = (,AnnotatedDestination isConsistent (DRelative $ DPlanar reOrient) $ Cosmic sw exitName) . extractLoc
     return $ map f $ NE.toList entranceLocs
 
   let reconciledPortalPairs = concat nestedPortalPairs
@@ -173,15 +178,15 @@ validatePortals ::
   Navigation (M.Map SubworldName) WaypointName ->
   m (M.Map (Cosmic Location) (AnnotatedDestination Location))
 validatePortals (Navigation wpUniverse partialPortals) = do
-  portalPairs <- forM (M.toList partialPortals) $ \(portalEntrance, AnnotatedDestination isConsistent portalExit@(Cosmic swName (WaypointName rawExitName))) -> do
+  portalPairs <- forM (M.toList partialPortals) $ \(portalEntrance, AnnotatedDestination isConsistent reOrient portalExit@(Cosmic swName (WaypointName rawExitName))) -> do
     firstExitLoc :| otherExits <- getLocs portalExit
     unless (null otherExits) $
       failT
         [ "Ambiguous exit waypoints named"
         , quote rawExitName
         , "for portal"
         ]
-    return (portalEntrance, AnnotatedDestination isConsistent $ Cosmic swName firstExitLoc)
+    return (portalEntrance, AnnotatedDestination isConsistent reOrient $ Cosmic swName firstExitLoc)
 
   ensureSpatialConsistency portalPairs
 
@@ -228,7 +233,7 @@ ensureSpatialConsistency xs =
       ]
  where
   consistentPairs :: [(Cosmic Location, Cosmic Location)]
-  consistentPairs = map (fmap cosmoLocation) $ filter (enforceConsistency . snd) xs
+  consistentPairs = map (fmap destination) $ filter (enforceConsistency . snd) xs
 
   interWorldPairs :: [(Cosmic Location, Cosmic Location)]
   interWorldPairs = filter (uncurry ((/=) `on` view subworld)) consistentPairs

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 (..), cosmoLocation)
+import Swarm.Game.Scenario.Topography.Navigation.Portal (Navigation (..), destination, reorientation)
 import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointName (..))
 import Swarm.Game.State
 import Swarm.Game.Universe
@@ -2753,7 +2753,12 @@ updateRobotLocation oldLoc newLoc
  where
   applyPortal loc = do
     lms <- use worldNavigation
-    return . M.findWithDefault loc loc . M.map cosmoLocation $ portals lms
+    let maybePortalInfo = M.lookup loc $ portals lms
+        updatedLoc = maybe loc destination maybePortalInfo
+        maybeTurn = reorientation <$> maybePortalInfo
+    forM_ maybeTurn $ \d ->
+      robotOrientation . _Just %= applyTurn d
+    return updatedLoc
 
 -- | Execute a stateful action on a target robot --- whether the
 --   current one or another.

src/Swarm/Language/Direction.hs

@@ -0,0 +1,116 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+--
+-- Types and helper functions for working with directions
+module Swarm.Language.Direction (
+  -- * Directions
+  Direction (..),
+  AbsoluteDir (..),
+  RelativeDir (..),
+  PlanarRelativeDir (..),
+  directionSyntax,
+  isCardinal,
+  allDirs,
+) where
+
+import Data.Aeson.Types hiding (Key)
+import Data.Char qualified as C (toLower)
+import Data.Data (Data)
+import Data.Hashable (Hashable)
+import Data.List qualified as L (tail)
+import Data.Text hiding (filter, length, map)
+import Data.Text qualified as T
+import GHC.Generics (Generic)
+import Swarm.Util qualified as Util
+import Witch.From (from)
+
+------------------------------------------------------------
+-- Directions
+------------------------------------------------------------
+
+-- | An absolute direction is one which is defined with respect to an
+--   external frame of reference; robots need a compass in order to
+--   use them.
+--
+-- NOTE: These values are ordered by increasing angle according to
+-- the standard mathematical convention.
+-- That is, the right-pointing direction, East, is considered
+-- the "reference angle" and the order proceeds counter-clockwise.
+-- See https://en.wikipedia.org/wiki/Polar_coordinate_system#Conventions
+--
+-- Do not alter this ordering, as there exist functions that depend on it
+-- (e.g. "nearestDirection" and "relativeTo").
+data AbsoluteDir = DEast | DNorth | DWest | DSouth
+  deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, Enum, Bounded)
+
+directionJsonModifier :: String -> String
+directionJsonModifier = map C.toLower . L.tail
+
+directionJsonOptions :: Options
+directionJsonOptions =
+  defaultOptions
+    { constructorTagModifier = directionJsonModifier
+    }
+
+instance FromJSON AbsoluteDir where
+  parseJSON = genericParseJSON directionJsonOptions
+
+instance ToJSON AbsoluteDir where
+  toJSON = genericToJSON directionJsonOptions
+
+cardinalDirectionKeyOptions :: JSONKeyOptions
+cardinalDirectionKeyOptions =
+  defaultJSONKeyOptions
+    { keyModifier = directionJsonModifier
+    }
+
+instance ToJSONKey AbsoluteDir where
+  toJSONKey = genericToJSONKey cardinalDirectionKeyOptions
+
+instance FromJSONKey AbsoluteDir where
+  fromJSONKey = genericFromJSONKey cardinalDirectionKeyOptions
+
+-- | A relative direction is one which is defined with respect to the
+--   robot's frame of reference; no special capability is needed to
+--   use them.
+data RelativeDir = DPlanar PlanarRelativeDir | DDown
+  deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, ToJSON, FromJSON)
+
+-- | Caution: Do not alter this ordering, as there exist functions that depend on it
+-- (e.g. "nearestDirection" and "relativeTo").
+data PlanarRelativeDir = DForward | DLeft | DBack | DRight
+  deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, Enum, Bounded)
+
+instance FromJSON PlanarRelativeDir where
+  parseJSON = genericParseJSON directionJsonOptions
+
+instance ToJSON PlanarRelativeDir where
+  toJSON = genericToJSON directionJsonOptions
+
+-- | The type of directions. Used /e.g./ to indicate which way a robot
+--   will turn.
+data Direction = DAbsolute AbsoluteDir | DRelative RelativeDir
+  deriving (Eq, Ord, Show, Read, Generic, Data, Hashable, ToJSON, FromJSON)
+
+-- | Direction name is generated from the deepest nested data constructor
+-- e.g. DLeft becomes "left"
+directionSyntax :: Direction -> Text
+directionSyntax d = toLower . T.tail . from $ case d of
+  DAbsolute x -> show x
+  DRelative x -> case x of
+    DPlanar y -> show y
+    _ -> show x
+
+-- | Check if the direction is absolute (e.g. 'north' or 'south').
+isCardinal :: Direction -> Bool
+isCardinal = \case
+  DAbsolute _ -> True
+  _ -> False
+
+allDirs :: [Direction]
+allDirs = map DAbsolute Util.listEnums <> map DRelative (DDown : map DPlanar Util.listEnums)