{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE UndecidableInstances #-}
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)
data Navigation additionalDimension portalExitLoc = Navigation
{ forall (additionalDimension :: * -> *) portalExitLoc.
Navigation additionalDimension portalExitLoc
-> additionalDimension WaypointMap
waypoints :: additionalDimension WaypointMap
, 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
}
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
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
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
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
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
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