{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# 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.Map.NonEmpty qualified as NEM
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.Syntax.Direction
import Swarm.Util (allEqual, binTuples, both, commaList, 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
[AnnotatedDestination a] -> ShowS
AnnotatedDestination a -> String
(Int -> AnnotatedDestination a -> ShowS)
-> (AnnotatedDestination a -> String)
-> ([AnnotatedDestination a] -> ShowS)
-> Show (AnnotatedDestination a)
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
$cshowsPrec :: forall a. Show a => Int -> AnnotatedDestination a -> ShowS
showsPrec :: Int -> AnnotatedDestination a -> ShowS
$cshow :: forall a. Show a => AnnotatedDestination a -> String
show :: AnnotatedDestination a -> String
$cshowList :: forall a. Show a => [AnnotatedDestination a] -> ShowS
showList :: [AnnotatedDestination a] -> ShowS
Show, AnnotatedDestination a -> AnnotatedDestination a -> Bool
(AnnotatedDestination a -> AnnotatedDestination a -> Bool)
-> (AnnotatedDestination a -> AnnotatedDestination a -> Bool)
-> Eq (AnnotatedDestination a)
forall a.
Eq a =>
AnnotatedDestination a -> AnnotatedDestination a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: AnnotatedDestination a -> AnnotatedDestination a -> Bool
Eq, (forall x.
 AnnotatedDestination a -> Rep (AnnotatedDestination a) x)
-> (forall x.
    Rep (AnnotatedDestination a) x -> AnnotatedDestination a)
-> Generic (AnnotatedDestination a)
forall x. Rep (AnnotatedDestination a) x -> AnnotatedDestination a
forall x. AnnotatedDestination a -> Rep (AnnotatedDestination a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x.
Rep (AnnotatedDestination a) x -> AnnotatedDestination a
forall a x.
AnnotatedDestination a -> Rep (AnnotatedDestination a) x
$cfrom :: forall a x.
AnnotatedDestination a -> Rep (AnnotatedDestination a) x
from :: forall x. AnnotatedDestination a -> Rep (AnnotatedDestination a) x
$cto :: forall a x.
Rep (AnnotatedDestination a) x -> AnnotatedDestination a
to :: forall x. Rep (AnnotatedDestination a) x -> AnnotatedDestination a
Generic, [AnnotatedDestination a] -> Value
[AnnotatedDestination a] -> Encoding
AnnotatedDestination a -> Bool
AnnotatedDestination a -> Value
AnnotatedDestination a -> Encoding
(AnnotatedDestination a -> Value)
-> (AnnotatedDestination a -> Encoding)
-> ([AnnotatedDestination a] -> Value)
-> ([AnnotatedDestination a] -> Encoding)
-> (AnnotatedDestination a -> Bool)
-> ToJSON (AnnotatedDestination a)
forall a. ToJSON a => [AnnotatedDestination a] -> Value
forall a. ToJSON a => [AnnotatedDestination a] -> Encoding
forall a. ToJSON a => AnnotatedDestination a -> Bool
forall a. ToJSON a => AnnotatedDestination a -> Value
forall a. ToJSON a => AnnotatedDestination a -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: forall a. ToJSON a => AnnotatedDestination a -> Value
toJSON :: AnnotatedDestination a -> Value
$ctoEncoding :: forall a. ToJSON a => AnnotatedDestination a -> Encoding
toEncoding :: AnnotatedDestination a -> Encoding
$ctoJSONList :: forall a. ToJSON a => [AnnotatedDestination a] -> Value
toJSONList :: [AnnotatedDestination a] -> Value
$ctoEncodingList :: forall a. ToJSON a => [AnnotatedDestination a] -> Encoding
toEncodingList :: [AnnotatedDestination a] -> Encoding
$comitField :: forall a. ToJSON a => AnnotatedDestination a -> Bool
omitField :: AnnotatedDestination a -> Bool
ToJSON)

-- | 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 ((forall x.
 Navigation additionalDimension portalExitLoc
 -> Rep (Navigation additionalDimension portalExitLoc) x)
-> (forall x.
    Rep (Navigation additionalDimension portalExitLoc) x
    -> Navigation additionalDimension portalExitLoc)
-> Generic (Navigation additionalDimension portalExitLoc)
forall x.
Rep (Navigation additionalDimension portalExitLoc) x
-> Navigation additionalDimension portalExitLoc
forall x.
Navigation additionalDimension portalExitLoc
-> Rep (Navigation additionalDimension portalExitLoc) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (additionalDimension :: * -> *) portalExitLoc x.
Rep (Navigation additionalDimension portalExitLoc) x
-> Navigation additionalDimension portalExitLoc
forall (additionalDimension :: * -> *) portalExitLoc x.
Navigation additionalDimension portalExitLoc
-> Rep (Navigation additionalDimension portalExitLoc) x
$cfrom :: forall (additionalDimension :: * -> *) portalExitLoc x.
Navigation additionalDimension portalExitLoc
-> Rep (Navigation additionalDimension portalExitLoc) x
from :: forall x.
Navigation additionalDimension portalExitLoc
-> Rep (Navigation additionalDimension portalExitLoc) x
$cto :: forall (additionalDimension :: * -> *) portalExitLoc x.
Rep (Navigation additionalDimension portalExitLoc) x
-> Navigation additionalDimension portalExitLoc
to :: forall x.
Rep (Navigation additionalDimension portalExitLoc) x
-> Navigation additionalDimension portalExitLoc
Generic)

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
(Int -> PortalExit -> ShowS)
-> (PortalExit -> String)
-> ([PortalExit] -> ShowS)
-> Show PortalExit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PortalExit -> ShowS
showsPrec :: Int -> PortalExit -> ShowS
$cshow :: PortalExit -> String
show :: PortalExit -> String
$cshowList :: [PortalExit] -> ShowS
showList :: [PortalExit] -> ShowS
Show, PortalExit -> PortalExit -> Bool
(PortalExit -> PortalExit -> Bool)
-> (PortalExit -> PortalExit -> Bool) -> Eq PortalExit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PortalExit -> PortalExit -> Bool
== :: PortalExit -> PortalExit -> Bool
$c/= :: PortalExit -> PortalExit -> Bool
/= :: PortalExit -> PortalExit -> Bool
Eq, (forall x. PortalExit -> Rep PortalExit x)
-> (forall x. Rep PortalExit x -> PortalExit) -> Generic PortalExit
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
$cfrom :: forall x. PortalExit -> Rep PortalExit x
from :: forall x. PortalExit -> Rep PortalExit x
$cto :: forall x. Rep PortalExit x -> PortalExit
to :: forall x. Rep PortalExit x -> PortalExit
Generic, Maybe PortalExit
Value -> Parser [PortalExit]
Value -> Parser PortalExit
(Value -> Parser PortalExit)
-> (Value -> Parser [PortalExit])
-> Maybe PortalExit
-> FromJSON PortalExit
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser PortalExit
parseJSON :: Value -> Parser PortalExit
$cparseJSONList :: Value -> Parser [PortalExit]
parseJSONList :: Value -> Parser [PortalExit]
$comittedField :: Maybe PortalExit
omittedField :: Maybe 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
(Int -> Portal -> ShowS)
-> (Portal -> String) -> ([Portal] -> ShowS) -> Show Portal
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Portal -> ShowS
showsPrec :: Int -> Portal -> ShowS
$cshow :: Portal -> String
show :: Portal -> String
$cshowList :: [Portal] -> ShowS
showList :: [Portal] -> ShowS
Show, Portal -> Portal -> Bool
(Portal -> Portal -> Bool)
-> (Portal -> Portal -> Bool) -> Eq Portal
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Portal -> Portal -> Bool
== :: Portal -> Portal -> Bool
$c/= :: Portal -> Portal -> Bool
/= :: Portal -> Portal -> Bool
Eq)

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

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 =
  Maybe (a, NonEmpty b) -> ((a, NonEmpty b) -> m Any) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([(a, NonEmpty b)] -> Maybe (a, NonEmpty b)
forall a. [a] -> Maybe a
listToMaybe ([(a, NonEmpty b)] -> Maybe (a, NonEmpty b))
-> [(a, NonEmpty b)] -> Maybe (a, NonEmpty b)
forall a b. (a -> b) -> a -> b
$ Map a (NonEmpty b) -> [(a, NonEmpty b)]
forall k a. Map k a -> [(k, a)]
M.toList Map a (NonEmpty b)
duplicated) (((a, NonEmpty b) -> m Any) -> m ())
-> ((a, NonEmpty b) -> m Any) -> m ()
forall a b. (a -> b) -> a -> b
$ \(a
pIn, NonEmpty b
pOuts) ->
    [Text] -> m Any
forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT
      [ Text
"Waypoint"
      , a -> Text
forall a. Show a => a -> Text
showT a
pIn
      , Text
message
      , Text -> [Text] -> Text
T.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (b -> Text) -> [b] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map b -> Text
forall a. Show a => a -> Text
showT ([b] -> [Text]) -> [b] -> [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty b -> [b]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty b
pOuts
      ]
 where
  duplicated :: Map a (NonEmpty b)
duplicated = (NonEmpty b -> Bool) -> Map a (NonEmpty b) -> Map a (NonEmpty b)
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Int -> Bool) -> (NonEmpty b -> Int) -> NonEmpty b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty b -> Int
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) =
  m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Text] -> m a
forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT [Text
"No waypoint named", Text -> Text
quote Text
rawName]) a -> m a
forall a. a -> m a
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
  Text -> Map WaypointName (NonEmpty (Originated Waypoint)) -> m ()
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 <- t Portal
-> (Portal -> m [(Location, AnnotatedDestination WaypointName)])
-> m (t [(Location, AnnotatedDestination WaypointName)])
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM t Portal
portalDefs ((Portal -> m [(Location, AnnotatedDestination WaypointName)])
 -> m (t [(Location, AnnotatedDestination WaypointName)]))
-> (Portal -> m [(Location, AnnotatedDestination WaypointName)])
-> m (t [(Location, AnnotatedDestination WaypointName)])
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 <- WaypointName -> m (NonEmpty (Originated Waypoint))
forall {m :: * -> *}.
MonadFail m =>
WaypointName -> m (NonEmpty (Originated Waypoint))
getLocs WaypointName
entranceName

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

  let reconciledPortalPairs :: [(Location, AnnotatedDestination WaypointName)]
reconciledPortalPairs = t [(Location, AnnotatedDestination WaypointName)]
-> [(Location, AnnotatedDestination WaypointName)]
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
  Text
-> Map Location (NonEmpty (AnnotatedDestination WaypointName))
-> m ()
forall (m :: * -> *) a b.
(MonadFail m, Show a, Show b) =>
Text -> Map a (NonEmpty b) -> m ()
failUponDuplication Text
"has overlapping portal entrances exiting to" (Map Location (NonEmpty (AnnotatedDestination WaypointName))
 -> m ())
