{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Types and utilities for working with "universal locations";
-- locations that encompass different 2-D subworlds.
module Swarm.Game.Universe where

import Control.Lens (makeLenses, view)
import Data.Aeson (ToJSONKey)
import Data.Function (on)
import Data.Int (Int32)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Yaml (FromJSON, ToJSON, Value (Object), parseJSON, withText, (.:))
import GHC.Generics (Generic)
import Linear (V2 (..))
import Swarm.Game.Location
import Swarm.Util (quote)

-- * Referring to subworlds

data SubworldName = DefaultRootSubworld | SubworldName Text
  deriving (Int -> SubworldName -> ShowS
[SubworldName] -> ShowS
SubworldName -> String
(Int -> SubworldName -> ShowS)
-> (SubworldName -> String)
-> ([SubworldName] -> ShowS)
-> Show SubworldName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SubworldName -> ShowS
showsPrec :: Int -> SubworldName -> ShowS
$cshow :: SubworldName -> String
show :: SubworldName -> String
$cshowList :: [SubworldName] -> ShowS
showList :: [SubworldName] -> ShowS
Show, SubworldName -> SubworldName -> Bool
(SubworldName -> SubworldName -> Bool)
-> (SubworldName -> SubworldName -> Bool) -> Eq SubworldName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SubworldName -> SubworldName -> Bool
== :: SubworldName -> SubworldName -> Bool
$c/= :: SubworldName -> SubworldName -> Bool
/= :: SubworldName -> SubworldName -> Bool
Eq, Eq SubworldName
Eq SubworldName =>
(SubworldName -> SubworldName -> Ordering)
-> (SubworldName -> SubworldName -> Bool)
-> (SubworldName -> SubworldName -> Bool)
-> (SubworldName -> SubworldName -> Bool)
-> (SubworldName -> SubworldName -> Bool)
-> (SubworldName -> SubworldName -> SubworldName)
-> (SubworldName -> SubworldName -> SubworldName)
-> Ord SubworldName
SubworldName -> SubworldName -> Bool
SubworldName -> SubworldName -> Ordering
SubworldName -> SubworldName -> SubworldName
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SubworldName -> SubworldName -> Ordering
compare :: SubworldName -> SubworldName -> Ordering
$c< :: SubworldName -> SubworldName -> Bool
< :: SubworldName -> SubworldName -> Bool
$c<= :: SubworldName -> SubworldName -> Bool
<= :: SubworldName -> SubworldName -> Bool
$c> :: SubworldName -> SubworldName -> Bool
> :: SubworldName -> SubworldName -> Bool
$c>= :: SubworldName -> SubworldName -> Bool
>= :: SubworldName -> SubworldName -> Bool
$cmax :: SubworldName -> SubworldName -> SubworldName
max :: SubworldName -> SubworldName -> SubworldName
$cmin :: SubworldName -> SubworldName -> SubworldName
min :: SubworldName -> SubworldName -> SubworldName
Ord, (forall x. SubworldName -> Rep SubworldName x)
-> (forall x. Rep SubworldName x -> SubworldName)
-> Generic SubworldName
forall x. Rep SubworldName x -> SubworldName
forall x. SubworldName -> Rep SubworldName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SubworldName -> Rep SubworldName x
from :: forall x. SubworldName -> Rep SubworldName x
$cto :: forall x. Rep SubworldName x -> SubworldName
to :: forall x. Rep SubworldName x -> SubworldName
Generic, [SubworldName] -> Value
[SubworldName] -> Encoding
SubworldName -> Bool
SubworldName -> Value
SubworldName -> Encoding
(SubworldName -> Value)
-> (SubworldName -> Encoding)
-> ([SubworldName] -> Value)
-> ([SubworldName] -> Encoding)
-> (SubworldName -> Bool)
-> ToJSON SubworldName
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: SubworldName -> Value
toJSON :: SubworldName -> Value
$ctoEncoding :: SubworldName -> Encoding
toEncoding :: SubworldName -> Encoding
$ctoJSONList :: [SubworldName] -> Value
toJSONList :: [SubworldName] -> Value
$ctoEncodingList :: [SubworldName] -> Encoding
toEncodingList :: [SubworldName] -> Encoding
$comitField :: SubworldName -> Bool
omitField :: SubworldName -> Bool
ToJSON, ToJSONKeyFunction [SubworldName]
ToJSONKeyFunction SubworldName
ToJSONKeyFunction SubworldName
-> ToJSONKeyFunction [SubworldName] -> ToJSONKey SubworldName
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
$ctoJSONKey :: ToJSONKeyFunction SubworldName
toJSONKey :: ToJSONKeyFunction SubworldName
$ctoJSONKeyList :: ToJSONKeyFunction [SubworldName]
toJSONKeyList :: ToJSONKeyFunction [SubworldName]
ToJSONKey)

instance FromJSON SubworldName where
  parseJSON :: Value -> Parser SubworldName
parseJSON = String
-> (Text -> Parser SubworldName) -> Value -> Parser SubworldName
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"subworld name" ((Text -> Parser SubworldName) -> Value -> Parser SubworldName)
-> (Text -> Parser SubworldName) -> Value -> Parser SubworldName
forall a b. (a -> b) -> a -> b
$ SubworldName -> Parser SubworldName
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (SubworldName -> Parser SubworldName)
-> (Text -> SubworldName) -> Text -> Parser SubworldName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> SubworldName
SubworldName

renderWorldName :: SubworldName -> Text
renderWorldName :: SubworldName -> Text
renderWorldName = \case
  SubworldName Text
s -> Text
s
  SubworldName
DefaultRootSubworld -> Text
"<default>"

renderQuotedWorldName :: SubworldName -> Text
renderQuotedWorldName :: SubworldName -> Text
renderQuotedWorldName = \case
  SubworldName Text
s -> Text -> Text
quote Text
s
  SubworldName
DefaultRootSubworld -> Text
"<default>"

-- * Universal location

-- | The swarm universe consists of locations
-- indexed by subworld.
-- Not only is this parameterized datatype useful for planar (2D)
-- coordinates, but is also used for named waypoints.
data Cosmic a = Cosmic
  { forall a. Cosmic a -> SubworldName
_subworld :: SubworldName
  , forall a. Cosmic a -> a
_planar :: a
  }
  deriving (Int -> Cosmic a -> ShowS
[Cosmic a] -> ShowS
Cosmic a -> String
(Int -> Cosmic a -> ShowS)
-> (Cosmic a -> String) -> ([Cosmic a] -> ShowS) -> Show (Cosmic a)
forall a. Show a => Int -> Cosmic a -> ShowS
forall a. Show a => [Cosmic a] -> ShowS
forall a. Show a => Cosmic a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Cosmic a -> ShowS
showsPrec :: Int -> Cosmic a -> ShowS
$cshow :: forall a. Show a => Cosmic a -> String
show :: Cosmic a -> String
$cshowList :: forall a. Show a => [Cosmic a] -> ShowS
showList :: [Cosmic a] -> ShowS
Show, Cosmic a -> Cosmic a -> Bool
(Cosmic a -> Cosmic a -> Bool)
-> (Cosmic a -> Cosmic a -> Bool) -> Eq (Cosmic a)
forall a. Eq a => Cosmic a -> Cosmic a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Cosmic a -> Cosmic a -> Bool
== :: Cosmic a -> Cosmic a -> Bool
$c/= :: forall a. Eq a => Cosmic a -> Cosmic a -> Bool
/= :: Cosmic a -> Cosmic a -> Bool
Eq, Eq (Cosmic a)
Eq (Cosmic a) =>
(Cosmic a -> Cosmic a -> Ordering)
-> (Cosmic a -> Cosmic a -> Bool)
-> (Cosmic a -> Cosmic a -> Bool)
-> (Cosmic a -> Cosmic a -> Bool)
-> (Cosmic a -> Cosmic a -> Bool)
-> (Cosmic a -> Cosmic a -> Cosmic a)
-> (Cosmic a -> Cosmic a -> Cosmic a)
-> Ord (Cosmic a)
Cosmic a -> Cosmic a -> Bool
Cosmic a -> Cosmic a -> Ordering
Cosmic a -> Cosmic a -> Cosmic a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Cosmic a)
forall a. Ord a => Cosmic a -> Cosmic a -> Bool
forall a. Ord a => Cosmic a -> Cosmic a -> Ordering
forall a. Ord a => Cosmic a -> Cosmic a -> Cosmic a
$ccompare :: forall a. Ord a => Cosmic a -> Cosmic a -> Ordering
compare :: Cosmic a -> Cosmic a -> Ordering
$c< :: forall a. Ord a => Cosmic a -> Cosmic a -> Bool
< :: Cosmic a -> Cosmic a -> Bool
$c<= :: forall a. Ord a => Cosmic a -> Cosmic a -> Bool
<= :: Cosmic a -> Cosmic a -> Bool
$c> :: forall a. Ord a => Cosmic a -> Cosmic a -> Bool
> :: Cosmic a -> Cosmic a -> Bool
$c>= :: forall a. Ord a => Cosmic a -> Cosmic a -> Bool
>= :: Cosmic a -> Cosmic a -> Bool
$cmax :: forall a. Ord a => Cosmic a -> Cosmic a -> Cosmic a
max :: Cosmic a -> Cosmic a -> Cosmic a
$cmin :: forall a. Ord a => Cosmic a -> Cosmic a -> Cosmic a
min :: Cosmic a -> Cosmic a -> Cosmic a
Ord, (forall a b. (a -> b) -> Cosmic a -> Cosmic b)
-> (forall a b. a -> Cosmic b -> Cosmic a) -> Functor Cosmic
forall a b. a -> Cosmic b -> Cosmic a
forall a b. (a -> b) -> Cosmic a -> Cosmic b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Cosmic a -> Cosmic b
fmap :: forall a b. (a -> b) -> Cosmic a -> Cosmic b
$c<$ :: forall a b. a -> Cosmic b -> Cosmic a
<$ :: forall a b. a -> Cosmic b -> Cosmic a
Functor, (forall x. Cosmic a -> Rep (Cosmic a) x)
-> (forall x. Rep (Cosmic a) x -> Cosmic a) -> Generic (Cosmic a)
forall x. Rep (Cosmic a) x -> Cosmic a
forall x. Cosmic a -> Rep (Cosmic a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Cosmic a) x -> Cosmic a
forall a x. Cosmic a -> Rep (Cosmic a) x
$cfrom :: forall a x. Cosmic a -> Rep (Cosmic a) x
from :: forall x. Cosmic a -> Rep (Cosmic a) x
$cto :: forall a x. Rep (Cosmic a) x -> Cosmic a
to :: forall x. Rep (Cosmic a) x -> Cosmic a
Generic, [Cosmic a] -> Value
[Cosmic a] -> Encoding
Cosmic a -> Bool
Cosmic a -> Value
Cosmic a -> Encoding
(Cosmic a -> Value)
-> (Cosmic a -> Encoding)
-> ([Cosmic a] -> Value)
-> ([Cosmic a] -> Encoding)
-> (Cosmic a -> Bool)
-> ToJSON (Cosmic a)
forall a. ToJSON a => [Cosmic a] -> Value
forall a. ToJSON a => [Cosmic a] -> Encoding
forall a. ToJSON a => Cosmic a -> Bool
forall a. ToJSON a => Cosmic a -> Value
forall a. ToJSON a => Cosmic a -> Encoding
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: forall a. ToJSON a => Cosmic a -> Value
toJSON :: Cosmic a -> Value
$ctoEncoding :: forall a. ToJSON a => Cosmic a -> Encoding
toEncoding :: Cosmic a -> Encoding
$ctoJSONList :: forall a. ToJSON a => [Cosmic a] -> Value
toJSONList :: [Cosmic a] -> Value
$ctoEncodingList :: forall a. ToJSON a => [Cosmic a] -> Encoding
toEncodingList :: [Cosmic a] -> Encoding
$comitField :: forall a. ToJSON a => Cosmic a -> Bool
omitField :: Cosmic a -> Bool
ToJSON, ToJSONKeyFunction [Cosmic a]
ToJSONKeyFunction (Cosmic a)
ToJSONKeyFunction (Cosmic a)
-> ToJSONKeyFunction [Cosmic a] -> ToJSONKey (Cosmic a)
forall a.
ToJSONKeyFunction a -> ToJSONKeyFunction [a] -> ToJSONKey a
forall a. ToJSON a => ToJSONKeyFunction [Cosmic a]
forall a. ToJSON a => ToJSONKeyFunction (Cosmic a)
$ctoJSONKey :: forall a. ToJSON a => ToJSONKeyFunction (Cosmic a)
toJSONKey :: ToJSONKeyFunction (Cosmic a)
$ctoJSONKeyList :: forall a. ToJSON a => ToJSONKeyFunction [Cosmic a]
toJSONKeyList :: ToJSONKeyFunction [Cosmic a]
ToJSONKey)

