{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Type definitions and validation logic for portals.
--
-- Portals can be inter-world or intra-world.
-- It is legal for a portal exit to be on the same cell as its entrance.
--
-- By default, passage through a portal preserves the orientation
-- of the robot, but an extra portal parameter can specify
-- that the robot should be re-oriented.
module Swarm.Game.Scenario.Topography.Navigation.Portal where

import Control.Arrow ((&&&))
import Control.Lens (view)
import Control.Monad (forM, forM_, unless)
import Data.Aeson
import Data.Bifunctor (first)
import Data.BoolExpr (Signed (..))
import Data.Function (on)
import Data.Functor.Identity
import Data.Int (Int32)
import Data.List.NonEmpty (NonEmpty ((:|)))
import Data.List.NonEmpty qualified as NE
import Data.Map (Map)
import Data.Map qualified as M
import Data.Maybe (fromMaybe, listToMaybe)
import Data.Text qualified as T
import Data.Tuple (swap)
import GHC.Generics (Generic)
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
  { forall a. AnnotatedDestination a -> Bool
enforceConsistency :: Bool
  , forall a. AnnotatedDestination a -> Direction
reorientation :: Direction
  , forall a. AnnotatedDestination a -> Cosmic a
destination :: Cosmic a
  }
  deriving (Int -> AnnotatedDestination a -> ShowS
forall a. Show a => Int -> AnnotatedDestination a -> ShowS
forall a. Show a => [AnnotatedDestination a] -> ShowS
forall a. Show a => AnnotatedDestination a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AnnotatedDestination a] -> ShowS
$cshowList :: forall a. Show a => [AnnotatedDestination a] -> ShowS
show :: AnnotatedDestination a -> String
$cshow :: forall a. Show a => AnnotatedDestination a -> String
showsPrec :: Int -> AnnotatedDestination a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> AnnotatedDestination a -> ShowS
Show, AnnotatedDestination a -> AnnotatedDestination a -> Bool
forall a.
Eq a =>
AnnotatedDestination a -> AnnotatedDestination a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AnnotatedDestination a -> AnnotatedDestination a -> Bool
$c/= :: forall a.
Eq a =>
AnnotatedDestination a -> AnnotatedDestination a -> Bool
== :: AnnotatedDestination a -> AnnotatedDestination a -> Bool
$c== :: forall a.
Eq a =>
AnnotatedDestination a -> AnnotatedDestination a -> Bool
Eq)

-- | Parameterized on waypoint dimensionality ('additionalDimension') and
-- on the portal location specification method ('portalExitLoc').
--
-- == @additionalDimension@
-- As a member of the 'Swarm.Game.Scenario.Topography.WorldDescription.WorldDescription', waypoints are only known within a
-- a single subworld, so 'additionalDimension' is 'Identity' for the map
-- of waypoint names to planar locations.
-- At the Scenario level, in contrast, we have access to all subworlds, so
-- we nest this map to planar locations in additional mapping layer by subworld.
--
-- == @portalExitLoc@
-- At the subworld parsing level, we only can obtain the planar location
-- for portal /entrances/, but the /exits/ remain as waypoint names.
-- 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 additionalDimension portalExitLoc = Navigation
  { forall (additionalDimension :: * -> *) portalExitLoc.
Navigation additionalDimension portalExitLoc
-> additionalDimension WaypointMap
waypoints :: additionalDimension 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).
  , forall (additionalDimension :: * -> *) portalExitLoc.
