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

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Landmarks that are used to specify portal locations
-- and can serve as navigation aids via the `waypoint` command.
--
-- = Waypoint ordering
--
-- The sequence of waypoints of a given name is dictated by criteria in the following order:
--
-- 1. Ordering of structure placements
--    (see implementation of 'Swarm.Game.Scenario.Topography.Structure.mergeStructures');
--    later placements are ordered first.
-- 2. Placement of cells within a map. Map locations go by row-major order
--    (compare to docs for 'Swarm.Game.State.genRobotTemplates').
--
-- TODO (#1366): May be useful to have a mechanism for more
-- precise control of ordering.
module Swarm.Game.Scenario.Topography.Navigation.Waypoint where

import Data.Text qualified as T
import Data.Yaml as Y
import GHC.Generics (Generic)
import Swarm.Game.Location
import Swarm.Game.Scenario.Topography.Placement

-- | This type is isomorphic to 'Maybe'.
data Parentage a
  = WithParent a
  | Root
  deriving (Int -> Parentage a -> ShowS
[Parentage a] -> ShowS
Parentage a -> String
(Int -> Parentage a -> ShowS)
-> (Parentage a -> String)
-> ([Parentage a] -> ShowS)
-> Show (Parentage a)
forall a. Show a => Int -> Parentage a -> ShowS
forall a. Show a => [Parentage a] -> ShowS
forall a. Show a => Parentage a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Parentage a -> ShowS
showsPrec :: Int -> Parentage a -> ShowS
$cshow :: forall a. Show a => Parentage a -> String
show :: Parentage a -> String
$cshowList :: forall a. Show a => [Parentage a] -> ShowS
showList :: [Parentage a] -> ShowS
Show, Parentage a -> Parentage a -> Bool
(Parentage a -> Parentage a -> Bool)
-> (Parentage a -> Parentage a -> Bool) -> Eq (Parentage a)
forall a. Eq a => Parentage a -> Parentage a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Parentage a -> Parentage a -> Bool
== :: Parentage a -> Parentage a -> Bool
$c/= :: forall a. Eq a => Parentage a -> Parentage a -> Bool
/= :: Parentage a -> Parentage a -> Bool
Eq)

-- | Indicates which structure something came from
-- for debugging purposes.
data Originated a = Originated
  { forall a. Originated a -> Parentage Placement
parent :: Parentage Placement
  , forall a. Originated a -> a
value :: a
  }
  deriving (Int -> Originated a -> ShowS
[Originated a] -> ShowS
Originated a -> String
(Int -> Originated a -> ShowS)
-> (Originated a -> String)
-> ([Originated a] -> ShowS)
-> Show (Originated a)
forall a. Show a => Int -> Originated a -> ShowS
forall a. Show a => [Originated a] -> ShowS
forall a. Show a => Originated a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Originated a -> ShowS
showsPrec :: Int -> Originated a -> ShowS
$cshow :: forall a. Show a => Originated a -> String
show :: Originated a -> String
$cshowList :: forall a. Show a => [Originated a] -> ShowS
showList :: [Originated a] -> ShowS
Show, Originated a -> Originated a -> Bool
(Originated a -> Originated a -> Bool)
-> (Originated a -> Originated a -> Bool) -> Eq (Originated a)
forall a. Eq a => Originated a -> Originated a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Originated a -> Originated a -> Bool
== :: Originated a -> Originated a -> Bool
$c/= :: forall a. Eq a => Originated a -> Originated a -> Bool
/= :: Originated a -> Originated a -> Bool
Eq, (forall a b. (a -> b) -> Originated a -> Originated b)
-> (forall a b. a -> Originated b -> Originated a)
-> Functor Originated
forall a b. a -> Originated b -> Originated a
forall a b. (a -> b) -> Originated a -> Originated 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) -> Originated a -> Originated b
fmap :: forall a b. (a -> b) -> Originated a -> Originated b
$c<$ :: forall a b. a -> Originated b -> Originated a
<$ :: forall a b. a -> Originated b -> Originated a
Functor)

