-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- GameState- and TUI-independent world rendering.
module Swarm.Game.World.Render where

import Codec.Picture
import Control.Applicative ((<|>))
import Control.Carrier.Throw.Either (runThrow)
import Control.Effect.Lift (Lift, sendIO)
import Control.Effect.Throw
import Control.Lens (view, (^.))
import Data.Colour.SRGB (RGB (..))
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Maybe (fromMaybe)
import Data.Tuple.Extra (both)
import Linear (V2 (..))
import Swarm.Game.Display (defaultChar)
import Swarm.Game.Entity.Cosmetic
import Swarm.Game.Failure (SystemFailure, simpleErrorHandle)
import Swarm.Game.Land
import Swarm.Game.Location
import Swarm.Game.Scenario
import Swarm.Game.Scenario.Topography.Area
import Swarm.Game.Scenario.Topography.Cell
import Swarm.Game.Scenario.Topography.Center
import Swarm.Game.Scenario.Topography.EntityFacade (EntityFacade (..), mkFacade)
import Swarm.Game.Scenario.Topography.Grid
import Swarm.Game.Scenario.Topography.Rasterize
import Swarm.Game.Scenario.Topography.Structure.Overlay
import Swarm.Game.State.Landscape
import Swarm.Game.Universe
import Swarm.Game.World.Coords
import Swarm.Game.World.Gen (Seed)
import Swarm.Language.Pretty (prettyString)
import Swarm.Util (surfaceEmpty)
import Swarm.Util.Content
import Swarm.Util.Erasable (erasableToMaybe)
import System.IO (hPutStrLn, stderr)

data OuputFormat
  = ConsoleText
  | PngImage

data FailureMode
  = Terminate
  | RenderBlankImage

-- | Command-line options for configuring the app.
data RenderOpts = RenderOpts
  { RenderOpts -> Maybe Seed
renderSeed :: Maybe Seed
  -- ^ Explicit seed chosen by the user.
  , RenderOpts -> OuputFormat
outputFormat :: OuputFormat
  , RenderOpts -> FilePath
outputFilepath :: FilePath
  , RenderOpts -> Maybe AreaDimensions
gridSize :: Maybe AreaDimensions
  , RenderOpts -> FailureMode
failureMode :: FailureMode
  }

getDisplayChar :: PCell EntityFacade -> Char
getDisplayChar :: PCell EntityFacade -> Char
getDisplayChar = Char -> (EntityFacade -> Char) -> Maybe EntityFacade -> Char
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Char
' ' EntityFacade -> Char
facadeChar (Maybe EntityFacade -> Char)
-> (PCell EntityFacade -> Maybe EntityFacade)
-> PCell EntityFacade
-> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Erasable EntityFacade -> Maybe EntityFacade
forall e. Erasable e -> Maybe e
erasableToMaybe (Erasable EntityFacade -> Maybe EntityFacade)
-> (PCell EntityFacade -> Erasable EntityFacade)
-> PCell EntityFacade
-> Maybe EntityFacade
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PCell EntityFacade -> Erasable EntityFacade
forall e. PCell e -> Erasable e
cellEntity
 where
  facadeChar :: EntityFacade -> Char
facadeChar (EntityFacade EntityName
_ Display
d) = Getting Char Display Char -> Display -> Char
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Char Display Char
Lens' Display Char
defaultChar Display
d

getDisplayColor :: M.Map WorldAttr PreservableColor -> PCell EntityFacade -> PixelRGBA8
getDisplayColor :: Map WorldAttr PreservableColor -> PCell EntityFacade -> PixelRGBA8
getDisplayColor Map WorldAttr PreservableColor
aMap PCell EntityFacade
c =
  PixelRGBA8