-> Map Location (NonEmpty (AnnotatedDestination WaypointName))
-> m ()
forall a b. (a -> b) -> a -> b
$
    [(Location, AnnotatedDestination WaypointName)]
-> Map Location (NonEmpty (AnnotatedDestination WaypointName))
forall (t :: * -> *) a b.
(Foldable t, Ord a) =>
t (a, b) -> Map a (NonEmpty b)
binTuples [(Location, AnnotatedDestination WaypointName)]
reconciledPortalPairs

  Navigation Identity WaypointName
-> m (Navigation Identity WaypointName)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Navigation Identity WaypointName
 -> m (Navigation Identity WaypointName))
-> ([(Cosmic Location, AnnotatedDestination WaypointName)]
    -> Navigation Identity WaypointName)
-> [(Cosmic Location, AnnotatedDestination WaypointName)]
-> m (Navigation Identity WaypointName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identity WaypointMap
-> Map (Cosmic Location) (AnnotatedDestination WaypointName)
-> Navigation Identity WaypointName
forall (additionalDimension :: * -> *) portalExitLoc.
additionalDimension WaypointMap
-> Map (Cosmic Location) (AnnotatedDestination portalExitLoc)
-> Navigation additionalDimension portalExitLoc
Navigation (WaypointMap -> Identity WaypointMap
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WaypointMap
bareWaypoints) (Map (Cosmic Location) (AnnotatedDestination WaypointName)
 -> Navigation Identity WaypointName)
-> ([(Cosmic Location, AnnotatedDestination WaypointName)]
    -> Map (Cosmic Location) (AnnotatedDestination WaypointName))
-> [(Cosmic Location, AnnotatedDestination WaypointName)]
-> Navigation Identity WaypointName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Cosmic Location, AnnotatedDestination WaypointName)]
-> Map (Cosmic Location) (AnnotatedDestination WaypointName)
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(Cosmic Location, AnnotatedDestination WaypointName)]
 -> m (Navigation Identity WaypointName))