newtype WaypointName = WaypointName T.Text
  deriving (Int -> WaypointName -> ShowS
[WaypointName] -> ShowS
WaypointName -> String
(Int -> WaypointName -> ShowS)
-> (WaypointName -> String)
-> ([WaypointName] -> ShowS)
-> Show WaypointName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WaypointName -> ShowS
showsPrec :: Int -> WaypointName -> ShowS
$cshow :: WaypointName -> String
show :: WaypointName -> String
$cshowList :: [WaypointName] -> ShowS
showList :: [WaypointName] -> ShowS
Show, WaypointName -> WaypointName -> Bool
(WaypointName -> WaypointName -> Bool)
-> (WaypointName -> WaypointName -> Bool) -> Eq WaypointName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WaypointName -> WaypointName -> Bool
== :: WaypointName -> WaypointName -> Bool
$c/= :: WaypointName -> WaypointName -> Bool
/= :: WaypointName -> WaypointName -> Bool
Eq, Eq WaypointName
Eq WaypointName =>
(WaypointName -> WaypointName -> Ordering)
-> (WaypointName -> WaypointName -> Bool)
-> (WaypointName -> WaypointName -> Bool)
-> (WaypointName -> WaypointName -> Bool)
-> (WaypointName -> WaypointName -> Bool)
-> (WaypointName -> WaypointName -> WaypointName)
-> (WaypointName -> WaypointName -> WaypointName)
-> Ord WaypointName
WaypointName -> WaypointName -> Bool
WaypointName -> WaypointName -> Ordering
WaypointName -> WaypointName -> WaypointName
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 :: WaypointName -> WaypointName -> Ordering
compare :: WaypointName -> WaypointName -> Ordering
$c< :: WaypointName -> WaypointName -> Bool
< :: WaypointName -> WaypointName -> Bool
$c<= :: WaypointName -> WaypointName -> Bool
<= :: WaypointName -> WaypointName -> Bool
$c> :: WaypointName -> WaypointName -> Bool
> :: WaypointName -> WaypointName -> Bool
$c>= :: WaypointName -> WaypointName -> Bool
>= :: WaypointName -> WaypointName -> Bool
$cmax :: WaypointName -> WaypointName -> WaypointName
max :: WaypointName -> WaypointName -> WaypointName
$cmin :: WaypointName -> WaypointName -> WaypointName
min :: WaypointName -> WaypointName -> WaypointName
Ord, (forall x. WaypointName -> Rep WaypointName x)
-> (forall x. Rep WaypointName x -> WaypointName)
-> Generic WaypointName
forall x. Rep WaypointName x -> WaypointName
forall x. WaypointName -> Rep WaypointName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. WaypointName -> Rep WaypointName x
from :: forall x. WaypointName -> Rep WaypointName x
$cto :: forall x. Rep WaypointName x -> WaypointName
to :: forall x. Rep WaypointName x -> WaypointName
Generic, Maybe WaypointName
Value -> Parser [WaypointName]
Value -> Parser WaypointName
(Value -> Parser WaypointName)
-> (Value -> Parser [WaypointName])
-> Maybe WaypointName
-> FromJSON WaypointName
forall a.
(Value -> Parser a)
-> (Value -> Parser [a]) -> Maybe a -> FromJSON a
$cparseJSON :: Value -> Parser WaypointName
parseJSON :: Value -> Parser WaypointName
$cparseJSONList :: Value -> Parser [WaypointName]
parseJSONList :: Value -> Parser [WaypointName]
$comittedField :: Maybe WaypointName
omittedField :: Maybe WaypointName
FromJSON)

-- | Metadata about a waypoint
data WaypointConfig = WaypointConfig
  { WaypointConfig -> WaypointName
wpName :: WaypointName
  , WaypointConfig -> Bool
wpUnique :: Bool
  -- ^ Enforce global uniqueness of this waypoint
  }
  deriving (Int -> WaypointConfig -> ShowS
[WaypointConfig] -> ShowS
WaypointConfig -> String
(Int -> WaypointConfig -> ShowS)
-> (WaypointConfig -> String)
-> ([WaypointConfig] -> ShowS)
-> Show WaypointConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WaypointConfig -> ShowS
showsPrec :: Int -> WaypointConfig -> ShowS
$cshow :: WaypointConfig -> String
show :: WaypointConfig -> String
$cshowList :: [WaypointConfig] -> ShowS
showList :: [WaypointConfig] -> ShowS
Show, WaypointConfig -> WaypointConfig -> Bool
(WaypointConfig -> WaypointConfig -> Bool)
-> (WaypointConfig -> WaypointConfig -> Bool) -> Eq WaypointConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WaypointConfig -> WaypointConfig -> Bool
== :: WaypointConfig -> WaypointConfig -> Bool
$c/= :: WaypointConfig -> WaypointConfig -> Bool
/= :: WaypointConfig -> WaypointConfig -> Bool
Eq)