-> (PreservableColor -> PixelRGBA8)
-> Maybe PreservableColor
-> PixelRGBA8
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PixelRGBA8
transparent PreservableColor -> PixelRGBA8
mkPixelColor (Maybe PreservableColor -> PixelRGBA8)
-> Maybe PreservableColor -> PixelRGBA8
forall a b. (a -> b) -> a -> b
$ Map WorldAttr PreservableColor
-> PCell EntityFacade -> Maybe PreservableColor
getTerrainEntityColor Map WorldAttr PreservableColor
aMap PCell EntityFacade
c
 where
  transparent :: PixelRGBA8
transparent = Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
0 Word8
0 Word8
0 Word8
0

mkPixelColor :: PreservableColor -> PixelRGBA8
mkPixelColor :: PreservableColor -> PixelRGBA8
mkPixelColor PreservableColor
h = Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
r Word8
g Word8
b Word8
255
 where
  RGB Word8
r Word8
g Word8
b = ColorLayers (RGB Word8) -> RGB Word8
forall a. ColorLayers a -> a
flattenBg (ColorLayers (RGB Word8) -> RGB Word8)
-> ColorLayers (RGB Word8) -> RGB Word8
forall a b. (a -> b) -> a -> b
$ PreservableColor -> ColorLayers (RGB Word8)
fromHiFi PreservableColor
h

-- | Since terminals can customize these named
-- colors using themes or explicit user overrides,
-- these color assignments are somewhat arbitrary.
namedToTriple :: NamedColor -> RGBColor
namedToTriple :: NamedColor -> RGB Word8
namedToTriple = \case
  NamedColor
White -> Word8 -> Word8 -> Word8 -> RGB Word8
forall a. a -> a -> a -> RGB a
RGB Word8
208 Word8
207 Word8
204
  NamedColor
BrightRed -> Word8 -> Word8 -> Word8 -> RGB Word8
forall a. a -> a -> a -> RGB a
RGB Word8
246 Word8
97 Word8
81
  NamedColor
Red -> Word8 -> Word8 -> Word8 -> RGB Word8
forall a. a -> a -> a -> RGB a
RGB Word8
192 Word8
28 Word8
40
  NamedColor
Green -> Word8 -> Word8 -> Word8 -> RGB Word8
forall a. a -> a -> a -> RGB a
RGB Word8
38 Word8
162 Word8
105
  NamedColor
Blue -> Word8 -> Word8 -> Word8 -> RGB Word8
forall a. a -> a -> a -> RGB a
RGB Word8
18 Word8
72 Word8
139
  NamedColor
BrightYellow -> Word8 -> Word8 -> Word8 -> RGB Word8
forall a. a -> a -> a -> RGB a
RGB Word8
233 Word8
173 Word8
12
  NamedColor
Yellow -> Word8 -> Word8 -> Word8 -> RGB Word8
forall a. a -> a -> a -> RGB a
RGB Word8
162 Word8
115 Word8
76

fromHiFi :: PreservableColor -> ColorLayers RGBColor
fromHiFi :: PreservableColor -> ColorLayers (RGB Word8)
fromHiFi = (TrueColor -> RGB Word8)
-> PreservableColor -> ColorLayers (RGB Word8)
forall a b. (a -> b) -> ColorLayers a -> ColorLayers b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TrueColor -> RGB Word8)
 -> PreservableColor -> ColorLayers (RGB Word8))
-> (TrueColor -> RGB Word8)
-> PreservableColor
-> ColorLayers (RGB Word8)
forall a b. (a -> b) -> a -> b
$ \case
  Triple RGB Word8
x -> RGB Word8
x
  -- The triples we've manually assigned for named
  -- ANSI colors do not need to be round-tripped, since
  -- those triples are not inputs to the VTY attribute creation.
  AnsiColor NamedColor
x -> NamedColor -> RGB Word8
namedToTriple NamedColor
x

-- | When output size is not explicitly provided,
-- uses natural map bounds (if a map exists).
getBoundingBox ::
  Location ->
  PWorldDescription e ->
  Maybe AreaDimensions ->
  BoundsRectangle