-> [(Cosmic Location, AnnotatedDestination WaypointName)]
-> m (Navigation Identity WaypointName)
forall a b. (a -> b) -> a -> b
$
    ((Location, AnnotatedDestination WaypointName)
 -> (Cosmic Location, AnnotatedDestination WaypointName))
-> [(Location, AnnotatedDestination WaypointName)]
-> [(Cosmic Location, AnnotatedDestination WaypointName)]
forall a b. (a -> b) -> [a] -> [b]
map ((Location -> Cosmic Location)
-> (Location, AnnotatedDestination WaypointName)
-> (Cosmic Location, AnnotatedDestination WaypointName)
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ((Location -> Cosmic Location)
 -> (Location, AnnotatedDestination WaypointName)
 -> (Cosmic Location, AnnotatedDestination WaypointName))
-> (Location -> Cosmic Location)
-> (Location, AnnotatedDestination WaypointName)
-> (Cosmic Location, AnnotatedDestination WaypointName)
forall a b. (a -> b) -> a -> b
$ SubworldName -> Location -> Cosmic Location
forall a. SubworldName -> a -> Cosmic a
Cosmic SubworldName
currentSubworldName) [(Location, AnnotatedDestination WaypointName)]
reconciledPortalPairs
 where
  getLocs :: WaypointName -> m (NonEmpty (Originated Waypoint))
getLocs WaypointName
wpWrapper = WaypointName
-> Maybe (NonEmpty (Originated Waypoint))
-> m (NonEmpty (Originated Waypoint))
forall (m :: * -> *) a.
MonadFail m =>
WaypointName -> Maybe a -> m a
failWaypointLookup WaypointName
wpWrapper (Maybe (NonEmpty (Originated Waypoint))
 -> m (NonEmpty (Originated Waypoint)))
-> Maybe (NonEmpty (Originated Waypoint))
-> m (NonEmpty (Originated Waypoint))
forall a b. (a -> b) -> a -> b
$ WaypointName
-> Map WaypointName (NonEmpty (Originated Waypoint))
-> Maybe (NonEmpty (Originated Waypoint))
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 Parentage Placement
_ (Waypoint WaypointConfig
_ Location
loc)) = Location
loc
  correctedWaypoints :: Map WaypointName (NonEmpty (Originated Waypoint))
correctedWaypoints =
    [(WaypointName, Originated Waypoint)]
-> Map WaypointName (NonEmpty (Originated Waypoint))
forall (t :: * -> *) a b.
(Foldable t, Ord a) =>
t (a, b) -> Map a (NonEmpty b)
binTuples ([(WaypointName, Originated Waypoint)]
 -> Map WaypointName (NonEmpty (Originated Waypoint)))
-> [(WaypointName, Originated Waypoint)]
-> Map WaypointName (NonEmpty (Originated Waypoint))
forall a b. (a -> b) -> a -> b
$
      (Originated Waypoint -> (WaypointName, Originated Waypoint))
-> [Originated Waypoint] -> [(WaypointName, Originated Waypoint)]
forall a b. (a -> b) -> [a] -> [b]
map
        (\Originated Waypoint
x -> (WaypointConfig -> WaypointName
wpName (WaypointConfig -> WaypointName) -> WaypointConfig -> WaypointName
forall a b. (a -> b) -> a -> b
$ Waypoint -> WaypointConfig
wpConfig (Waypoint -> WaypointConfig) -> Waypoint -> WaypointConfig
forall a b. (a -> b) -> a -> b
$ Originated Waypoint -> Waypoint
forall a. Originated a -> a
value Originated Waypoint
x, (Waypoint -> Waypoint)
-> Originated Waypoint -> Originated Waypoint
forall a b. (a -> b) -> Originated a -> Originated b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (V2 Int32 -> Waypoint -> Waypoint
forall a. HasLocation a => V2 Int32 -> a -> a
offsetLoc (V2 Int32 -> Waypoint -> Waypoint)
-> V2 Int32 -> Waypoint -> Waypoint
forall a b. (a -> b) -> a -> b
$ Location -> V2 Int32
asVector Location
upperLeft) Originated Waypoint
x))
        [Originated Waypoint]
unmergedWaypoints
  bareWaypoints :: WaypointMap