Navigation additionalDimension portalExitLoc
-> Map (Cosmic Location) (AnnotatedDestination portalExitLoc)
portals :: M.Map (Cosmic Location) (AnnotatedDestination portalExitLoc)
  }

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
  { PortalExit -> WaypointName
exit :: WaypointName
  , PortalExit -> Maybe SubworldName
subworldName :: Maybe SubworldName
  -- ^ Note: 'Nothing' indicates that references a waypoint within the same subworld.
  }
  deriving (Int -> PortalExit -> ShowS
[PortalExit] -> ShowS
PortalExit -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PortalExit] -> ShowS
$cshowList :: [PortalExit] -> ShowS
show :: PortalExit -> String
$cshow :: PortalExit -> String
showsPrec :: Int -> PortalExit -> ShowS
$cshowsPrec :: Int -> PortalExit -> ShowS
Show, PortalExit -> PortalExit -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PortalExit -> PortalExit -> Bool
$c/= :: PortalExit -> PortalExit -> Bool
== :: PortalExit -> PortalExit -> Bool
$c== :: PortalExit -> PortalExit -> Bool
Eq, forall x. Rep PortalExit x -> PortalExit
forall x. PortalExit -> Rep PortalExit x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PortalExit x -> PortalExit
$cfrom :: forall x. PortalExit -> Rep PortalExit x
Generic, Value -> Parser [PortalExit]
Value -> Parser PortalExit
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [PortalExit]
$cparseJSONList :: Value -> Parser [PortalExit]
parseJSON :: Value -> Parser PortalExit
$cparseJSON :: Value -> Parser PortalExit
FromJSON)

data Portal = Portal
  { Portal -> WaypointName
entrance :: WaypointName
  , Portal -> PortalExit
exitInfo :: PortalExit
  , Portal -> Bool
consistent :: Bool
  , Portal -> PlanarRelativeDir
reorient :: PlanarRelativeDir
  }
  deriving (Int -> Portal -> ShowS
[Portal] -> ShowS
Portal -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Portal] -> ShowS
$cshowList :: [Portal] -> ShowS
show :: Portal -> String
$cshow :: Portal -> String
showsPrec :: Int -> Portal -> ShowS
$cshowsPrec :: Int -> Portal -> ShowS
Show, Portal -> Portal -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Portal -> Portal -> Bool
$c/= :: Portal -> Portal -> Bool
== :: Portal -> Portal -> Bool
$c== :: Portal -> Portal -> Bool
Eq)

instance FromJSON Portal where
  parseJSON :: Value -> Parser Portal
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Portal" forall a b. (a -> b) -> a -> b
$ \Object
v ->
    WaypointName -> PortalExit -> Bool -> PlanarRelativeDir -> Portal
Portal
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v
        forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"entrance"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v
        forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"exitInfo"
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"consistent" forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"reorient" forall a. Parser (Maybe a) -> a -> Parser a
.!= PlanarRelativeDir
DForward

failUponDuplication ::
  (MonadFail m, Show a, Show b) =>
  T.Text ->
  M.Map a (NonEmpty b) ->
  m ()
failUponDuplication :: forall (m :: * -> *) a b.
(MonadFail m, Show a, Show b) =>
Text -> Map a (NonEmpty b) -> m ()
failUponDuplication Text
message Map a (NonEmpty b)
binnedMap =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
M.toList Map a (NonEmpty b)
duplicated) forall a b. (a -> b) -> a -> b
$ \(a
pIn, NonEmpty b
pOuts) ->
    forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT
      [ Text
"Waypoint"
      , forall a. Show a => a -> Text
showT a
pIn
      , Text
message
      , Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Text
showT forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
pOuts
      ]
 where
  duplicated :: Map a (NonEmpty b)
duplicated = forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter ((forall a. Ord a => a -> a -> Bool
> Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> Int
NE.length) Map a (NonEmpty b)
binnedMap

failWaypointLookup :: MonadFail m => WaypointName -> Maybe a -> m a
failWaypointLookup :: forall (m :: * -> *) a.
MonadFail m =>
WaypointName -> Maybe a -> m a
failWaypointLookup (WaypointName Text
rawName) =
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT [Text
"No waypoint named", Text -> Text
quote Text
rawName]) forall (m :: * -> *) a. Monad m => a -> m a
return

-- |
-- 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
-- * 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 'Swarm.Game.Scenario.Topography.WorldDescription.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-'Swarm.Game.Scenario.Topography.WorldDescription.WorldDescription' level whether
--   that waypoint has plural multiplicity.
validatePartialNavigation ::
  (MonadFail m, Traversable t) =>
  SubworldName ->
  Location ->
  [Originated Waypoint] ->
  t Portal ->
  m (Navigation Identity WaypointName)