getBoundingBox :: forall e.
Location
-> PWorldDescription e -> Maybe AreaDimensions -> BoundsRectangle
getBoundingBox Location
vc PWorldDescription e
scenarioWorld Maybe AreaDimensions
maybeSize =
  AreaDimensions -> Location -> BoundsRectangle
mkBoundingBox AreaDimensions
areaDims Location
upperLeftLocation
 where
  upperLeftLocation :: Location
upperLeftLocation =
    if Maybe AreaDimensions -> Bool
forall a. Maybe a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Maybe AreaDimensions
maybeSize Bool -> Bool -> Bool
&& Bool -> Bool
not (AreaDimensions -> Bool
isEmpty AreaDimensions
mapAreaDims)
      then PWorldDescription e -> Location
forall e. PWorldDescription e -> Location
ul PWorldDescription e
scenarioWorld
      else Location
vc Location -> Diff (Point V2) Int32 -> Location
forall a. Num a => Point V2 a -> Diff (Point V2) a -> Point V2 a
forall (p :: * -> *) a. (Affine p, Num a) => p a -> Diff p a -> p a
.+^ ((Int32 -> Int32 -> Int32
forall a. Integral a => a -> a -> a
`div` Int32
2) (Int32 -> Int32) -> V2 Int32 -> V2 Int32
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int32 -> Int32 -> V2 Int32
forall a. a -> a -> V2 a
V2 (Int32 -> Int32
forall a. Num a => a -> a
negate Int32
w) Int32
h)

  mkBoundingBox :: AreaDimensions -> Location -> BoundsRectangle
mkBoundingBox AreaDimensions
areaDimens Location
upperLeftLoc =
    (Location -> Coords) -> (Location, Location) -> BoundsRectangle
forall a b. (a -> b) -> (a, a) -> (b, b)
both Location -> Coords
locToCoords (Location, Location)
locationBounds
   where
    lowerRightLocation :: Location
lowerRightLocation = AreaDimensions -> Location -> Location
computeBottomRightFromUpperLeft AreaDimensions
areaDimens Location
upperLeftLoc
    locationBounds :: (Location, Location)
locationBounds = (Location
upperLeftLoc, Location
lowerRightLocation)

  worldArea :: Grid (Maybe (PCell e))
worldArea = PositionedGrid (Maybe (PCell e)) -> Grid (Maybe (PCell e))
forall a. PositionedGrid a -> Grid a
gridContent (PositionedGrid (Maybe (PCell e)) -> Grid (Maybe (PCell e)))
-> PositionedGrid (Maybe (PCell e)) -> Grid (Maybe (PCell e))
forall a b. (a -> b) -> a -> b
$ PWorldDescription e -> PositionedGrid (Maybe (PCell e))
forall e. PWorldDescription e -> PositionedGrid (Maybe (PCell e))
area PWorldDescription e
scenarioWorld
  mapAreaDims :: AreaDimensions
mapAreaDims = Grid (Maybe (PCell e)) -> AreaDimensions
forall a. Grid a -> AreaDimensions
getGridDimensions Grid (Maybe (PCell e))
worldArea
  areaDims :: AreaDimensions
areaDims@(AreaDimensions Int32
w Int32
h) =
    AreaDimensions -> Maybe AreaDimensions -> AreaDimensions
forall a. a -> Maybe a -> a
fromMaybe (Int32 -> Int32 -> AreaDimensions
AreaDimensions Int32
20 Int32
10) (Maybe AreaDimensions -> AreaDimensions)
-> Maybe AreaDimensions -> AreaDimensions
forall a b. (a -> b) -> a -> b
$
      Maybe AreaDimensions
maybeSize Maybe AreaDimensions
-> Maybe AreaDimensions -> Maybe AreaDimensions
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (AreaDimensions -> Bool) -> AreaDimensions -> Maybe AreaDimensions
forall (f :: * -> *) a. Alternative f => (a -> Bool) -> a -> f a
surfaceEmpty AreaDimensions -> Bool
isEmpty AreaDimensions
mapAreaDims