bareWaypoints = (NonEmpty (Originated Waypoint) -> NonEmpty Location)
-> Map WaypointName (NonEmpty (Originated Waypoint)) -> WaypointMap
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((Originated Waypoint -> Location)
-> NonEmpty (Originated Waypoint) -> NonEmpty Location
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 = (NonEmpty (Originated Waypoint) -> Bool)
-> Map WaypointName (NonEmpty (Originated Waypoint))
-> Map WaypointName (NonEmpty (Originated Waypoint))
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter ((Originated Waypoint -> Bool)
-> NonEmpty (Originated Waypoint) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Originated Waypoint -> Bool)
 -> NonEmpty (Originated Waypoint) -> Bool)
-> (Originated Waypoint -> Bool)
-> NonEmpty (Originated Waypoint)
-> Bool
forall a b. (a -> b) -> a -> b
$ WaypointConfig -> Bool
wpUnique (WaypointConfig -> Bool)
-> (Originated Waypoint -> WaypointConfig)
-> Originated Waypoint
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Waypoint -> WaypointConfig
wpConfig (Waypoint -> WaypointConfig)
-> (Originated Waypoint -> Waypoint)
-> Originated Waypoint
-> WaypointConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Originated Waypoint -> Waypoint
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 <- [(Cosmic Location, AnnotatedDestination WaypointName)]
-> ((Cosmic Location, AnnotatedDestination WaypointName)
    -> m (Cosmic Location, AnnotatedDestination Location))
-> m [(Cosmic Location, AnnotatedDestination Location)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Map (Cosmic Location) (AnnotatedDestination WaypointName)
-> [(Cosmic Location, AnnotatedDestination WaypointName)]
forall k a. Map k a -> [(k, a)]
M.toList Map (Cosmic Location) (AnnotatedDestination WaypointName)
partialPortals) (((Cosmic Location, AnnotatedDestination WaypointName)
  -> m (Cosmic Location, AnnotatedDestination Location))
 -> m [(Cosmic Location, AnnotatedDestination Location)])
-> ((Cosmic Location, AnnotatedDestination WaypointName)
    -> m (Cosmic Location, AnnotatedDestination Location))
-> m [(Cosmic Location, AnnotatedDestination Location)]
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 <- Cosmic WaypointName -> m (NonEmpty Location)
forall {m :: * -> *}.
MonadFail m =>
Cosmic WaypointName -> m (NonEmpty Location)
getLocs Cosmic WaypointName
portalExit
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Location] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Location]
otherExits) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
      [Text] -> m ()
forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT
        [ Text
"Ambiguous exit waypoints named"
        , Text -> Text
quote Text
rawExitName
        , Text
"for portal"
        ]
    (Cosmic Location, AnnotatedDestination Location)
-> m (Cosmic Location, AnnotatedDestination Location)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cosmic Location
portalEntrance, Bool
-> Direction -> Cosmic Location -> AnnotatedDestination Location
forall a. Bool -> Direction -> Cosmic a -> AnnotatedDestination a
AnnotatedDestination Bool
isConsistent Direction
reOrient (Cosmic Location -> AnnotatedDestination Location)
-> Cosmic Location -> AnnotatedDestination Location
forall a b. (a -> b) -> a -> b
$ SubworldName -> Location -> Cosmic Location
forall a. SubworldName -> a -> Cosmic a
Cosmic SubworldName
swName Location
firstExitLoc)

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

  Map (Cosmic Location) (AnnotatedDestination Location)
-> m (Map (Cosmic Location) (AnnotatedDestination Location))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Map (Cosmic Location) (AnnotatedDestination Location)
 -> m (Map (Cosmic Location) (AnnotatedDestination Location)))
-> Map (Cosmic Location) (AnnotatedDestination Location)
-> m (Map (Cosmic Location) (AnnotatedDestination Location))
forall a b. (a -> b) -> a -> b
$ [(Cosmic Location, AnnotatedDestination Location)]
-> Map (Cosmic Location) (AnnotatedDestination Location)
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 SubworldName -> Map SubworldName WaypointMap -> Maybe WaypointMap
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup SubworldName
swName Map SubworldName WaypointMap
wpUniverse of
      Just WaypointMap
x -> WaypointMap -> m WaypointMap
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return WaypointMap
x
      Maybe WaypointMap
Nothing ->
        [Text] -> m WaypointMap
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 (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ SubworldName -> Text
renderWorldName SubworldName
swName
          , Text
"does not exist"
          ]

    WaypointName -> Maybe (NonEmpty Location) -> m (NonEmpty Location)
