WIP: preview structures

app/scene/Main.hs

@@ -5,15 +5,30 @@
 module Main where
 
 import Options.Applicative
+import Swarm.Failure (simpleErrorHandle)
 import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..))
 import Swarm.Game.World.Render (FailureMode (..), OuputFormat (..), RenderComputationContext (..), RenderOpts (..), doRenderCmd)
+import Swarm.Render.Structures
+
+data CLIToplevel
+  = CLIToplevel FilePath CLI
 
 data CLI
-  = RenderMap FilePath RenderOpts
+  = RenderMap RenderOpts
+  | RenderStructures RenderOpts
 
-cliParser :: Parser CLI
+cliParser :: Parser CLIToplevel
 cliParser =
-  RenderMap <$> strArgument (metavar "SCENARIO") <*> subOpts
+  CLIToplevel
+    <$> strArgument (metavar "SCENARIO")
+    <*> ( subparser
+            ( mconcat
+                [ command "scene" (info (RenderMap <$> subOpts <**> helper) (progDesc "Run the Swarm game (default)"))
+                , command "structures" (info (RenderStructures <$> subOpts <**> helper) (progDesc "Format a file"))
+                ]
+            )
+            <|> (RenderMap <$> subOpts)
+        )
  where
   sizeOpts =
     AreaDimensions
@@ -35,7 +50,7 @@ cliParser =
   seed :: Parser (Maybe Int)
   seed = optional $ option auto (long "seed" <> short 's' <> metavar "INT" <> help "Seed to use for world generation")
 
-cliInfo :: ParserInfo CLI
+cliInfo :: ParserInfo CLIToplevel
 cliInfo =
   info
     (cliParser <**> helper)
@@ -46,6 +61,10 @@ cliInfo =
 
 main :: IO ()
 main = do
-  cli <- execParser cliInfo
+  CLIToplevel mapPath cli <- execParser cliInfo
   case cli of
-    RenderMap mapPath opts -> doRenderCmd opts mapPath
+    RenderMap opts -> doRenderCmd opts mapPath
+    RenderStructures opts ->
+      simpleErrorHandle $
+        doRenderStructures mapPath $
+          outputFilepath opts

scripts/gen/img/preview-structures.sh

@@ -0,0 +1,29 @@
+#!/bin/bash -xe
+
+cd $(git rev-parse --show-toplevel)
+
+SCENARIO_PATH=${1?"Usage: $0 SCENARIO_PATH"}
+
+IMG_WIDTH=200
+IMG_HEIGHT=150
+
+DOT_OUTPUT_PATH=structures.dot
+
+EXECUTABLE_NAME=swarm-scene
+
+cabal build -j -O0 $EXECUTABLE_NAME
+
+OUTPUT_DIR=blarg
+
+mkdir -p $OUTPUT_DIR
+cabal run $EXECUTABLE_NAME -- \
+    $SCENARIO_PATH structures \
+    --fail-blank \
+    --dest $OUTPUT_DIR/$DOT_OUTPUT_PATH \
+    --png \
+    --width $IMG_WIDTH \
+    --height $IMG_HEIGHT
+
+cd $OUTPUT_DIR
+dot -Tpng -o structures.png $DOT_OUTPUT_PATH
+dot -Tsvg -o structures.svg $DOT_OUTPUT_PATH

src/swarm-render/Swarm/Render/Image.hs