getDisplayGrid ::
  Location ->
  ScenarioLandscape ->
  Landscape ->
  Maybe AreaDimensions ->
  Grid CellPaintDisplay
getDisplayGrid :: Location
-> ScenarioLandscape
-> Landscape
-> Maybe AreaDimensions
-> Grid (PCell EntityFacade)
getDisplayGrid Location
vc ScenarioLandscape
sLandscape Landscape
ls Maybe AreaDimensions
maybeSize =
  (Entity -> EntityFacade)
-> (Coords -> (TerrainType, Maybe Entity))
-> BoundsRectangle
-> Grid (PCell EntityFacade)
forall d e.
(d -> e)
-> (Coords -> (TerrainType, Maybe d))
-> BoundsRectangle
-> Grid (PCell e)
getMapRectangle
    Entity -> EntityFacade
mkFacade
    (TerrainMap
-> MultiWorld Seed Entity
-> Cosmic Coords
-> (TerrainType, Maybe Entity)
forall e.
TerrainMap
-> MultiWorld Seed e -> Cosmic Coords -> (TerrainType, Maybe e)
getContentAt (ScenarioLandscape
sLandscape ScenarioLandscape
-> Getting TerrainMap ScenarioLandscape TerrainMap -> TerrainMap
forall s a. s -> Getting a s a -> a
^. (TerrainEntityMaps -> Const TerrainMap TerrainEntityMaps)
-> ScenarioLandscape -> Const TerrainMap ScenarioLandscape
Lens' ScenarioLandscape TerrainEntityMaps
scenarioTerrainAndEntities ((TerrainEntityMaps -> Const TerrainMap TerrainEntityMaps)
 -> ScenarioLandscape -> Const TerrainMap ScenarioLandscape)
-> ((TerrainMap -> Const TerrainMap TerrainMap)
    -> TerrainEntityMaps -> Const TerrainMap TerrainEntityMaps)
-> Getting TerrainMap ScenarioLandscape TerrainMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TerrainMap -> Const TerrainMap TerrainMap)
-> TerrainEntityMaps -> Const TerrainMap TerrainEntityMaps
Lens' TerrainEntityMaps TerrainMap
terrainMap) MultiWorld Seed Entity
worlds (Cosmic Coords -> (TerrainType, Maybe Entity))
-> (Coords -> Cosmic Coords)
-> Coords
-> (TerrainType, Maybe Entity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coords -> Cosmic Coords
forall {a}. a -> Cosmic a
mkCosmic)
    (Location
-> PWorldDescription Entity
-> Maybe AreaDimensions
-> BoundsRectangle
forall e.
Location
-> PWorldDescription e -> Maybe AreaDimensions -> BoundsRectangle
getBoundingBox Location
vc PWorldDescription Entity
firstScenarioWorld Maybe AreaDimensions
maybeSize)
 where
  mkCosmic :: a -> Cosmic a
mkCosmic = SubworldName -> a -> Cosmic a
forall a. SubworldName -> a -> Cosmic a
Cosmic (SubworldName -> a -> Cosmic a) -> SubworldName -> a -> Cosmic a
forall a b. (a -> b) -> a -> b
$ PWorldDescription Entity -> SubworldName
forall e. PWorldDescription e -> SubworldName
worldName PWorldDescription Entity
firstScenarioWorld
  worlds :: MultiWorld Seed Entity
worlds = Getting (MultiWorld Seed Entity) Landscape (MultiWorld Seed Entity)
-> Landscape -> MultiWorld Seed Entity
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (MultiWorld Seed Entity) Landscape (MultiWorld Seed Entity)
Lens' Landscape (MultiWorld Seed Entity)
multiWorld Landscape
ls

  firstScenarioWorld :: PWorldDescription Entity