forall (m :: * -> *) a.
MonadFail m =>
WaypointName -> Maybe a -> m a
failWaypointLookup WaypointName
wpWrapper (Maybe (NonEmpty Location) -> m (NonEmpty Location))
-> Maybe (NonEmpty Location) -> m (NonEmpty Location)
forall a b. (a -> b) -> a -> b
$
      WaypointName -> WaypointMap -> Maybe (NonEmpty Location)
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 =
  Maybe (NEMap (SubworldName, SubworldName) (NonEmpty (V2 Int32)))
-> (NEMap (SubworldName, SubworldName) (NonEmpty (V2 Int32))
    -> m Any)
-> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))
-> Maybe (NEMap (SubworldName, SubworldName) (NonEmpty (V2 Int32)))
forall k a. Map k a -> Maybe (NEMap k a)
NEM.nonEmptyMap Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))
nonUniform) ((NEMap (SubworldName, SubworldName) (NonEmpty (V2 Int32))
  -> m Any)
 -> m ())
-> (NEMap (SubworldName, SubworldName) (NonEmpty (V2 Int32))
    -> m Any)
-> m ()
forall a b. (a -> b) -> a -> b
$ \NEMap (SubworldName, SubworldName) (NonEmpty (V2 Int32))
nonUniformMap ->
    [Text] -> m Any
forall (m :: * -> *) a. MonadFail m => [Text] -> m a
failT
      [ Text
"Non-uniform portal distances:"
      , NEMap (SubworldName, SubworldName) (NonEmpty (V2 Int32)) -> Text
forall {a}.
Show a =>
NEMap (SubworldName, SubworldName) (NonEmpty a) -> Text
renderNonUniformPairs NEMap (SubworldName, SubworldName) (NonEmpty (V2 Int32))
nonUniformMap
      ]
 where
  renderNonUniformPairs :: NEMap (SubworldName, SubworldName) (NonEmpty a) -> Text
renderNonUniformPairs NEMap (SubworldName, SubworldName) (NonEmpty a)
nem =
    [Text] -> Text
commaList ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty Text -> [Text]) -> NonEmpty Text -> [Text]
forall a b. (a -> b) -> a -> b
$ ((SubworldName, SubworldName), NonEmpty a) -> Text
forall {a}.
Show a =>
((SubworldName, SubworldName), NonEmpty a) -> Text
renderPair (((SubworldName, SubworldName), NonEmpty a) -> Text)
-> NonEmpty ((SubworldName, SubworldName), NonEmpty a)
-> NonEmpty Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NEMap (SubworldName, SubworldName) (NonEmpty a)
-> NonEmpty ((SubworldName, SubworldName), NonEmpty a)
forall k a. NEMap k a -> NonEmpty (k, a)
NEM.toList NEMap (SubworldName, SubworldName) (NonEmpty a)
nem
   where
    renderPair :: ((SubworldName, SubworldName), NonEmpty a) -> Text
renderPair ((SubworldName, SubworldName)
k, NonEmpty a
v) =
      [Text] -> Text
T.unwords
        [ (SubworldName, SubworldName) -> Text
renderKey (SubworldName, SubworldName)
k Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":"
        , [Text] -> Text
commaList ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ NonEmpty Text -> [Text]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty Text -> [Text]) -> NonEmpty Text -> [Text]
forall a b. (a -> b) -> a -> b
$ a -> Text
forall a. Show a => a -> Text
showT (a -> Text) -> NonEmpty a -> NonEmpty Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty a
v
        ]
    renderKey :: (SubworldName, SubworldName) -> Text
renderKey (SubworldName
sw1, SubworldName
sw2) =
      [Text] -> Text
T.unwords
        [ Text
"Between subworlds"
        , SubworldName -> Text
renderQuotedWorldName SubworldName
sw1
        , Text
"and"
        , SubworldName -> Text
renderQuotedWorldName SubworldName
sw2
        ]

  consistentPairs :: [(Cosmic Location, Cosmic Location)]
  consistentPairs :: [(Cosmic Location, Cosmic Location)]
consistentPairs = ((Cosmic Location, AnnotatedDestination Location)
 -> (Cosmic Location, Cosmic Location))
