{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
module Swarm.Game.Scenario.Topography.Cell (
  PCell (..),
  Cell,
  AugmentedCell,
  CellPaintDisplay,
  cellToEntity,
) where

import Control.Lens hiding (from, (.=), (<.>))
import Control.Monad.Extra (mapMaybeM, unless)
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as M
import Data.Maybe (catMaybes, listToMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Vector qualified as V
import Data.Yaml as Y
import Swarm.Game.Entity hiding (empty)
import Swarm.Game.Land
import Swarm.Game.Scenario.RobotLookup
import Swarm.Game.Scenario.Topography.EntityFacade
import Swarm.Game.Scenario.Topography.ProtoCell hiding (name)
import Swarm.Game.Terrain
import Swarm.Util (quote, showT)
import Swarm.Util.Erasable (Erasable (..), erasableToMaybe)
import Swarm.Util.Yaml

------------------------------------------------------------
-- World cells
------------------------------------------------------------

-- | A single cell in a world map, which contains a terrain value,
--   and optionally an entity and robot.
--   It is parameterized on the 'Entity' type to facilitate less
--   stateful versions of the 'Entity' type in rendering scenario data.
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
(PCell e -> PCell e -> Bool)
-> (PCell e -> PCell e -> Bool) -> Eq (PCell e)
forall e. Eq e => PCell e -> PCell e -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$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
/= :: PCell e -> PCell e -> Bool
Eq, Int -> PCell e -> ShowS
[PCell e] -> ShowS
PCell e -> String
(Int -> PCell e -> ShowS)
-> (PCell e -> String) -> ([PCell e] -> ShowS) -> Show (PCell e)
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
$cshowsPrec :: forall e. Show e => Int -> PCell e -> ShowS
showsPrec :: Int -> PCell e -> ShowS
$cshow :: forall e. Show e => PCell e -> String
show :: PCell e -> String
$cshowList :: forall e. Show e => [PCell e] -> ShowS
showList :: [PCell e] -> ShowS
Show)

-- | A single cell in a world map, which contains a terrain value,
--   and optionally an entity and robot.
type Cell = PCell Entity

-- | Supplements a cell with waypoint information
type AugmentedCell e = SignpostableCell (PCell e)

-- | Re-usable serialization for variants of 'PCell'
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 =
  [Value] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$
    [Maybe Value] -> [Value]
forall a. [Maybe a] -> [a]
catMaybes
      [ Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value)
-> (TerrainType -> Value) -> TerrainType -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> (TerrainType -> Text) -> TerrainType -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TerrainType -> Text
getTerrainWord (TerrainType -> Maybe Value) -> TerrainType -> Maybe Value
forall a b. (a -> b) -> a -> b
$ PCell a -> TerrainType
forall e. PCell e -> TerrainType
cellTerrain PCell a
x
      , (b -> Value) -> Maybe b -> Maybe Value
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Value
forall a. ToJSON a => a -> Value
toJSON (Maybe b -> Maybe Value)
-> (Erasable a -> Maybe b) -> Erasable a -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Erasable a -> Maybe b
modifier (Erasable a -> Maybe Value) -> Erasable a -> Maybe Value
forall a b. (a -> b) -> a -> b
$ PCell a -> Erasable a
forall e. PCell e -> Erasable e
cellEntity PCell a
x
      , [Value] -> Maybe Value
forall a. [a] -> Maybe a
listToMaybe []
      ]

instance ToJSON Cell where
  toJSON :: Cell -> Value
toJSON = (Erasable Entity -> Maybe Text) -> Cell -> Value
forall b a. ToJSON b => (Erasable a -> Maybe b) -> PCell a -> Value
mkPCellJson ((Erasable Entity -> Maybe Text) -> Cell -> Value)
-> (Erasable Entity -> Maybe Text) -> Cell -> Value
forall a b. (a -> b) -> a -> b
$ \case
    Erasable Entity
EErase -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"erase"
    Erasable Entity
ENothing -> Maybe Text
forall a. Maybe a
Nothing
    EJust Entity
e -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Entity
e Entity -> Getting Text Entity Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Entity Text
Lens' Entity Text
entityName)