firstScenarioWorld = NonEmpty (PWorldDescription Entity) -> PWorldDescription Entity
forall a. NonEmpty a -> a
NE.head (NonEmpty (PWorldDescription Entity) -> PWorldDescription Entity)
-> NonEmpty (PWorldDescription Entity) -> PWorldDescription Entity
forall a b. (a -> b) -> a -> b
$ Getting
  (NonEmpty (PWorldDescription Entity))
  ScenarioLandscape
  (NonEmpty (PWorldDescription Entity))
-> ScenarioLandscape -> NonEmpty (PWorldDescription Entity)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (NonEmpty (PWorldDescription Entity))
  ScenarioLandscape
  (NonEmpty (PWorldDescription Entity))
Lens' ScenarioLandscape (NonEmpty (PWorldDescription Entity))
scenarioWorlds ScenarioLandscape
sLandscape

getRenderableGrid ::
  (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
  RenderOpts ->
  FilePath ->
  m (Grid (PCell EntityFacade), M.Map WorldAttr PreservableColor)
getRenderableGrid :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
RenderOpts
-> FilePath
-> m (Grid (PCell EntityFacade), Map WorldAttr PreservableColor)
getRenderableGrid (RenderOpts Maybe Seed
maybeSeed OuputFormat
_ FilePath
_ Maybe AreaDimensions
maybeSize FailureMode
_) FilePath
fp = do
  (Scenario
myScenario, GameStateInputs
_gsi) <- FilePath -> m (Scenario, GameStateInputs)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
FilePath -> m (Scenario, GameStateInputs)
loadStandaloneScenario FilePath
fp
  let 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
  Seed
theSeed <- IO Seed -> m Seed
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO (IO Seed -> m Seed) -> IO Seed -> m Seed
forall a b. (a -> b) -> a -> b
$ Maybe Seed -> ScenarioLandscape -> IO Seed
arbitrateSeed Maybe Seed
maybeSeed ScenarioLandscape
sLandscape

  let worldTuples :: NonEmpty SubworldDescription
worldTuples = ScenarioLandscape -> NonEmpty SubworldDescription
buildWorldTuples ScenarioLandscape
sLandscape
      myLandscape :: Landscape
myLandscape = ScenarioLandscape
-> NonEmpty SubworldDescription -> Seed -> Landscape
mkLandscape ScenarioLandscape
sLandscape NonEmpty SubworldDescription
worldTuples Seed
theSeed

      vc :: Location
vc =
        Getting Location (Cosmic Location) Location
-> Cosmic Location -> Location
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Location (Cosmic Location) Location
forall a1 a2 (f :: * -> *).
Functor f =>
(a1 -> f a2) -> Cosmic a1 -> f (Cosmic a2)
planar (Cosmic Location -> Location) -> Cosmic Location -> Location
forall a b. (a -> b) -> a -> b
$
          ScenarioLandscape
-> NonEmpty SubworldDescription -> Cosmic Location
determineStaticViewCenter ScenarioLandscape
sLandscape NonEmpty SubworldDescription
worldTuples

  (Grid (PCell EntityFacade), Map WorldAttr PreservableColor)
-> m (Grid (PCell EntityFacade), Map WorldAttr PreservableColor)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Location
-> ScenarioLandscape
-> Landscape
-> Maybe AreaDimensions
-> Grid (PCell EntityFacade)
getDisplayGrid Location
vc ScenarioLandscape
sLandscape Landscape
myLandscape Maybe AreaDimensions
maybeSize, 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)

doRenderCmd :: RenderOpts -> FilePath -> IO ()
doRenderCmd :: RenderOpts -> FilePath -> IO ()
doRenderCmd opts :: RenderOpts
opts@(RenderOpts Maybe Seed
_ OuputFormat
asPng FilePath
_ Maybe AreaDimensions
_ FailureMode
_) FilePath
mapPath =
  case OuputFormat
asPng of
    OuputFormat
ConsoleText -> [FilePath] -> IO ()
printScenarioMap ([FilePath] -> IO ()) -> IO [FilePath] -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RenderOpts -> FilePath -> IO [FilePath]
renderScenarioMap RenderOpts
opts FilePath
mapPath
    OuputFormat