parseWaypointConfig :: Object -> Parser WaypointConfig
parseWaypointConfig :: Object -> Parser WaypointConfig
parseWaypointConfig Object
v = do
  WaypointName
wpName <- Object
v Object -> Key -> Parser WaypointName
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
  Bool
wpUnique <- Object
v Object -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"unique" Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False
  WaypointConfig -> Parser WaypointConfig
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WaypointConfig {Bool
WaypointName
wpName :: WaypointName
wpUnique :: Bool
wpName :: WaypointName
wpUnique :: Bool
..}

instance FromJSON WaypointConfig where
  parseJSON :: Value -> Parser WaypointConfig
parseJSON = String
-> (Object -> Parser WaypointConfig)
-> Value
-> Parser WaypointConfig
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Waypoint Config" Object -> Parser WaypointConfig
parseWaypointConfig

-- |
-- A parent world shouldn't have to know the exact layout of a subworld
-- to specify where exactly a portal will deliver a robot to within the subworld.
-- Therefore, we define named waypoints in the subworld and the parent world
-- must reference them by name, rather than by coordinate.
data Waypoint = Waypoint
  { Waypoint -> WaypointConfig
wpConfig :: WaypointConfig
  , Waypoint -> Location
wpLoc :: Location
  }
  deriving (Int -> Waypoint -> ShowS
[Waypoint] -> ShowS
Waypoint -> String
(Int -> Waypoint -> ShowS)
-> (Waypoint -> String) -> ([Waypoint] -> ShowS) -> Show Waypoint
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Waypoint -> ShowS
showsPrec :: Int -> Waypoint -> ShowS
$cshow :: Waypoint -> String
show :: Waypoint -> String
$cshowList :: [Waypoint] -> ShowS
showList :: [Waypoint] -> ShowS
Show, Waypoint -> Waypoint -> Bool
(Waypoint -> Waypoint -> Bool)
-> (Waypoint -> Waypoint -> Bool) -> Eq Waypoint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Waypoint -> Waypoint -> Bool
== :: Waypoint -> Waypoint -> Bool
$c/= :: Waypoint -> Waypoint -> Bool
/= :: Waypoint -> Waypoint -> Bool
Eq)

-- | JSON representation is flattened; all keys are at the same level,
-- in contrast with the underlying record.
instance FromJSON Waypoint where
  parseJSON :: Value -> Parser Waypoint
parseJSON = String -> (Object -> Parser Waypoint) -> Value -> Parser Waypoint
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Waypoint" ((Object -> Parser Waypoint) -> Value -> Parser Waypoint)
-> (Object -> Parser Waypoint) -> Value -> Parser Waypoint
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    WaypointConfig
wpConfig <- Object -> Parser WaypointConfig
parseWaypointConfig Object
v
    Location
wpLoc <- Object
v Object -> Key -> Parser Location
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"loc"
    Waypoint -> Parser Waypoint
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Waypoint {Location
WaypointConfig
wpConfig :: WaypointConfig
wpLoc :: Location
wpConfig :: WaypointConfig
wpLoc :: Location
..}

instance HasLocation Waypoint where
  modifyLoc :: (Location -> Location) -> Waypoint -> Waypoint
modifyLoc Location -> Location
f (Waypoint WaypointConfig
cfg Location
originalLoc) = WaypointConfig -> Location -> Waypoint
Waypoint WaypointConfig
cfg (Location -> Waypoint) -> Location -> Waypoint
forall a b. (a -> b) -> a -> b
$ Location -> Location
f Location
originalLoc