{-# LANGUAGE OverloadedStrings #-}
{-# 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.Function (on)
import Data.Int (Int32)
import Data.Text (Text)
import Data.Yaml (FromJSON, ToJSON, Value (Object), parseJSON, withText, (.:))
import GHC.Generics (Generic)
import Linear (V2 (..))
import Swarm.Game.Location

-- * Referring to subworlds

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

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

-- * 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
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
showList :: [Cosmic a] -> ShowS
$cshowList :: forall a. Show a => [Cosmic a] -> ShowS
show :: Cosmic a -> String
$cshow :: forall a. Show a => Cosmic a -> String
showsPrec :: Int -> Cosmic a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Cosmic a -> ShowS
Show, Cosmic a -> Cosmic a -> Bool
forall a. Eq a => Cosmic a -> Cosmic a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Cosmic a -> Cosmic a -> Bool
$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
Eq, Cosmic a -> Cosmic a -> Bool
Cosmic a -> Cosmic a -> Ordering
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
min :: Cosmic a -> Cosmic a -> Cosmic a
$cmin :: forall a. Ord a => Cosmic a -> Cosmic a -> Cosmic a
max :: Cosmic a -> Cosmic a -> Cosmic a
$cmax :: forall a. Ord a => Cosmic a -> Cosmic a -> Cosmic a
>= :: 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
$c< :: forall a. Ord a => Cosmic a -> Cosmic a -> Bool
compare :: Cosmic a -> Cosmic a -> Ordering
$ccompare :: forall a. Ord a => Cosmic a -> Cosmic a -> Ordering
Ord, 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
<$ :: forall a b. a -> Cosmic b -> Cosmic a
$c<$ :: forall a b. a -> Cosmic b -> Cosmic a
fmap :: forall a b. (a -> b) -> Cosmic a -> Cosmic b
$cfmap :: forall a b. (a -> b) -> Cosmic a -> Cosmic b
Functor, 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
$cto :: forall a x. Rep (Cosmic a) x -> Cosmic a
$cfrom :: forall a x. Cosmic a -> Rep (Cosmic a) x
Generic, forall a. ToJSON a => [Cosmic a] -> Encoding
forall a. ToJSON a => [Cosmic a] -> Value
forall a. ToJSON a => Cosmic a -> Encoding
forall a. ToJSON a => Cosmic a -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Cosmic a] -> Encoding
$ctoEncodingList :: forall a. ToJSON a => [Cosmic a] -> Encoding
toJSONList :: [Cosmic a] -> Value
$ctoJSONList :: forall a. ToJSON a => [Cosmic a] -> Value
toEncoding :: Cosmic a -> Encoding
$ctoEncoding :: forall a. ToJSON a => Cosmic a -> Encoding
toJSON :: Cosmic a -> Value
$ctoJSON :: forall a. ToJSON a => Cosmic a -> Value
ToJSON)

makeLenses ''Cosmic

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

-- * Measurement

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

getFiniteDistance :: DistanceMeasure b -> Maybe b
getFiniteDistance :: forall b. DistanceMeasure b -> Maybe b
getFiniteDistance = \case
  Measurable b
x -> forall a. a -> Maybe a
Just b
x
  DistanceMeasure b
InfinitelyFar -> 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
  | (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 a
a Cosmic a
b = forall b. DistanceMeasure b
InfinitelyFar
  | Bool
otherwise = forall b. b -> DistanceMeasure b
Measurable forall a b. (a -> b) -> a -> b
$ (a -> a -> b
f 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 a. Lens (Cosmic a) (Cosmic a) a a
planar) Cosmic a
a Cosmic a
b

-- * Utilities

defaultCosmicLocation :: Cosmic Location
defaultCosmicLocation :: Cosmic Location
defaultCosmicLocation = forall a. SubworldName -> a -> Cosmic a
Cosmic SubworldName
DefaultRootSubworld 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ V2 Int32
v) Cosmic Location
loc