-- | Parse a tuple such as @[grass, rock, base]@ into a 'Cell'.  The
--   entity and robot, if present, are immediately looked up and
--   converted into 'Entity' and 'TRobot' values.  If they are not
--   found, a parse error results.
instance FromJSONE (TerrainEntityMaps, RobotMap) Cell where
  parseJSONE :: Value -> ParserE (TerrainEntityMaps, RobotMap) Cell
parseJSONE = String
-> (Array -> ParserE (TerrainEntityMaps, RobotMap) Cell)
-> Value
-> ParserE (TerrainEntityMaps, RobotMap) Cell
forall e a.
String -> (Array -> ParserE e a) -> Value -> ParserE e a
withArrayE String
"tuple" ((Array -> ParserE (TerrainEntityMaps, RobotMap) Cell)
 -> Value -> ParserE (TerrainEntityMaps, RobotMap) Cell)
-> (Array -> ParserE (TerrainEntityMaps, RobotMap) Cell)
-> Value
-> ParserE (TerrainEntityMaps, RobotMap) Cell
forall a b. (a -> b) -> a -> b
$ \Array
v -> do
    let tupRaw :: [Value]
tupRaw = Array -> [Value]
forall a. Vector a -> [a]
V.toList Array
v
    NonEmpty Value
tup <- case [Value] -> Maybe (NonEmpty Value)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Value]
tupRaw of
      Maybe (NonEmpty Value)
Nothing -> String
-> With (TerrainEntityMaps, RobotMap) Parser (NonEmpty Value)
forall a. String -> With (TerrainEntityMaps, RobotMap) Parser a
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 -> NonEmpty Value
-> With (TerrainEntityMaps, RobotMap) Parser (NonEmpty Value)
forall a. a -> With (TerrainEntityMaps, RobotMap) Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return NonEmpty Value
x

    (TerrainEntityMaps TerrainMap
tm EntityMap
_, RobotMap
_) <- With
  (TerrainEntityMaps, RobotMap) Parser (TerrainEntityMaps, RobotMap)
forall (f :: * -> *) e. Monad f => With e f e
getE
    TerrainType
terr <- Parser TerrainType
-> With (TerrainEntityMaps, RobotMap) Parser TerrainType
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Parser TerrainType
 -> With (TerrainEntityMaps, RobotMap) Parser TerrainType)
-> Parser TerrainType
-> With (TerrainEntityMaps, RobotMap) Parser TerrainType
forall a b. (a -> b) -> a -> b
$ Value -> Parser TerrainType
forall a. FromJSON a => Value -> Parser a
parseJSON (NonEmpty Value -> Value
forall a. NonEmpty a -> a
NE.head NonEmpty Value
tup)
    Bool
-> With (TerrainEntityMaps, RobotMap) Parser ()
-> With (TerrainEntityMaps, RobotMap) Parser ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (TerrainType -> Map TerrainType TerrainObj -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member TerrainType
terr (Map TerrainType TerrainObj -> Bool)
-> Map TerrainType TerrainObj -> Bool
forall a b. (a -> b) -> a -> b
$ TerrainMap -> Map TerrainType TerrainObj
terrainByName TerrainMap
tm)
      (With (TerrainEntityMaps, RobotMap) Parser ()
 -> With (TerrainEntityMaps, RobotMap) Parser ())
-> (Text -> With (TerrainEntityMaps, RobotMap) Parser ())
-> Text
-> With (TerrainEntityMaps, RobotMap) Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> With (TerrainEntityMaps, RobotMap) Parser ()
forall a. String -> With (TerrainEntityMaps, RobotMap) Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
      (String -> With (TerrainEntityMaps, RobotMap) Parser ())
-> (Text -> String)
-> Text
-> With (TerrainEntityMaps, RobotMap) Parser ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
      (Text -> With (TerrainEntityMaps, RobotMap) Parser ())