-> [(Cosmic Location, AnnotatedDestination Location)]
-> [(Cosmic Location, Cosmic Location)]
forall a b. (a -> b) -> [a] -> [b]
map ((AnnotatedDestination Location -> Cosmic Location)
-> (Cosmic Location, AnnotatedDestination Location)
-> (Cosmic Location, Cosmic Location)
forall a b.
(a -> b) -> (Cosmic Location, a) -> (Cosmic Location, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap AnnotatedDestination Location -> Cosmic Location
forall a. AnnotatedDestination a -> Cosmic a
destination) ([(Cosmic Location, AnnotatedDestination Location)]
 -> [(Cosmic Location, Cosmic Location)])
-> [(Cosmic Location, AnnotatedDestination Location)]
-> [(Cosmic Location, Cosmic Location)]
forall a b. (a -> b) -> a -> b
$ ((Cosmic Location, AnnotatedDestination Location) -> Bool)
-> [(Cosmic Location, AnnotatedDestination Location)]
-> [(Cosmic Location, AnnotatedDestination Location)]
forall a. (a -> Bool) -> [a] -> [a]
filter (AnnotatedDestination Location -> Bool
forall a. AnnotatedDestination a -> Bool
enforceConsistency (AnnotatedDestination Location -> Bool)
-> ((Cosmic Location, AnnotatedDestination Location)
    -> AnnotatedDestination Location)
-> (Cosmic Location, AnnotatedDestination Location)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cosmic Location, AnnotatedDestination Location)
-> AnnotatedDestination Location
forall a b. (a, b) -> b
snd) [(Cosmic Location, AnnotatedDestination Location)]
xs

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

  normalizedOrdering :: [Signed (Cosmic Location, Cosmic Location)]
  normalizedOrdering :: [Signed (Cosmic Location, Cosmic Location)]
normalizedOrdering = ((Cosmic Location, Cosmic Location)
 -> Signed (Cosmic Location, Cosmic Location))
-> [(Cosmic Location, Cosmic Location)]
-> [Signed (Cosmic Location, Cosmic Location)]
forall a b. (a -> b) -> [a] -> [b]
map (Cosmic Location, Cosmic Location)
-> Signed (Cosmic Location, Cosmic Location)
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 (Cosmic a -> Cosmic a -> Bool) -> (Cosmic a, Cosmic a) -> Bool
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (SubworldName -> SubworldName -> Bool
forall a. Ord a => a -> a -> Bool
(>) (SubworldName -> SubworldName -> Bool)
-> (Cosmic a -> SubworldName) -> Cosmic a -> Cosmic a -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Getting SubworldName (Cosmic a) SubworldName
-> Cosmic a -> SubworldName
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting SubworldName (Cosmic a) SubworldName
forall a (f :: * -> *).
Functor f =>
(SubworldName -> f SubworldName) -> Cosmic a -> f (Cosmic a)
subworld) (Cosmic a, Cosmic a)
pair
      then (Cosmic a, Cosmic a) -> Signed (Cosmic a, Cosmic a)