makeLenses ''Cosmic

instance (FromJSON a) => FromJSON (Cosmic a) where
  parseJSON :: Value -> Parser (Cosmic a)
parseJSON Value
x = case Value
x of
    Object Object
v -> do
      SubworldName
_subworld <- Object
v Object -> Key -> Parser SubworldName
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"subworld"
      a
_planar <- Object
v Object -> Key -> Parser a
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"loc"
      Cosmic a -> Parser (Cosmic a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Cosmic {a
SubworldName
_subworld :: SubworldName
_planar :: a
_subworld :: SubworldName
_planar :: a
..}
    Value
_ -> SubworldName -> a -> Cosmic a
forall a. SubworldName -> a -> Cosmic a
Cosmic SubworldName
DefaultRootSubworld (a -> Cosmic a) -> Parser a -> Parser (Cosmic a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Parser a
forall a. FromJSON a => Value -> Parser a
parseJSON Value
x

-- * Measurement

data DistanceMeasure b = Measurable b | InfinitelyFar
  deriving (DistanceMeasure b -> DistanceMeasure b -> Bool
(DistanceMeasure b -> DistanceMeasure b -> Bool)
-> (DistanceMeasure b -> DistanceMeasure b -> Bool)
-> Eq (DistanceMeasure b)
forall b. Eq b => DistanceMeasure b -> DistanceMeasure b -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall b. Eq b => DistanceMeasure b -> DistanceMeasure b -> Bool
== :: DistanceMeasure b -> DistanceMeasure b -> Bool
$c/= :: forall b. Eq b => DistanceMeasure b -> DistanceMeasure b -> Bool
/= :: DistanceMeasure b -> DistanceMeasure b -> Bool
Eq, Eq (DistanceMeasure b)
Eq (DistanceMeasure b) =>
(DistanceMeasure b -> DistanceMeasure b -> Ordering)
-> (DistanceMeasure b -> DistanceMeasure b -> Bool)
-> (DistanceMeasure b -> DistanceMeasure b -> Bool)
-> (DistanceMeasure b -> DistanceMeasure b -> Bool)
-> (DistanceMeasure b -> DistanceMeasure b -> Bool)
-> (DistanceMeasure b -> DistanceMeasure b -> DistanceMeasure b)
-> (DistanceMeasure b -> DistanceMeasure b -> DistanceMeasure b)
-> Ord (DistanceMeasure b)
DistanceMeasure b -> DistanceMeasure b -> Bool
DistanceMeasure b -> DistanceMeasure b -> Ordering
DistanceMeasure b -> DistanceMeasure b -> DistanceMeasure b
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall b. Ord b => Eq (DistanceMeasure b)
forall b. Ord b => DistanceMeasure b -> DistanceMeasure b -> Bool
forall b.
Ord b =>
DistanceMeasure b -> DistanceMeasure b -> Ordering
forall b.
Ord b =>
DistanceMeasure b -> DistanceMeasure b -> DistanceMeasure b
$ccompare :: forall b.
Ord b =>
DistanceMeasure b -> DistanceMeasure b -> Ordering
compare :: DistanceMeasure b -> DistanceMeasure b -> Ordering
$c< :: forall b. Ord b => DistanceMeasure b -> DistanceMeasure b -> Bool
< :: DistanceMeasure b -> DistanceMeasure b -> Bool
$c<= :: forall b. Ord b => DistanceMeasure b -> DistanceMeasure b -> Bool
<= :: DistanceMeasure b -> DistanceMeasure b -> Bool
$c> :: forall b. Ord b => DistanceMeasure b -> DistanceMeasure b -> Bool
> :: DistanceMeasure b -> DistanceMeasure b -> Bool
$c>= :: forall b. Ord b => DistanceMeasure b -> DistanceMeasure b -> Bool
>= :: DistanceMeasure b -> DistanceMeasure b -> Bool
$cmax :: forall b.
Ord b =>
DistanceMeasure b -> DistanceMeasure b -> DistanceMeasure b
max :: DistanceMeasure b -> DistanceMeasure b -> DistanceMeasure b
$cmin :: forall b.
Ord b =>
DistanceMeasure b -> DistanceMeasure b -> DistanceMeasure b
min :: DistanceMeasure b -> DistanceMeasure b -> DistanceMeasure b
Ord)

getFiniteDistance :: DistanceMeasure b -> Maybe b
getFiniteDistance :: forall b. DistanceMeasure b -> Maybe b
getFiniteDistance = \case
  Measurable b
x -> b -> Maybe b
forall a. a -> Maybe a
Just b
x
  DistanceMeasure b
InfinitelyFar -> Maybe b
forall a. Maybe a
Nothing

-- | Returns 'InfinitelyFar' if not within the same subworld.
cosmoMeasure :: (a -> a -> b) -> Cosmic a -> Cosmic a -> DistanceMeasure b
cosmoMeasure :: forall a b.
(a -> a -> b) -> Cosmic a -> Cosmic a -> DistanceMeasure b
cosmoMeasure a -> a -> b
f Cosmic a
a Cosmic a
b
  | (SubworldName -> SubworldName -> Bool
forall a. Eq 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
a Cosmic a
b = DistanceMeasure b
forall b. DistanceMeasure b
InfinitelyFar
  | Bool
otherwise = b -> DistanceMeasure b
forall b. b -> DistanceMeasure b
Measurable (b -> DistanceMeasure b) -> b -> DistanceMeasure b
forall a b. (a -> b) -> a -> b
$ (a -> a -> b
f (a -> a -> b) -> (Cosmic a -> a) -> Cosmic a -> Cosmic a -> b
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` 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 a a (f :: * -> *).
Functor f =>
(a -> f a) -> Cosmic a -> f (Cosmic a)
planar) Cosmic a
a Cosmic a
b

-- * Utilities

defaultCosmicLocation :: Cosmic Location
defaultCosmicLocation :: Cosmic Location
defaultCosmicLocation = SubworldName -> Location -> Cosmic Location
forall a. SubworldName -> a -> Cosmic a
Cosmic SubworldName
DefaultRootSubworld Location
forall (f :: * -> *) a. (Additive f, Num a) => Point f a
origin

offsetBy :: Cosmic Location -> V2 Int32 -> Cosmic Location
offsetBy :: Cosmic Location -> V2 Int32 -> Cosmic Location
offsetBy Cosmic Location
loc V2 Int32
v = (Location -> Location) -> Cosmic Location -> Cosmic Location
forall a b. (a -> b) -> Cosmic a -> Cosmic b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Location -> Diff (Point V2) Int32 -> Location
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 Int32
Diff (Point V2) Int32
v) Cosmic Location
loc

-- ** Rendering

locationToString :: Location -> String
locationToString :: Location -> String
locationToString (Location Int32
x Int32
y) =
  [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Int32 -> String) -> [Int32] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Int32 -> String
forall a. Show a => a -> String
show [Int32
x, Int32
y]

renderCoordsString :: Cosmic Location -> String
renderCoordsString :: Cosmic Location -> String
renderCoordsString (Cosmic SubworldName
sw Location
coords) =
  [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ Location -> String
locationToString Location
coords String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
suffix
 where
  suffix :: [String]
suffix = case SubworldName
sw of
    SubworldName
DefaultRootSubworld -> []
    SubworldName Text
swName -> [String
"in", Text -> String
T.unpack Text
swName]