-- |
-- SPDX-License-Identifier: BSD-3-Clause
-- Description: Render game world for web display
module Swarm.Web.Worldview where

import Control.Lens ((^.))
import Data.Aeson (ToJSON)
import Data.Colour.Palette.BrewerSet (Kolor)
import Data.Colour.SRGB (RGB (..), sRGB24, sRGB24show)
import Data.IntMap qualified as IM
import Data.Text qualified as T
import GHC.Generics (Generic)
import Servant.Docs qualified as SD
import Swarm.Game.Entity.Cosmetic (RGBColor, flattenBg)
import Swarm.Game.Scenario (Scenario, scenarioCosmetics, scenarioLandscape)
import Swarm.Game.Scenario.Style
import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..))
import Swarm.Game.Scenario.Topography.Grid (Grid)
import Swarm.Game.State (GameState, landscape, robotInfo)
import Swarm.Game.State.Robot (viewCenter)
import Swarm.Game.Universe (planar)
import Swarm.Game.World.Render
import Swarm.Util.Content (getTerrainEntityColor)
import Swarm.Util.OccurrenceEncoder

data GridResponse = GridResponse
  { GridResponse -> Bool
isPlaying :: Bool
  , GridResponse -> Maybe CellGrid
grid :: Maybe CellGrid
  }
  deriving ((forall x. GridResponse -> Rep GridResponse x)
-> (forall x. Rep GridResponse x -> GridResponse)
-> Generic GridResponse
forall x. Rep GridResponse x -> GridResponse
forall x. GridResponse -> Rep GridResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. GridResponse -> Rep GridResponse x
from :: forall x. GridResponse -> Rep GridResponse x
$cto :: forall x. Rep GridResponse x -> GridResponse
to :: forall x. Rep GridResponse x -> GridResponse
Generic, [GridResponse] -> Value
[GridResponse] -> Encoding
GridResponse -> Bool
GridResponse -> Value
GridResponse -> Encoding
(GridResponse -> Value)
-> (GridResponse -> Encoding)
-> ([GridResponse] -> Value)
-> ([GridResponse] -> Encoding)
-> (GridResponse -> Bool)
-> ToJSON GridResponse
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: GridResponse -> Value
toJSON :: GridResponse -> Value
$ctoEncoding :: GridResponse -> Encoding
toEncoding :: GridResponse -> Encoding
$ctoJSONList :: [GridResponse] -> Value
toJSONList :: [GridResponse] -> Value
$ctoEncodingList :: [GridResponse] -> Encoding
toEncodingList :: [GridResponse] -> Encoding
$comitField :: GridResponse -> Bool
omitField :: GridResponse -> Bool
ToJSON)

getCellGrid ::
  Scenario ->
  GameState ->
  AreaDimensions ->
  CellGrid
getCellGrid :: Scenario -> GameState -> AreaDimensions -> CellGrid
getCellGrid Scenario
myScenario GameState
gs AreaDimensions
requestedSize =
  Grid Key -> [HexColor] -> CellGrid
CellGrid Grid Key
indexGrid [HexColor]
encoding
 where
  vc :: Cosmic Location
vc = GameState
gs GameState
-> Getting (Cosmic Location) GameState (Cosmic Location)
-> Cosmic Location
forall s a. s -> Getting a s a -> a
^. (Robots -> Const (Cosmic Location) Robots)
-> GameState -> Const (Cosmic Location) GameState
Lens' GameState Robots
robotInfo ((Robots -> Const (Cosmic Location) Robots)
 -> GameState -> Const (Cosmic Location) GameState)
-> ((Cosmic Location -> Const (Cosmic Location) (Cosmic Location))
    -> Robots -> Const (Cosmic Location) Robots)
-> Getting (Cosmic Location) GameState (Cosmic Location)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Cosmic Location -> Const (Cosmic Location) (Cosmic Location))
-> Robots -> Const (Cosmic Location) Robots
Getter Robots (Cosmic Location)
viewCenter
  sLandscape :: ScenarioLandscape
sLandscape = Scenario
myScenario Scenario
-> Getting ScenarioLandscape Scenario ScenarioLandscape
-> ScenarioLandscape
forall s a. s -> Getting a s a -> a
^. Getting ScenarioLandscape Scenario ScenarioLandscape
Lens' Scenario ScenarioLandscape
scenarioLandscape
  dg :: Grid CellPaintDisplay
dg = Location
-> ScenarioLandscape
-> Landscape
-> Maybe AreaDimensions
-> Grid CellPaintDisplay
getDisplayGrid (Cosmic Location
vc Cosmic Location
-> Getting Location (Cosmic Location) Location -> Location
forall s a. s -> Getting a s a -> a
^. Getting Location (Cosmic Location) Location
forall a1 a2 (f :: * -> *).
Functor f =>
(a1 -> f a2) -> Cosmic a1 -> f (Cosmic a2)
planar) ScenarioLandscape
sLandscape (GameState
gs GameState -> Getting Landscape GameState Landscape -> Landscape
forall s a. s -> Getting a s a -> a
^. Getting Landscape GameState Landscape
Lens' GameState Landscape
landscape) (AreaDimensions -> Maybe AreaDimensions
forall a. a -> Maybe a
Just AreaDimensions
requestedSize)
  aMap :: Map WorldAttr PreservableColor