forall a. a -> Signed a
Negative ((Cosmic a, Cosmic a) -> Signed (Cosmic a, Cosmic a))
-> (Cosmic a, Cosmic a) -> Signed (Cosmic a, Cosmic a)
forall a b. (a -> b) -> a -> b
$ (Cosmic a, Cosmic a) -> (Cosmic a, Cosmic a)
forall a b. (a, b) -> (b, a)
swap (Cosmic a, Cosmic a)
pair
      else (Cosmic a, Cosmic a) -> Signed (Cosmic a, Cosmic a)
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 = (Cosmic a -> SubworldName)
-> (Cosmic a, Cosmic a) -> (SubworldName, SubworldName)
forall (p :: * -> * -> *) a d.
Bifunctor p =>
(a -> d) -> p a a -> p d d
both (Getting SubworldName (Cosmic a) SubworldName
-> Cosmic a -> SubworldName
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting SubworldName (Cosmic a) SubworldName
forall a (f :: * -> *).
Functor f =>
(SubworldName -> f SubworldName) -> Cosmic a -> f (Cosmic a)
subworld) ((Cosmic a, Cosmic a) -> (SubworldName, SubworldName))
-> ((Cosmic a, Cosmic a) -> (a, a))
-> (Cosmic a, Cosmic a)
-> ((SubworldName, SubworldName), (a, a))
forall b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Cosmic a -> a) -> (Cosmic a, Cosmic a) -> (a, a)
forall (p :: * -> * -> *) a d.
Bifunctor p =>
(a -> d) -> p a a -> p d d
both (Getting a (Cosmic a) a -> Cosmic a -> a
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting a (Cosmic a) a
forall a1 a2 (f :: * -> *).
Functor f =>
(a1 -> f a2) -> Cosmic a1 -> f (Cosmic 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 -> V2 Int32 -> V2 Int32
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 = [((SubworldName, SubworldName), Signed (Location, Location))]
-> Map
     (SubworldName, SubworldName)
     (NonEmpty (Signed (Location, Location)))
forall (t :: * -> *) a b.
(Foldable t, Ord a) =>
t (a, b) -> Map a (NonEmpty b)
binTuples ([((SubworldName, SubworldName), Signed (Location, Location))]
 -> Map
      (SubworldName, SubworldName)
      (NonEmpty (Signed (Location, Location))))
-> [((SubworldName, SubworldName), Signed (Location, Location))]
-> Map
     (SubworldName, SubworldName)
     (NonEmpty (Signed (Location, Location)))
forall a b. (a -> b) -> a -> b
$ (Signed (Cosmic Location, Cosmic Location)
 -> ((SubworldName, SubworldName), Signed (Location, Location)))
-> [Signed (Cosmic Location, Cosmic Location)]
-> [((SubworldName, SubworldName), Signed (Location, Location))]
forall a b. (a -> b) -> [a] -> [b]
map (Signed ((SubworldName, SubworldName), (Location, Location))
-> ((SubworldName, SubworldName), Signed (Location, Location))
forall (f :: * -> *) a. Functor f => Signed (f a) -> f (Signed a)
sequenceSigned (Signed ((SubworldName, SubworldName), (Location, Location))
 -> ((SubworldName, SubworldName), Signed (Location, Location)))
-> (Signed (Cosmic Location, Cosmic Location)
    -> Signed ((SubworldName, SubworldName), (Location, Location)))
-> Signed (Cosmic Location, Cosmic Location)
-> ((SubworldName, SubworldName), Signed (Location, Location))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Cosmic Location, Cosmic Location)
 -> ((SubworldName, SubworldName), (Location, Location)))
-> Signed (Cosmic Location, Cosmic Location)
-> Signed ((SubworldName, SubworldName), (Location, Location))
forall a b. (a -> b) -> Signed a -> Signed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Cosmic Location, Cosmic Location)
-> ((SubworldName, SubworldName), (Location, Location))
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 = (NonEmpty (Signed (Location, Location)) -> NonEmpty (V2 Int32))
-> Map
     (SubworldName, SubworldName)
     (NonEmpty (Signed (Location, Location)))
-> Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))
forall a b k. (a -> b) -> Map k a -> Map k b
M.map ((Signed (Location, Location) -> V2 Int32)
-> NonEmpty (Signed (Location, Location)) -> NonEmpty (V2 Int32)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (Signed (V2 Int32) -> V2 Int32
getSigned (Signed (V2 Int32) -> V2 Int32)
-> (Signed (Location, Location) -> Signed (V2 Int32))
-> Signed (Location, Location)
-> V2 Int32
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Location, Location) -> V2 Int32)
-> Signed (Location, Location) -> Signed (V2 Int32)
forall a b. (a -> b) -> Signed a -> Signed b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Location -> Location -> V2 Int32)
-> (Location, Location) -> V2 Int32
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Location -> Location -> V2 Int32
Location -> Location -> Diff (Point V2) Int32
forall a. Num a => Point V2 a -> Point V2 a -> Diff (Point V2) a
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 = (NonEmpty (V2 Int32) -> Bool)
-> Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))
-> Map (SubworldName, SubworldName) (NonEmpty (V2 Int32))
forall a k. (a -> Bool) -> Map k a -> Map k a
M.filter ((Bool -> Bool
not (Bool -> Bool) -> ([V2 Int32] -> Bool) -> [V2 Int32] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [V2 Int32] -> Bool
forall a. Ord a => [a] -> Bool
allEqual) ([V2 Int32] -> Bool)
-> (NonEmpty (V2 Int32) -> [V2 Int32])
-> NonEmpty (V2 Int32)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (V2 Int32) -> [V2 Int32]
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 -> a -> Signed a
forall a. a -> Signed a
Positive (a -> Signed a) -> f a -> f (Signed a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x
  Negative f a
x -> a -> Signed a
forall a. a -> Signed a
Negative (a -> Signed a) -> f a -> f (Signed a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
x