PngImage -> RenderOpts -> FilePath -> IO ()
renderScenarioPng RenderOpts
opts FilePath
mapPath

renderScenarioMap :: RenderOpts -> FilePath -> IO [String]
renderScenarioMap :: RenderOpts -> FilePath -> IO [FilePath]
renderScenarioMap RenderOpts
opts FilePath
fp = ThrowC SystemFailure IO [FilePath] -> IO [FilePath]
forall a. ThrowC SystemFailure IO a -> IO a
simpleErrorHandle (ThrowC SystemFailure IO [FilePath] -> IO [FilePath])
-> ThrowC SystemFailure IO [FilePath] -> IO [FilePath]
forall a b. (a -> b) -> a -> b
$ do
  (Grid (PCell EntityFacade)
grid, Map WorldAttr PreservableColor
_) <- RenderOpts
-> FilePath
-> ThrowC
     SystemFailure
     IO
     (Grid (PCell EntityFacade), Map WorldAttr PreservableColor)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
RenderOpts
-> FilePath
-> m (Grid (PCell EntityFacade), Map WorldAttr PreservableColor)
getRenderableGrid RenderOpts
opts FilePath
fp
  [FilePath] -> ThrowC SystemFailure IO [FilePath]
forall a. a -> ThrowC SystemFailure IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([FilePath] -> ThrowC SystemFailure IO [FilePath])
-> [FilePath] -> ThrowC SystemFailure IO [FilePath]
forall a b. (a -> b) -> a -> b
$ Grid Char -> [FilePath]
forall a. Grid a -> [[a]]
getRows (Grid Char -> [FilePath]) -> Grid Char -> [FilePath]
forall a b. (a -> b) -> a -> b
$ PCell EntityFacade -> Char
getDisplayChar (PCell EntityFacade -> Char)
-> Grid (PCell EntityFacade) -> Grid Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Grid (PCell EntityFacade)
grid

renderScenarioPng :: RenderOpts -> FilePath -> IO ()
renderScenarioPng :: RenderOpts -> FilePath -> IO ()
renderScenarioPng RenderOpts
opts FilePath
fp = do
  Either
  SystemFailure
  (Grid (PCell EntityFacade), Map WorldAttr PreservableColor)
result <- ThrowC
  SystemFailure
  IO
  (Grid (PCell EntityFacade), Map WorldAttr PreservableColor)
-> IO
     (Either
        SystemFailure
        (Grid (PCell EntityFacade), Map WorldAttr PreservableColor))
forall e (m :: * -> *) a. ThrowC e m a -> m (Either e a)
runThrow (ThrowC
   SystemFailure
   IO
   (Grid (PCell EntityFacade), Map WorldAttr PreservableColor)
 -> IO
      (Either
         SystemFailure
         (Grid (PCell EntityFacade), Map WorldAttr PreservableColor)))
-> ThrowC
     SystemFailure
     IO
     (Grid (PCell EntityFacade), Map WorldAttr PreservableColor)
-> IO
     (Either
        SystemFailure
        (Grid (PCell EntityFacade), Map WorldAttr PreservableColor))
forall a b. (a -> b) -> a -> b
$ RenderOpts
-> FilePath
-> ThrowC
     SystemFailure
     IO
     (Grid (PCell EntityFacade), Map WorldAttr PreservableColor)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
RenderOpts
-> FilePath
-> m (Grid (PCell EntityFacade), Map WorldAttr PreservableColor)
getRenderableGrid RenderOpts
opts FilePath
fp
  Image PixelRGBA8
img <- case Either
  SystemFailure
  (Grid (PCell EntityFacade), Map WorldAttr PreservableColor)
result of
    Left (SystemFailure
err :: SystemFailure) -> case RenderOpts -> FailureMode
failureMode RenderOpts
opts of
      FailureMode
Terminate -> FilePath -> IO (Image PixelRGBA8)
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
errorMsg
      FailureMode
RenderBlankImage -> do
        Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr FilePath