-> Text -> With (TerrainEntityMaps, RobotMap) Parser ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
        [ Text
"Unrecognized terrain type"
        , Text -> Text
quote (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ TerrainType -> Text
getTerrainWord TerrainType
terr
        , Text
"Avaliable:"
        , [TerrainType] -> Text
forall a. Show a => a -> Text
showT ([TerrainType] -> Text) -> [TerrainType] -> Text
forall a b. (a -> b) -> a -> b
$ Map TerrainType TerrainObj -> [TerrainType]
forall k a. Map k a -> [k]
M.keys (Map TerrainType TerrainObj -> [TerrainType])
-> Map TerrainType TerrainObj -> [TerrainType]
forall a b. (a -> b) -> a -> b
$ TerrainMap -> Map TerrainType TerrainObj
terrainByName TerrainMap
tm
        ]

    Erasable Entity
ent <- case NonEmpty Value
tup NonEmpty Value
-> Getting (First Value) (NonEmpty Value) Value -> Maybe Value
forall s a. s -> Getting (First a) s a -> Maybe a
^? Index (NonEmpty Value)
-> Traversal' (NonEmpty Value) (IxValue (NonEmpty Value))
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix Int
Index (NonEmpty Value)
1 of
      Maybe Value
Nothing -> Erasable Entity
-> With (TerrainEntityMaps, RobotMap) Parser (Erasable Entity)
forall a. a -> With (TerrainEntityMaps, RobotMap) Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Erasable Entity
forall e. Erasable e
ENothing
      Just Value
e -> do
        Maybe Text
meName <- Parser (Maybe Text)
-> With (TerrainEntityMaps, RobotMap) Parser (Maybe Text)
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Parser (Maybe Text)
 -> With (TerrainEntityMaps, RobotMap) Parser (Maybe Text))
-> Parser (Maybe Text)
-> With (TerrainEntityMaps, RobotMap) Parser (Maybe Text)
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 -> Erasable Entity
-> With (TerrainEntityMaps, RobotMap) Parser (Erasable Entity)
forall a. a -> With (TerrainEntityMaps, RobotMap) Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Erasable Entity
forall e. Erasable e
ENothing
          Just Text
"erase" -> Erasable Entity
-> With (TerrainEntityMaps, RobotMap) Parser (Erasable Entity)
forall a. a -> With (TerrainEntityMaps, RobotMap) Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Erasable Entity
forall e. Erasable e
EErase
          Just Text
name -> (Entity -> Erasable Entity)
-> With (TerrainEntityMaps, RobotMap) Parser Entity
-> With (TerrainEntityMaps, RobotMap) Parser (Erasable Entity)
forall a b.
(a -> b)
-> With (TerrainEntityMaps, RobotMap) Parser a
-> With (TerrainEntityMaps, RobotMap) Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Entity -> Erasable Entity
forall e. e -> Erasable e
EJust (With (TerrainEntityMaps, RobotMap) Parser Entity
 -> With (TerrainEntityMaps, RobotMap) Parser (Erasable Entity))
-> (ParserE EntityMap Entity
    -> With (TerrainEntityMaps, RobotMap) Parser Entity)
-> ParserE EntityMap Entity
-> With (TerrainEntityMaps, RobotMap) Parser (Erasable Entity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((TerrainEntityMaps, RobotMap) -> EntityMap)
-> ParserE EntityMap Entity
-> With (TerrainEntityMaps, RobotMap) Parser Entity
forall e' e (f :: * -> *) a. (e' -> e) -> With e f a -> With e' f a
localE (Getting EntityMap TerrainEntityMaps EntityMap
-> TerrainEntityMaps -> EntityMap
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting EntityMap TerrainEntityMaps EntityMap
Lens' TerrainEntityMaps EntityMap
entityMap (TerrainEntityMaps -> EntityMap)
-> ((TerrainEntityMaps, RobotMap) -> TerrainEntityMaps)
-> (TerrainEntityMaps, RobotMap)
-> EntityMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TerrainEntityMaps, RobotMap) -> TerrainEntityMaps
forall a b. (a, b) -> a
fst) (ParserE EntityMap Entity
 -> With (TerrainEntityMaps, RobotMap) Parser (Erasable Entity))
-> ParserE EntityMap Entity
-> With (TerrainEntityMaps, RobotMap) Parser (Erasable Entity)
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 <- Parser (Maybe RobotName)
-> With (a, RobotMap) Parser (Maybe RobotName)
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Parser (Maybe RobotName)
 -> With (a, RobotMap) Parser (Maybe RobotName))
-> Parser (Maybe RobotName)
-> With (a, RobotMap) Parser (Maybe RobotName)
forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => Value -> Parser a
parseJSON @(Maybe RobotName) Value
r
          (RobotName -> With (a, RobotMap) Parser IndexedTRobot)