validatePartialNavigation :: forall (m :: * -> *) (t :: * -> *).
(MonadFail m, Traversable t) =>
SubworldName
-> Location
-> [Originated Waypoint]
-> t Portal
-> m (Navigation Identity WaypointName)
validatePartialNavigation SubworldName
currentSubworldName Location
upperLeft [Originated Waypoint]
unmergedWaypoints t Portal
portalDefs = do
  forall (m :: * -> *) a b.
(MonadFail m, Show a, Show b) =>
Text -> Map a (NonEmpty b) -> m ()
failUponDuplication Text
"is required to be unique, but is duplicated in:" Map WaypointName (NonEmpty (Originated Waypoint))
waypointsWithUniqueFlag

  t [(Location, AnnotatedDestination WaypointName)]
nestedPortalPairs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM t Portal
portalDefs forall a b. (a -> b) -> a -> b
$ \Portal
p -> do
    let Portal WaypointName
entranceName (PortalExit WaypointName
exitName Maybe SubworldName
maybeExitSubworldName) Bool
isConsistent PlanarRelativeDir
reOrient = Portal
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.
    NonEmpty (Originated Waypoint)
entranceLocs <- forall {m :: * -> *}.
MonadFail m =>
WaypointName -> m (NonEmpty (Originated Waypoint))
getLocs WaypointName
entranceName

    let sw :: SubworldName
sw = forall a. a -> Maybe a -> a
fromMaybe SubworldName
currentSubworldName Maybe SubworldName
maybeExitSubworldName
        f :: Originated Waypoint
-> (Location, AnnotatedDestination WaypointName)
f = (,forall a. Bool -> Direction -> Cosmic a -> AnnotatedDestination a
AnnotatedDestination Bool
isConsistent (RelativeDir -> Direction
DRelative forall a b. (a -> b) -> a -> b
$ PlanarRelativeDir -> RelativeDir
DPlanar PlanarRelativeDir
reOrient) forall a b. (a -> b) -> a -> b
$ forall a. SubworldName -> a -> Cosmic a
Cosmic SubworldName
sw WaypointName
exitName) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Originated Waypoint -> Location
extractLoc
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Originated Waypoint
-> (Location, AnnotatedDestination WaypointName)
f forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Originated Waypoint)
entranceLocs

  let reconciledPortalPairs :: [(Location, AnnotatedDestination WaypointName)]
reconciledPortalPairs = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat t [(Location, AnnotatedDestination WaypointName)]
nestedPortalPairs

  -- Aside from the enforcement of single-exit per portal, we apply another layer of
  -- enforcement to ensure that no two portals share the same entrance location
  forall (m :: * -> *) a b.
(MonadFail m, Show a, Show b) =>
Text -> Map a (NonEmpty b) -> m ()
failUponDuplication Text
"has overlapping portal entrances exiting to" forall a b. (a -> b) -> a -> b
$
    forall (t :: * -> *) a b.
(Foldable t, Ord a) =>
t (a, b) -> Map a (NonEmpty b)
binTuples [(Location, AnnotatedDestination WaypointName)]
reconciledPortalPairs

  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (additionalDimension :: * -> *) portalExitLoc.
additionalDimension WaypointMap
-> Map (Cosmic Location) (AnnotatedDestination portalExitLoc)
-> Navigation additionalDimension portalExitLoc
Navigation (forall (f :: * -> *) a. Applicative f => a -> f a
pure WaypointMap
bareWaypoints) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => [(k, a)] -> Map k a
M.fromList forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a b. (a -> b) -> a -> b
$ forall a. SubworldName -> a -> Cosmic a
Cosmic SubworldName
currentSubworldName) [(Location, AnnotatedDestination WaypointName)]
reconciledPortalPairs
 where
  getLocs :: WaypointName -> m (NonEmpty (Originated Waypoint))