errorMsg
        let s :: (Seed, Seed)
s = (Seed, Seed)
-> (AreaDimensions -> (Seed, Seed))
-> Maybe AreaDimensions
-> (Seed, Seed)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Seed
1, Seed
1) ((Int32 -> Seed) -> (Int32, Int32) -> (Seed, Seed)
forall a b. (a -> b) -> (a, a) -> (b, b)
both Int32 -> Seed
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Int32, Int32) -> (Seed, Seed))
-> (AreaDimensions -> (Int32, Int32))
-> AreaDimensions
-> (Seed, Seed)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AreaDimensions -> (Int32, Int32)
asTuple) (Maybe AreaDimensions -> (Seed, Seed))
-> Maybe AreaDimensions -> (Seed, Seed)
forall a b. (a -> b) -> a -> b
$ RenderOpts -> Maybe AreaDimensions
gridSize RenderOpts
opts
        Image PixelRGBA8 -> IO (Image PixelRGBA8)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Image PixelRGBA8 -> IO (Image PixelRGBA8))
-> Image PixelRGBA8 -> IO (Image PixelRGBA8)
forall a b. (a -> b) -> a -> b
$ (Seed -> Seed -> Image PixelRGBA8)
-> (Seed, Seed) -> Image PixelRGBA8
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ((Seed -> Seed -> PixelRGBA8) -> Seed -> Seed -> Image PixelRGBA8
forall px.
Pixel px =>
(Seed -> Seed -> px) -> Seed -> Seed -> Image px
generateImage ((Seed -> Seed -> PixelRGBA8) -> Seed -> Seed -> Image PixelRGBA8)
-> (Seed -> Seed -> PixelRGBA8) -> Seed -> Seed -> Image PixelRGBA8
forall a b. (a -> b) -> a -> b
$ \Seed
_x Seed
_y -> Word8 -> Word8 -> Word8 -> Word8 -> PixelRGBA8
PixelRGBA8 Word8
0 Word8
0 Word8
0 Word8
255) (Seed, Seed)
s
     where
      errorMsg :: String
      errorMsg :: FilePath
errorMsg = SystemFailure -> FilePath
forall a. PrettyPrec a => a -> FilePath
prettyString SystemFailure
err
    Right (Grid (PCell EntityFacade)
grid, Map WorldAttr PreservableColor
aMap) -> Image PixelRGBA8 -> IO (Image PixelRGBA8)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Image PixelRGBA8 -> IO (Image PixelRGBA8))
-> Image PixelRGBA8 -> IO (Image PixelRGBA8)
forall a b. (a -> b) -> a -> b
$ ((PCell EntityFacade -> PixelRGBA8)
-> Grid (PCell EntityFacade) -> Image PixelRGBA8
forall px a. Pixel px => (a -> px) -> Grid a -> Image px
makeImage ((PCell EntityFacade -> PixelRGBA8)
 -> Grid (PCell EntityFacade) -> Image PixelRGBA8)
-> (Map WorldAttr PreservableColor
    -> PCell EntityFacade -> PixelRGBA8)
-> Map WorldAttr PreservableColor
-> Grid (PCell EntityFacade)
-> Image PixelRGBA8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map WorldAttr PreservableColor -> PCell EntityFacade -> PixelRGBA8
getDisplayColor) Map WorldAttr PreservableColor
aMap Grid (PCell EntityFacade)
grid
  FilePath -> Image PixelRGBA8 -> IO ()
forall pixel. PngSavable pixel => FilePath -> Image pixel -> IO ()
writePng (RenderOpts -> FilePath
outputFilepath RenderOpts
opts) Image PixelRGBA8
img

printScenarioMap :: [String] -> IO ()
printScenarioMap :: [FilePath] -> IO ()
printScenarioMap =
  IO () -> IO ()
forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO (IO () -> IO ()) -> ([FilePath] -> IO ()) -> [FilePath] -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> IO ()) -> [FilePath] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
putStrLn