@@ -0,0 +1,95 @@
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+module Swarm.Render.Image (
+  TransparencyHandling (..),
+  ImgRendering (..),
+  mkStructurePng,
+  defaultImageRendering,
+) where
+
+import Codec.Picture
+import Data.ByteString.Lazy qualified as LBS
+import Data.Either.Utils (forceEither)
+import Data.Function (on)
+import Data.Map (Map)
+import Swarm.Game.Scenario.Topography.Navigation.Waypoint (
+  Parentage (Root),
+ )
+import Swarm.Game.Scenario.Topography.Rasterize
+import Swarm.Game.Scenario.Topography.Structure
+import Swarm.Game.Scenario.Topography.Structure.Assembly
+import Swarm.Game.Scenario.Topography.Structure.Named (NamedArea, StructureName)
+import Swarm.Game.Scenario.Topography.Structure.Overlay
+import Swarm.Util (applyWhen)
+
+data TransparencyHandling
+  = Transparent
+  | DiagonalIndicators
+
+data ImgRendering = ImgRendering
+  { scaleNum :: Int
+  , transparencyHandling :: TransparencyHandling
+  }
+
+defaultImageRendering :: ImgRendering
+defaultImageRendering = ImgRendering 1 Transparent
+
+mkStructurePng ::
+  ToPixel a =>
+  ImgRendering ->
+  Map StructureName (NamedArea (PStructure (Maybe a))) ->
+  PStructure (Maybe a) ->
+  LBS.ByteString
+mkStructurePng (ImgRendering scaleFactor transparencyMode) sMap parentStruct =
+  encodePng . imgPipeline . makeImage $ gridContent overlayArea
+ where
+  imgPipeline = illustrateTransparency transparencyMode . scalePixelImage scaleFactor
+  overlayArea = forceMerge sMap parentStruct
+
+illustrateTransparency :: TransparencyHandling -> Image PixelRGBA8 -> Image PixelRGBA8
+illustrateTransparency mode img@(Image w h _) = case mode of
+  Transparent -> img
+  DiagonalIndicators -> mkNewImage img
+ where
+  mkNewImage s = generateImage (f s) w h
+  f s x y =
+    if pixelOpacity px == 0
+      then checkerColor
+      else px
+   where
+    px = pixelAt s x y
+    checkerOpacity =
+      if even $ (x `div` 2) + (y `div` 2)
+        then maxBound `div` 4
+        else maxBound `div` 2
+    checkerColor = PixelRGBA8 (gradientPixel x w) 128 128 checkerOpacity
+    gradientPixel i d = fromIntegral $ (i * 255) `div` d
+
+-- | Integral-factor scaling by nearest neighbor.
+-- Preserves sharp definition for pixel art.
+scaleImage :: Pixel a => Int -> Image a -> Image a
+scaleImage scaleFactor =
+  applyWhen (scaleFactor > 1) mkNewImage
+ where
+  mkNewImage s@(Image w h _) = (generateImage (f s) `on` (* scaleFactor)) w h
+  f s = pixelAt s `on` (`div` scaleFactor)
+
+scalePixelImage :: Int -> Image PixelRGBA8 -> Image PixelRGBA8
+scalePixelImage rawScaleFactor =
+  applyWhen (rawScaleFactor > 1) mkNewImage
+ where
+  scaleFactor = rawScaleFactor + 1
+  mkNewImage s@(Image w h _) = (generateImage (f s) `on` (* scaleFactor)) w h
+  f s x y =
+    if x `mod` scaleFactor == 0 || y `mod` scaleFactor == 0
+      then PixelRGBA8 minBound minBound minBound maxBound
+      else (pixelAt s `on` (`div` scaleFactor)) x y
+
+forceMerge ::
+  Map StructureName (NamedArea (PStructure (Maybe a))) ->
+  PStructure (Maybe a) ->
+  PositionedGrid (Maybe a)
+forceMerge sMap parentStruct =
+  overlayArea
+ where
+  MergedStructure overlayArea _ _ = forceEither $ mergeStructures sMap Root parentStruct

src/swarm-render/Swarm/Render/Structures.hs