-> Maybe RobotName
-> With (a, RobotMap) Parser (Maybe IndexedTRobot)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (((a, RobotMap) -> RobotMap)
-> With RobotMap Parser IndexedTRobot
-> With (a, RobotMap) Parser IndexedTRobot
forall e' e (f :: * -> *) a. (e' -> e) -> With e f a -> With e' f a
localE (a, RobotMap) -> RobotMap
forall a b. (a, b) -> b
snd (With RobotMap Parser IndexedTRobot
 -> With (a, RobotMap) Parser IndexedTRobot)
-> (RobotName -> With RobotMap Parser IndexedTRobot)
-> RobotName
-> With (a, RobotMap) Parser IndexedTRobot
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RobotName -> With RobotMap Parser IndexedTRobot
getRobot) Maybe RobotName
mrName

    [IndexedTRobot]
robs <- (Value
 -> With (TerrainEntityMaps, RobotMap) Parser (Maybe IndexedTRobot))
-> [Value]
-> With (TerrainEntityMaps, RobotMap) Parser [IndexedTRobot]
forall (m :: * -> *) a b.
Monad m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM Value
-> With (TerrainEntityMaps, RobotMap) Parser (Maybe IndexedTRobot)
forall {a}.
Value -> With (a, RobotMap) Parser (Maybe IndexedTRobot)
name2rob (Int -> [Value] -> [Value]
forall a. Int -> [a] -> [a]
drop Int
2 [Value]
tupRaw)

    Cell -> ParserE (TerrainEntityMaps, RobotMap) Cell
forall a. a -> With (TerrainEntityMaps, RobotMap) Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (Cell -> ParserE (TerrainEntityMaps, RobotMap) Cell)
-> Cell -> ParserE (TerrainEntityMaps, RobotMap) Cell
forall a b. (a -> b) -> a -> b
$ TerrainType -> Erasable Entity -> [IndexedTRobot] -> Cell
forall e. TerrainType -> Erasable e -> [IndexedTRobot] -> PCell e
Cell TerrainType
terr Erasable Entity
ent [IndexedTRobot]
robs

cellToEntity :: Maybe Cell -> Maybe Entity
cellToEntity :: Maybe Cell -> Maybe Entity
cellToEntity = ((Erasable Entity -> Maybe Entity
forall e. Erasable e -> Maybe e
erasableToMaybe (Erasable Entity -> Maybe Entity)
-> (Cell -> Erasable Entity) -> Cell -> Maybe Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cell -> Erasable Entity
forall e. PCell e -> Erasable e
cellEntity) (Cell -> Maybe Entity) -> Maybe Cell -> Maybe Entity
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<)

------------------------------------------------------------
-- World editor
------------------------------------------------------------

-- | Stateless cells used for the World Editor.
-- These cells contain the bare minimum display information
-- for rendering.
type CellPaintDisplay = PCell EntityFacade

-- Note: This instance is used only for the purpose of 'WorldPalette'
instance ToJSON CellPaintDisplay where
  toJSON :: CellPaintDisplay -> Value
toJSON = (Erasable EntityFacade -> Maybe EntityFacade)
-> CellPaintDisplay -> Value
forall b a. ToJSON b => (Erasable a -> Maybe b) -> PCell a -> Value
mkPCellJson ((Erasable EntityFacade -> Maybe EntityFacade)
 -> CellPaintDisplay -> Value)
-> (Erasable EntityFacade -> Maybe EntityFacade)
-> CellPaintDisplay
-> Value
forall a b. (a -> b) -> a -> b
$ \case
    Erasable EntityFacade
ENothing -> Maybe EntityFacade
forall a. Maybe a
Nothing
    Erasable EntityFacade
EErase -> EntityFacade -> Maybe EntityFacade
forall a. a -> Maybe a
Just (EntityFacade -> Maybe EntityFacade)
-> EntityFacade -> Maybe EntityFacade
forall a b. (a -> b) -> a -> b
$ Text -> Display -> EntityFacade
EntityFacade Text
"erase" Display
forall a. Monoid a => a
mempty
    EJust EntityFacade
e -> EntityFacade -> Maybe EntityFacade
forall a. a -> Maybe a
Just EntityFacade
e