{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}
module Swarm.Game.Scenario.Topography.Cell (
PCell (..),
Cell,
AugmentedCell (..),
CellPaintDisplay,
) where
import Control.Lens hiding (from, (.=), (<.>))
import Control.Monad.Extra (mapMaybeM)
import Data.List.NonEmpty qualified as NE
import Data.Maybe (catMaybes, listToMaybe)
import Data.Text (Text)
import Data.Vector qualified as V
import Data.Yaml as Y
import Swarm.Game.Entity hiding (empty)
import Swarm.Game.Scenario.RobotLookup
import Swarm.Game.Scenario.Topography.EntityFacade
import Swarm.Game.Scenario.Topography.Navigation.Waypoint (WaypointConfig)
import Swarm.Game.Terrain
import Swarm.Util.Erasable (Erasable (..))
import Swarm.Util.Yaml
data PCell e = Cell
{ forall e. PCell e -> TerrainType
cellTerrain :: TerrainType
, forall e. PCell e -> Erasable e
cellEntity :: Erasable e
, forall e. PCell e -> [IndexedTRobot]
cellRobots :: [IndexedTRobot]
}
deriving (PCell e -> PCell e -> Bool
forall e. Eq e => PCell e -> PCell e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PCell e -> PCell e -> Bool
$c/= :: forall e. Eq e => PCell e -> PCell e -> Bool
== :: PCell e -> PCell e -> Bool
$c== :: forall e. Eq e => PCell e -> PCell e -> Bool
Eq, Int -> PCell e -> ShowS
forall e. Show e => Int -> PCell e -> ShowS
forall e. Show e => [PCell e] -> ShowS
forall e. Show e => PCell e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PCell e] -> ShowS
$cshowList :: forall e. Show e => [PCell e] -> ShowS
show :: PCell e -> String
$cshow :: forall e. Show e => PCell e -> String
showsPrec :: Int -> PCell e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> PCell e -> ShowS
Show)
type Cell = PCell Entity
data AugmentedCell e = AugmentedCell
{ forall e. AugmentedCell e -> Maybe WaypointConfig
waypointCfg :: Maybe WaypointConfig
, forall e. AugmentedCell e -> PCell e
standardCell :: PCell e
}
deriving (AugmentedCell e -> AugmentedCell e -> Bool
forall e. Eq e => AugmentedCell e -> AugmentedCell e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AugmentedCell e -> AugmentedCell e -> Bool
$c/= :: forall e. Eq e => AugmentedCell e -> AugmentedCell e -> Bool
== :: AugmentedCell e -> AugmentedCell e -> Bool
$c== :: forall e. Eq e => AugmentedCell e -> AugmentedCell e -> Bool
Eq, Int -> AugmentedCell e -> ShowS
forall e. Show e => Int -> AugmentedCell e -> ShowS
forall e. Show e => [AugmentedCell e] -> ShowS
forall e. Show e => AugmentedCell e -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AugmentedCell e] -> ShowS
$cshowList :: forall e. Show e => [AugmentedCell e] -> ShowS
show :: AugmentedCell e -> String
$cshow :: forall e. Show e => AugmentedCell e -> String
showsPrec :: Int -> AugmentedCell e -> ShowS
$cshowsPrec :: forall e. Show e => Int -> AugmentedCell e -> ShowS
Show)
mkPCellJson :: ToJSON b => (Erasable a -> Maybe b) -> PCell a -> Value
mkPCellJson :: forall b a. ToJSON b => (Erasable a -> Maybe b) -> PCell a -> Value
mkPCellJson Erasable a -> Maybe b
modifier PCell a
x =
forall a. ToJSON a => a -> Value
toJSON forall a b. (a -> b) -> a -> b
$
forall a. [Maybe a] -> [a]
catMaybes
[ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. TerrainType -> Text
getTerrainWord forall a b. (a -> b) -> a -> b
$ forall e. PCell e -> TerrainType
cellTerrain PCell a
x
, forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. Erasable a -> Maybe b
modifier forall a b. (a -> b) -> a -> b
$ forall e. PCell e -> Erasable e
cellEntity PCell a
x
, forall a. [a] -> Maybe a
listToMaybe []
]
instance ToJSON Cell where
toJSON :: Cell -> Value
toJSON = forall b a. ToJSON b => (Erasable a -> Maybe b) -> PCell a -> Value
mkPCellJson forall a b. (a -> b) -> a -> b
$ \case
Erasable Entity
EErase -> forall a. a -> Maybe a
Just Text
"erase"
Erasable Entity
ENothing -> forall a. Maybe a
Nothing
EJust Entity
e -> forall a. a -> Maybe a
Just (Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName)
instance FromJSONE (EntityMap, RobotMap) Cell where
parseJSONE :: Value -> ParserE (EntityMap, RobotMap) Cell
parseJSONE = forall e a.
String -> (Array -> ParserE e a) -> Value -> ParserE e a
withArrayE String
"tuple" forall a b. (a -> b) -> a -> b
$ \Array
v -> do
let tupRaw :: [Value]
tupRaw = forall a. Vector a -> [a]
V.toList Array
v
NonEmpty Value
tup <- case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Value]
tupRaw of
Maybe (NonEmpty Value)
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"palette entry must have nonzero length (terrain, optional entity and then robots if any)"
Just NonEmpty Value
x -> forall (m :: * -> *) a. Monad m => a -> m a
return NonEmpty Value
x
TerrainType
terr <- forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => Value -> Parser a
parseJSON (forall a. NonEmpty a -> a
NE.head NonEmpty Value
tup)
Erasable Entity
ent <- case NonEmpty Value
tup forall s a. s -> Getting (First a) s a -> Maybe a
^? forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
1 of
Maybe Value
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall e. Erasable e
ENothing
Just Value
e -> do
Maybe Text
meName <- forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => Value -> Parser a
parseJSON @(Maybe Text) Value
e
case Maybe Text
meName of
Maybe Text
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall e. Erasable e
ENothing
Just Text
"erase" -> forall (m :: * -> *) a. Monad m => a -> m a
return forall e. Erasable e
EErase
Just Text
name -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. e -> Erasable e
EJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e' e (f :: * -> *) a. (e' -> e) -> With e f a -> With e' f a
localE forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Text -> ParserE EntityMap Entity
getEntity Text
name
let name2rob :: Value -> With (a, RobotMap) Parser (Maybe IndexedTRobot)
name2rob Value
r = do
Maybe RobotName
mrName <- forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => Value -> Parser a
parseJSON @(Maybe RobotName) Value
r
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall e' e (f :: * -> *) a. (e' -> e) -> With e f a -> With e' f a
localE forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. RobotName -> ParserE RobotMap IndexedTRobot
getRobot) Maybe RobotName
mrName
[IndexedTRobot]
robs <- forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM forall {a}.
Value -> With (a, RobotMap) Parser (Maybe IndexedTRobot)
name2rob (forall a. Int -> [a] -> [a]
drop Int
2 [Value]
tupRaw)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. TerrainType -> Erasable e -> [IndexedTRobot] -> PCell e
Cell TerrainType
terr Erasable Entity
ent [IndexedTRobot]
robs
instance FromJSONE (EntityMap, RobotMap) (AugmentedCell Entity) where
parseJSONE :: Value -> ParserE (EntityMap, RobotMap) (AugmentedCell Entity)
parseJSONE Value
x = case Value
x of
Object Object
v -> forall {e} {e}.
FromJSONE e (PCell e) =>
Object -> With e Parser (AugmentedCell e)
objParse Object
v
Value
z -> forall e. Maybe WaypointConfig -> PCell e -> AugmentedCell e
AugmentedCell forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e a. FromJSONE e a => Value -> ParserE e a
parseJSONE Value
z
where
objParse :: Object -> With e Parser (AugmentedCell e)
objParse Object
v =
forall e. Maybe WaypointConfig -> PCell e -> AugmentedCell e
AugmentedCell
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"waypoint")
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v
forall e a. FromJSONE e a => Object -> Text -> ParserE e a
..: Text
"cell"
type CellPaintDisplay = PCell EntityFacade
instance ToJSON CellPaintDisplay where
toJSON :: CellPaintDisplay -> Value
toJSON = forall b a. ToJSON b => (Erasable a -> Maybe b) -> PCell a -> Value
mkPCellJson forall a b. (a -> b) -> a -> b
$ \case
Erasable EntityFacade
ENothing -> forall a. Maybe a
Nothing
Erasable EntityFacade
EErase -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Display -> EntityFacade
EntityFacade Text
"erase" forall a. Monoid a => a
mempty
EJust EntityFacade
e -> forall a. a -> Maybe a
Just EntityFacade
e