Cell.hs

{-# 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
  { cellTerrain :: TerrainType
  , cellEntity :: Erasable e
  , cellRobots :: [IndexedTRobot]
  }
  deriving (Eq, 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 modifier x =
  toJSON $
    catMaybes
      [ Just . toJSON . getTerrainWord $ cellTerrain x
      , fmap toJSON . modifier $ cellEntity x
      , listToMaybe []
      ]

instance ToJSON Cell where
  toJSON = mkPCellJson $ \case
    EErase -> Just "erase"
    ENothing -> Nothing
    EJust e -> Just (e ^. 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 = withArrayE "tuple" $ \v -> do
    let tupRaw = V.toList v
    tup <- case NE.nonEmpty tupRaw of
      Nothing -> fail "palette entry must have nonzero length (terrain, optional entity and then robots if any)"
      Just x -> return x

    (TerrainEntityMaps tm _, _) <- getE
    terr <- liftE $ parseJSON (NE.head tup)
    unless (M.member terr $ terrainByName tm)
      . fail
      . T.unpack
      $ T.unwords
        [ "Unrecognized terrain type"
        , quote $ getTerrainWord terr
        , "Avaliable:"
        , showT $ M.keys $ terrainByName tm
        ]

    ent <- case tup ^? ix 1 of
      Nothing -> return ENothing
      Just e -> do
        meName <- liftE $ parseJSON @(Maybe Text) e
        case meName of
          Nothing -> return ENothing
          Just "erase" -> return EErase
          Just name -> fmap EJust . localE (view entityMap . fst) $ getEntity name

    let name2rob r = do
          mrName <- liftE $ parseJSON @(Maybe RobotName) r
          traverse (localE snd . getRobot) mrName

    robs <- mapMaybeM name2rob (drop 2 tupRaw)

    return $ Cell terr ent robs

cellToEntity :: Maybe Cell -> Maybe Entity
cellToEntity = ((erasableToMaybe . cellEntity) =<<)

------------------------------------------------------------
-- 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 = mkPCellJson $ \case
    ENothing -> Nothing
    EErase -> Just $ EntityFacade "erase" mempty
    EJust e -> Just e