getLocs WaypointName
wpWrapper = forall (m :: * -> *) a.
MonadFail m =>
WaypointName -> Maybe a -> m a
failWaypointLookup WaypointName
wpWrapper forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup WaypointName
wpWrapper Map WaypointName (NonEmpty (Originated Waypoint))
correctedWaypoints

  extractLoc :: Originated Waypoint -> Location
extractLoc (Originated Maybe Placement
_ (Waypoint WaypointConfig
_ Location
loc)) = Location
loc
  correctedWaypoints :: Map WaypointName (NonEmpty (Originated Waypoint))
correctedWaypoints =
    forall (t :: * -> *) a b.
(Foldable t, Ord a) =>
t (a, b) -> Map a (NonEmpty b)
binTuples forall a b. (a -> b) -> a -> b
$
      forall a b. (a -> b) -> [a] -> [b]
map
        (\Originated Waypoint
x -> (WaypointConfig -> WaypointName
wpName forall a b. (a -> b) -> a -> b
$ Waypoint -> WaypointConfig
wpConfig forall a b. (a -> b) -> a -> b
$ forall a. Originated a -> a
value Originated Waypoint
x, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (V2 Int32 -> Waypoint -> Waypoint
offsetWaypoint forall a b. (a -> b) -> a -> b
$ Location
upperLeft forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
.-. forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin) Originated Waypoint
x))
        [Originated Waypoint]
unmergedWaypoints
  bareWaypoints :: WaypointMap
bareWaypoints = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map Originated Waypoint -> Location
extractLoc) Map WaypointName (NonEmpty (Originated Waypoint))
correctedWaypoints
  waypointsWithUniqueFlag :: Map WaypointName (NonEmpty (Originated Waypoint))
waypointsWithUniqueFlag = forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall a b. (a -> b) -> a -> b
$ WaypointConfig -> Bool
wpUnique forall b c a. (b -> c) -> (a -> b) -> a -> c
. Waypoint -> WaypointConfig
wpConfig forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Originated a -> a
value) Map WaypointName (NonEmpty (Originated Waypoint))
correctedWaypoints

validatePortals ::
  MonadFail m =>
  Navigation (M.Map SubworldName) WaypointName ->
  m (M.Map (Cosmic Location) (AnnotatedDestination Location))
validatePortals :: forall (m :: * -> *).
MonadFail m =>
Navigation (Map SubworldName) WaypointName
-> m (Map (Cosmic Location) (AnnotatedDestination Location))
validatePortals (Navigation Map SubworldName WaypointMap
wpUniverse Map (Cosmic Location) (AnnotatedDestination WaypointName)
partialPortals) = do
  [(Cosmic Location, AnnotatedDestination Location)]
portalPairs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall k a. Map k a -> [(k, a)]
M.toList Map (Cosmic Location) (AnnotatedDestination WaypointName)
partialPortals) forall a b. (a -> b) -> a -> b
$ \(Cosmic Location
portalEntrance, AnnotatedDestination Bool
isConsistent Direction
reOrient portalExit :: Cosmic WaypointName
portalExit@(Cosmic SubworldName
swName (WaypointName Text
rawExitName))) -> do
    Location
firstExitLoc :| [Location]
otherExits <- forall {m :: * -> *}.
MonadFail m =>
Cosmic WaypointName -> m (NonEmpty Location)
getLocs Cosmic WaypointName
portalExit
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Location]
otherExits) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT
        [ Text
"Ambiguous exit waypoints named"
        , Text -> Text
quote Text
rawExitName
        , Text
"for portal"
        ]
    forall (m :: * -> *) a. Monad m => a -> m a
return (Cosmic Location
portalEntrance, forall a. Bool -> Direction -> Cosmic a -> AnnotatedDestination a
AnnotatedDestination Bool
isConsistent Direction
reOrient forall a b. (a -> b) -> a -> b
$ forall a. SubworldName -> a -> Cosmic a
Cosmic SubworldName
swName Location
firstExitLoc)

  forall (m :: * -> *).
