-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Utilities for accessing content of the world,
-- by single cells or in bulk for rendering.
module Swarm.Util.Content where

import Control.Applicative ((<|>))
import Control.Lens ((^.))
import Data.Map qualified as M
import Data.Text qualified as T
import Swarm.Game.Display
import Swarm.Game.Entity.Cosmetic
import Swarm.Game.Scenario.Topography.Cell (PCell (..))
import Swarm.Game.Scenario.Topography.EntityFacade
import Swarm.Game.Scenario.Topography.Grid
import Swarm.Game.Terrain (TerrainMap, TerrainType, getTerrainWord)
import Swarm.Game.Universe
import Swarm.Game.World
import Swarm.Game.World.Coords
import Swarm.Util.Erasable (erasableToMaybe, maybeToErasable)

-- | Get the terrain and entity at a single cell
getContentAt :: TerrainMap -> MultiWorld Int e -> Cosmic Coords -> (TerrainType, Maybe e)
getContentAt :: forall e.
TerrainMap
-> MultiWorld Int e -> Cosmic Coords -> (TerrainType, Maybe e)
getContentAt TerrainMap
tm MultiWorld Int e
w Cosmic Coords
coords = (TerrainType
underlyingCellTerrain, Maybe e
underlyingCellEntity)
 where
  underlyingCellEntity :: Maybe e
underlyingCellEntity = Cosmic Coords -> MultiWorld Int e -> Maybe e
forall t e. Cosmic Coords -> MultiWorld t e -> Maybe e
lookupCosmicEntity Cosmic Coords
coords MultiWorld Int e
w
  underlyingCellTerrain :: TerrainType
underlyingCellTerrain = TerrainMap -> Cosmic Coords -> MultiWorld Int e -> TerrainType
forall e.
TerrainMap -> Cosmic Coords -> MultiWorld Int e -> TerrainType
lookupCosmicTerrain TerrainMap
tm Cosmic Coords
coords MultiWorld Int e
w

-- * Rendering

-- | Get a rectangle of cells for rendering.
--
-- Compare to: 'Swarm.TUI.View.worldWidget'
getMapRectangle ::
  (d -> e) ->
  (Coords -> (TerrainType, Maybe d)) ->
  BoundsRectangle ->
  Grid (PCell e)
getMapRectangle :: forall d e.
(d -> e)
-> (Coords -> (TerrainType, Maybe d))
-> BoundsRectangle
-> Grid (PCell e)
getMapRectangle d -> e
paintTransform Coords -> (TerrainType, Maybe d)
contentFunc BoundsRectangle
coords =
  [[PCell e]] -> Grid (PCell e)
forall a. [[a]] -> Grid a
mkGrid ([[PCell e]] -> Grid (PCell e)) -> [[PCell e]] -> Grid (PCell e)
forall a b. (a -> b) -> a -> b
$ (Int32 -> [PCell e]) -> [Int32] -> [[PCell e]]
forall a b. (a -> b) -> [a] -> [b]
map Int32 -> [PCell e]
renderRow [Int32
yTop .. Int32
yBottom]
 where
  (Coords (Int32
yTop, Int32
xLeft), Coords (Int32
yBottom, Int32
xRight)) = BoundsRectangle
coords

  drawCell :: (d -> e) -> Int32 -> Int32 -> PCell e
drawCell d -> e
f Int32
rowIndex Int32
colIndex =
    TerrainType -> Erasable e -> [IndexedTRobot] -> PCell e
forall e. TerrainType -> Erasable e -> [IndexedTRobot] -> PCell e
Cell
      TerrainType
terrain
      (d -> e
f (d -> e) -> Erasable d -> Erasable e
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe d -> Erasable d
forall e. Maybe e -> Erasable e
maybeToErasable Maybe d
erasableEntity)
      []
   where
    (TerrainType
terrain, Maybe d
erasableEntity) = Coords -> (TerrainType, Maybe d)
contentFunc (Coords -> (TerrainType, Maybe d))
-> Coords -> (TerrainType, Maybe d)
forall a b. (a -> b) -> a -> b
$ (Int32, Int32) -> Coords
Coords (Int32
rowIndex, Int32
colIndex)

  renderRow :: Int32 -> [PCell e]
renderRow Int32
rowIndex = (Int32 -> PCell e) -> [Int32] -> [PCell e]
forall a b. (a -> b) -> [a] -> [b]
map ((d -> e) -> Int32 -> Int32 -> PCell e
forall {e}. (d -> e) -> Int32 -> Int32 -> PCell e
drawCell d -> e
paintTransform Int32
rowIndex) [Int32
xLeft .. Int32
xRight]

-- | Get the color used to render a single cell
getTerrainEntityColor ::
  M.Map WorldAttr PreservableColor ->
  PCell EntityFacade ->
  Maybe PreservableColor
getTerrainEntityColor :: Map WorldAttr PreservableColor
-> PCell EntityFacade -> Maybe PreservableColor
getTerrainEntityColor Map WorldAttr PreservableColor
aMap (Cell TerrainType
terr Erasable EntityFacade
cellEnt [IndexedTRobot]
_) =
  (EntityFacade -> Maybe PreservableColor
entityColor (EntityFacade -> Maybe PreservableColor)
-> Maybe EntityFacade -> Maybe PreservableColor
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Erasable EntityFacade -> Maybe EntityFacade
forall e. Erasable e -> Maybe e
erasableToMaybe Erasable EntityFacade
cellEnt) Maybe PreservableColor
-> Maybe PreservableColor -> Maybe PreservableColor
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe PreservableColor
terrainFallback
 where
  terrainFallback :: Maybe PreservableColor
terrainFallback = WorldAttr
-> Map WorldAttr PreservableColor -> Maybe PreservableColor
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (String -> WorldAttr
WorldAttr (String -> WorldAttr) -> String -> WorldAttr
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ TerrainType -> Text
getTerrainWord TerrainType
terr) Map WorldAttr PreservableColor
aMap
  entityColor :: EntityFacade -> Maybe PreservableColor
entityColor (EntityFacade Text
_ Display
d) = case Display
d Display -> Getting Attribute Display Attribute -> Attribute
forall s a. s -> Getting a s a -> a
^. Getting Attribute Display Attribute
Lens' Display Attribute
displayAttr of
    AWorld Text
n -> WorldAttr
-> Map WorldAttr PreservableColor -> Maybe PreservableColor
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (String -> WorldAttr
WorldAttr (String -> WorldAttr) -> String -> WorldAttr
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
n) Map WorldAttr PreservableColor
aMap
    Attribute
_ -> Maybe PreservableColor
forall a. Maybe a
Nothing