aMap = ScenarioLandscape
sLandscape ScenarioLandscape
-> Getting
     (Map WorldAttr PreservableColor)
     ScenarioLandscape
     (Map WorldAttr PreservableColor)
-> Map WorldAttr PreservableColor
forall s a. s -> Getting a s a -> a
^. Getting
  (Map WorldAttr PreservableColor)
  ScenarioLandscape
  (Map WorldAttr PreservableColor)
Lens' ScenarioLandscape (Map WorldAttr PreservableColor)
scenarioCosmetics

  asColour :: RGBColor -> Kolor
  asColour :: RGBColor -> Kolor
asColour (RGB Word8
r Word8
g Word8
b) = Word8 -> Word8 -> Word8 -> Kolor
forall b.
(Ord b, Floating b) =>
Word8 -> Word8 -> Word8 -> Colour b
sRGB24 Word8
r Word8
g Word8
b
  asHex :: RGBColor -> HexColor
asHex = Text -> HexColor
HexColor (Text -> HexColor) -> (RGBColor -> Text) -> RGBColor -> HexColor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (RGBColor -> String) -> RGBColor -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kolor -> String
forall b. (RealFrac b, Floating b) => Colour b -> String
sRGB24show (Kolor -> String) -> (RGBColor -> Kolor) -> RGBColor -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RGBColor -> Kolor
asColour

  f :: CellPaintDisplay -> HexColor
f = RGBColor -> HexColor
asHex (RGBColor -> HexColor)
-> (CellPaintDisplay -> RGBColor) -> CellPaintDisplay -> HexColor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RGBColor
-> (PreservableColor -> RGBColor)
-> Maybe PreservableColor
-> RGBColor
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Word8 -> Word8 -> Word8 -> RGBColor
forall a. a -> a -> a -> RGB a
RGB Word8
0 Word8
0 Word8
0) (ColorLayers RGBColor -> RGBColor
forall a. ColorLayers a -> a
flattenBg (ColorLayers RGBColor -> RGBColor)
-> (PreservableColor -> ColorLayers RGBColor)
-> PreservableColor
-> RGBColor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PreservableColor -> ColorLayers RGBColor
fromHiFi) (Maybe PreservableColor -> RGBColor)
-> (CellPaintDisplay -> Maybe PreservableColor)
-> CellPaintDisplay
-> RGBColor
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map WorldAttr PreservableColor
-> CellPaintDisplay -> Maybe PreservableColor
getTerrainEntityColor Map WorldAttr PreservableColor
aMap
  (Grid Key
indexGrid, [HexColor]
encoding) = Grid HexColor -> (Grid Key, [HexColor])
forall (t :: * -> *) b.
(Traversable t, Ord b) =>
t b -> (t Key, [b])
runEncoder (Grid HexColor -> (Grid Key, [HexColor]))
-> Grid HexColor -> (Grid Key, [HexColor])
forall a b. (a -> b) -> a -> b
$ CellPaintDisplay -> HexColor
f (CellPaintDisplay -> HexColor)
-> Grid CellPaintDisplay -> Grid HexColor
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Grid CellPaintDisplay
dg

data CellGrid = CellGrid
  { CellGrid -> Grid Key
coords :: Grid IM.Key
  , CellGrid -> [HexColor]
colors :: [HexColor]
  }
  deriving ((forall x. CellGrid -> Rep CellGrid x)
-> (forall x. Rep CellGrid x -> CellGrid) -> Generic CellGrid
forall x. Rep CellGrid x -> CellGrid
forall x. CellGrid -> Rep CellGrid x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CellGrid -> Rep CellGrid x
from :: forall x. CellGrid -> Rep CellGrid x
$cto :: forall x. Rep CellGrid x -> CellGrid
to :: forall x. Rep CellGrid x -> CellGrid
Generic, [CellGrid] -> Value
[CellGrid] -> Encoding
CellGrid -> Bool
CellGrid -> Value
CellGrid -> Encoding
(CellGrid -> Value)
-> (CellGrid -> Encoding)
-> ([CellGrid] -> Value)
-> ([CellGrid] -> Encoding)
-> (CellGrid -> Bool)
-> ToJSON CellGrid
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> (a -> Bool)
-> ToJSON a
$ctoJSON :: CellGrid -> Value
toJSON :: CellGrid -> Value
$ctoEncoding :: CellGrid -> Encoding
toEncoding :: CellGrid -> Encoding
$ctoJSONList :: [CellGrid] -> Value
toJSONList :: [CellGrid] -> Value
$ctoEncodingList :: [CellGrid] -> Encoding
toEncodingList :: [CellGrid] -> Encoding
$comitField :: CellGrid -> Bool
omitField :: CellGrid -> Bool
ToJSON)

instance SD.ToSample GridResponse where
  toSamples :: Proxy GridResponse -> [(Text, GridResponse)]
toSamples Proxy GridResponse
_ = [(Text, GridResponse)]
forall a. [(Text, a)]
SD.noSamples