MonadFail m =>
[(Cosmic Location, AnnotatedDestination Location)] -> m ()
ensureSpatialConsistency [(Cosmic Location, AnnotatedDestination Location)]
portalPairs

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Cosmic Location, AnnotatedDestination Location)]
portalPairs
 where
  getLocs :: Cosmic WaypointName -> m (NonEmpty Location)
getLocs (Cosmic SubworldName
swName wpWrapper :: WaypointName
wpWrapper@(WaypointName Text
exitName)) = do
    WaypointMap
subworldWaypoints <- case forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup SubworldName
swName Map SubworldName WaypointMap
wpUniverse of
      Just WaypointMap
x -> forall (m :: * -> *) a. Monad m => a -> m a
return WaypointMap
x
      Maybe WaypointMap
Nothing ->
        forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT
          [ Text
"Could not lookup waypoint"
          , Text -> Text
quote Text
exitName
          , Text
"for portal exit because subworld"
          , Text -> Text
quote forall a b. (a -> b) -> a -> b
$ SubworldName -> Text
renderWorldName SubworldName
swName
          , Text
"does not exist"
          ]

    forall (m :: * -> *) a.
MonadFail m =>
WaypointName -> Maybe a -> m a
failWaypointLookup WaypointName
wpWrapper forall a b. (a -> b) -> a -> b
$
      forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup WaypointName
wpWrapper WaypointMap
subworldWaypoints

-- | A portal can be marked as \"consistent\", meaning that it represents
-- a conventional physical passage rather than a \"magical\" teleportation.
--
-- If there exists more than one \"consistent\" portal between the same
-- two subworlds, then the portal locations must be spatially consistent
-- between the two worlds. I.e. the space comprising the two subworlds
-- forms a "conservative vector field".
--
-- Verifying this is simple:
-- For all of the portals between Subworlds A and B:
--
-- * The coordinates of all \"consistent\" portal locations in Subworld A
--   are subtracted from the corresponding coordinates in Subworld B. It
--   does not matter which are exits vs. entrances.
-- * The resulting \"vector\" from every pair must be equal.
ensureSpatialConsistency ::
  MonadFail m =>
  [(Cosmic Location, AnnotatedDestination Location)] ->
  m ()
ensureSpatialConsistency :: forall (m :: * -> *).
MonadFail m =>
[(Cosmic Location, AnnotatedDestination Location)] -> m ()
ensureSpatialConsistency [(Cosmic Location, AnnotatedDestination Location)]
xs =
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))
nonUniform) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT
      [ Text
"Non-uniform portal distances:"
      , forall a. Show a => a -> Text
showT Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))
nonUniform
      ]
 where
  consistentPairs :: [(Cosmic Location, Cosmic Location)]
  consistentPairs :: [(Cosmic Location, Cosmic Location)]
consistentPairs = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. AnnotatedDestination a -> Cosmic a
destination) forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. AnnotatedDestination a -> Bool
enforceConsistency forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(Cosmic Location, AnnotatedDestination Location)]
xs

  interWorldPairs :: [(Cosmic Location, Cosmic Location)]
  interWorldPairs :: [(Cosmic Location, Cosmic Location)]
interWorldPairs = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall a. Eq a => a -> a -> Bool
(/=) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (Cosmic a) SubworldName
subworld)) [(Cosmic Location, Cosmic Location)]
consistentPairs

  normalizedOrdering :: [Signed (Cosmic Location, Cosmic Location)]
  normalizedOrdering :: [Signed (Cosmic Location, Cosmic Location)]
normalizedOrdering = forall a b. (a -> b) -> [a] -> [b]
map forall a. (Cosmic a, Cosmic a) -> Signed (Cosmic a, Cosmic a)
normalizePairOrder [(Cosmic Location, Cosmic Location)]
interWorldPairs

  normalizePairOrder :: (Cosmic a, Cosmic a) -> Signed (Cosmic a, Cosmic a)
  normalizePairOrder :: forall a. (Cosmic a, Cosmic a) -> Signed (Cosmic a, Cosmic a)
normalizePairOrder (Cosmic a, Cosmic a)
pair =
    if forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (forall a. Ord a => a -> a -> Bool
(>) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (Cosmic a) SubworldName
subworld) (Cosmic a, Cosmic a)
pair
      then forall a. a -> Signed a