@@ -0,0 +1,92 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+module Swarm.Render.Structures where
+
+import Control.Carrier.Throw.Either
+import Control.Effect.Lift
+import Control.Lens ((^.))
+import Control.Monad (forM_)
+import Data.ByteString.Lazy qualified as LBS
+import Data.Map (Map)
+import Data.Map qualified as M
+import Data.Text qualified as T
+import Swarm.Failure (SystemFailure)
+import Swarm.Game.Entity.Cosmetic
+import Swarm.Game.Scenario
+import Swarm.Game.Scenario.Topography.Cell (Cell)
+import Swarm.Game.Scenario.Topography.Structure
+import Swarm.Game.Scenario.Topography.Structure.Assembly
+import Swarm.Game.Scenario.Topography.Structure.Named
+import Swarm.Game.Scenario.Topography.WorldPalette
+import Swarm.Render.Image
+import Swarm.Util.Content (getTerrainEntityColor)
+import System.FilePath
+import Text.Dot
+
+renderStructuresGraph ::
+  M.Map k (NamedStructure a) ->
+  Dot ()
+renderStructuresGraph sMap =
+  nlg
+ where
+  gEdges = makeGraphEdges $ M.elems sMap
+
+  edgeLookup = M.fromList $ map (\x@(_, b, _) -> (b, x)) gEdges
+  nlg =
+    netlistGraph
+      (\k -> maybe mempty mkAttrs $ M.lookup k edgeLookup)
+      (\k -> maybe mempty (\(_, _, c) -> c) $ M.lookup k edgeLookup)
+      ([(a, a) | (_, a, _) <- gEdges])
+
+  mkAttrs (_, b, _) =
+    [ ("label", sname)
+    , ("height", "1")
+    , ("image", imgPath)
+    , ("shape", "box")
+    , ("style", "filled")
+    , ("penwidth", "0")
+    , ("fillcolor", "#b0b0b0:#f0f0f0")
+    , ("imagepos", "tc")
+    , ("labelloc", "b")
+    ]
+   where
+    imgPath = sname <.> "png"
+    sname = T.unpack $ getStructureName b
+
+renderImages ::
+  ImgRendering ->
+  FilePath ->
+  Map WorldAttr PreservableColor ->
+  Map StructureName (NamedArea (PStructure (Maybe Cell))) ->
+  IO ()
+renderImages imgRendering outputFolder aMap sMap = do
+  forM_ (M.toList modifiedMap) $ \(StructureName n, parentStruct) -> do
+    let fp = outputFolder </> T.unpack n <.> "png"
+        encodedImgBytestring = mkStructurePng imgRendering modifiedMap $ structure parentStruct
+    LBS.writeFile fp encodedImgBytestring
+ where
+  modifiedMap = M.map ((fmap . fmap . fmap) (getTerrainEntityColor aMap . toCellPaintDisplay)) sMap
+
+doRenderStructures ::
+  (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
+  FilePath ->
+  FilePath ->
+  m ()
+doRenderStructures scenarioFilepath outputFilepath = do
+  (myScenario, _gsi) <- loadStandaloneScenario scenarioFilepath
+  -- sendIO $ print $ myScenario ^. scenarioMetadata . scenarioName
+
+  let sMap = myScenario ^. scenarioDiagnostic . scenarioStructureMap
+      aMap = myScenario ^. scenarioLandscape . scenarioCosmetics
+      imgOutputFolder = "blarg"
+
+      sGraph = do
+        renderStructuresGraph sMap
+
+  -- attribute ("imagepath", imgOutputFolder)
+
+  sendIO $ do
+    renderImages (ImgRendering 8 DiagonalIndicators) imgOutputFolder aMap sMap
+    writeFile outputFilepath $ showDot sGraph

src/swarm-scenario/Swarm/Game/Scenario.hs

@@ -24,6 +24,8 @@ module Swarm.Game.Scenario (
   scenarioMetadata,
   scenarioOperation,
   scenarioLandscape,
+  scenarioDiagnostic,
+  scenarioStructureMap,
   scenarioVersion,
   scenarioName,
   scenarioAuthor,
@@ -232,12 +234,22 @@ scenarioNavigation :: Lens' ScenarioLandscape (Navigation (M.Map SubworldName) L
 --   include the base.
 scenarioRobots :: Lens' ScenarioLandscape [TRobot]
 
+newtype ScenarioDiagnostic = ScenarioDiagnostic
+  { _scenarioStructureMap :: M.Map Structure.StructureName (Structure.NamedStructure (Maybe Cell))
+  }
+
+makeLensesNoSigs ''ScenarioDiagnostic
+
+-- | Authorship information about scenario not used at play-time
+scenarioStructureMap :: Lens' ScenarioDiagnostic (M.Map Structure.StructureName (Structure.NamedStructure (Maybe Cell)))
+
 -- | A 'Scenario' contains all the information to describe a
 --   scenario.
 data Scenario = Scenario
   { _scenarioMetadata :: ScenarioMetadata
   , _scenarioOperation :: ScenarioOperation
   , _scenarioLandscape :: ScenarioLandscape
+  , _scenarioDiagnostic :: ScenarioDiagnostic
   }
 
 makeLensesNoSigs ''Scenario
@@ -252,6 +264,10 @@ scenarioOperation :: Lens' Scenario ScenarioOperation
 -- | All cosmetic and structural content of the scenario.
 scenarioLandscape :: Lens' Scenario ScenarioLandscape
 
+-- | Intermediate content not required for scenario
+-- play, but useful for development
+scenarioDiagnostic :: Lens' Scenario ScenarioDiagnostic
+
 -- * Parsing
 
 instance FromJSONE ScenarioInputs Scenario where
@@ -397,7 +413,9 @@ instance FromJSONE ScenarioInputs Scenario where
           <*> localE (view entityMap) (v ..:? "recipes" ..!= [])
           <*> liftE (v .:? "stepsPerTick")
 
-      return $ Scenario metadata playInfo landscape
+      let diagnostic = ScenarioDiagnostic structureMap
+
+      return $ Scenario metadata playInfo landscape diagnostic
    where
     runValidation f = case run . runThrow $ f of
       Right x -> return x

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs

@@ -39,7 +39,7 @@ data PStructure c = Structure
   -- ^ earlier placements will be overlaid on top of later placements in the YAML file
   , waypoints :: [Waypoint]
   }
-  deriving (Eq, Show)
+  deriving (Eq, Show, Functor)
 
 data Placed c = Placed Placement (NamedStructure c)
   deriving (Show)

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs

@@ -8,6 +8,7 @@
 module Swarm.Game.Scenario.Topography.Structure.Assembly (
   mergeStructures,
   makeStructureMap,
+  makeGraphEdges,
 
   -- * Exposed for unit tests:
   foldLayer,
@@ -76,7 +77,7 @@ makeGraphEdges =
 -- | Overlays all of the "child placements", such that the children encountered later
 -- in the YAML file supersede the earlier ones (dictated by using 'foldl' instead of 'foldr').
 mergeStructures ::
-  M.Map StructureName (NamedStructure (Maybe a)) ->
+  M.Map StructureName (NamedArea (PStructure (Maybe a))) ->
   Parentage Placement ->
   PStructure (Maybe a) ->
   Either Text (MergedStructure (Maybe a))

src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs

@@ -28,7 +28,7 @@ data PositionedGrid a = PositionedGrid
   -- ^ location of the upper-left cell
   , gridContent :: Grid a
   }
-  deriving (Eq)
+  deriving (Eq, Functor)
 
 instance HasLocation (PositionedGrid a) where
   modifyLoc f (PositionedGrid originalLoc g) =