Negative forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> (b, a)
swap (Cosmic a, Cosmic a)
pair
      else forall a. a -> Signed a
Positive (Cosmic a, Cosmic a)
pair

  tuplify :: (Cosmic a, Cosmic a) -> ((SubworldName, SubworldName), (a, a))
  tuplify :: forall a.
(Cosmic a, Cosmic a) -> ((SubworldName, SubworldName), (a, a))
tuplify = forall (p :: * -> * -> *) a d.
Bifunctor p =>
(a -> d) -> p a a -> p d d
both (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. Lens' (Cosmic a) SubworldName
subworld) forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (p :: * -> * -> *) a d.
Bifunctor p =>
(a -> d) -> p a a -> p d d
both (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a1 a2. Lens (Cosmic a1) (Cosmic a2) a1 a2
planar)

  getSigned :: Signed (V2 Int32) -> V2 Int32
  getSigned :: Signed (V2 Int32) -> V2 Int32
getSigned = \case
    Positive V2 Int32
x -> V2 Int32
x
    Negative V2 Int32
x -> forall (f :: * -> *) a. (Functor f, Num a) => f a -> f a
negated V2 Int32
x

  groupedBySubworldPair ::
    Map (SubworldName, SubworldName) (NonEmpty (Signed (Location, Location)))
  groupedBySubworldPair :: Map
  (SubworldName, SubworldName)
  (NonEmpty (Signed (Location, Location)))
groupedBySubworldPair = forall (t :: * -> *) a b.
(Foldable t, Ord a) =>
t (a, b) -> Map a (NonEmpty b)
binTuples forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a. Functor f => Signed (f a) -> f (Signed a)
sequenceSigned forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a.
(Cosmic a, Cosmic a) -> ((SubworldName, SubworldName), (a, a))
tuplify) [Signed (Cosmic Location, Cosmic Location)]
normalizedOrdering

  vectorized :: Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))
  vectorized :: Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))
vectorized = forall a b k. (a -> b) -> Map k a -> Map k b
M.map (forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (Signed (V2 Int32) -> V2 Int32
getSigned forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall (p :: * -> *) a. (Affine p, Num a) => p a -> p a -> Diff p a
(.-.)))) Map
  (SubworldName, SubworldName)
  (NonEmpty (Signed (Location, Location)))
groupedBySubworldPair

  nonUniform :: Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))
  nonUniform :: Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))
nonUniform = forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter ((Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> Bool
allEqual) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NonEmpty a -> [a]
NE.toList) Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))
vectorized

-- |
-- An implementation of 'sequenceA' for 'Signed' that does not
-- require an 'Applicative' instance for the inner 'Functor'.
--
-- == Discussion
-- Compare to the 'Traversable' instance of 'Signed':
--
-- @
-- instance Traversable Signed where
--   traverse f (Positive x) = Positive <$> f x
--   traverse f (Negative x) = Negative <$> f x
-- @
--
-- if we were to substitute 'id' for f:
--
-- @
--   traverse id (Positive x) = Positive <$> id x
--   traverse id (Negative x) = Negative <$> id x
-- @
-- our implementation essentially becomes @traverse id@.
--
-- However, we cannot simply write our implementation as @traverse id@, because
-- the 'traverse' function has an 'Applicative' constraint, which is superfluous
-- for our purpose.
--
-- Perhaps there is an opportunity to invent a typeclass for datatypes which
-- consist exclusively of unary (or more ambitiously, non-nullary?) data constructors,
-- for which a less-constrained 'sequence' function could be automatically derived.
-- Compare to the 'Comonad' class and its 'extract' function.
sequenceSigned ::
  Functor f =>
  Signed (f a) ->
  f (Signed a)
sequenceSigned :: forall (f :: * -> *) a. Functor f => Signed (f a) -> f (Signed a)
sequenceSigned = \case
  Positive f a
x -> forall a. a -> Signed a
Positive forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x
  Negative f a
x -> forall a. a -> Signed a
Negative forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x