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,48 @@
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+module Swarm.Render.Image (
+  mkStructurePng,
+) where
+
+import Codec.Picture
+import Data.ByteString.Lazy qualified as LBS
+import Data.Either.Utils (forceEither)
+import Data.Function (applyWhen, 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
+
+mkStructurePng ::
+  ToPixel a =>
+  Int ->
+  Map StructureName (NamedArea (PStructure (Maybe a))) ->
+  PStructure (Maybe a) ->
+  LBS.ByteString
+mkStructurePng scaleFactor sMap parentStruct =
+  encodePng . scaleImage scaleFactor . makeImage $ gridContent overlayArea
+ where
+  overlayArea = forceMerge sMap parentStruct
+
+-- | 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)
+
+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,83 @@
+{-# 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)
+    , ("image", sname <.> "png")
+    ]
+   where
+    sname = T.unpack $ getStructureName b
+
+renderImages ::
+  Int ->
+  FilePath ->
+  Map WorldAttr PreservableColor ->
+  Map StructureName (NamedArea (PStructure (Maybe Cell))) ->
+  IO ()
+renderImages imgScale outputFolder aMap sMap = do
+  forM_ (M.toList modifiedMap) $ \(StructureName n, parentStruct) -> do
+    let fp = outputFolder </> T.unpack n <.> "png"
+        encodedImgBytestring = mkStructurePng imgScale 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 5 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) =

swarm.cabal

@@ -981,6 +981,41 @@ library swarm-doc
     -- See discussion in #415
     StrictData
 
+library swarm-render
+  import:
+    stan-config, common, ghc2021-extensions,
+    base,
+    containers,
+    dotgen,
+    filepath,
+    fused-effects,
+    lens,
+    MissingH,
+    JuicyPixels,
+    bytestring,
+    text,
+
+  visibility: public
+  -- cabal-gild: discover src/swarm-render
+  exposed-modules:
+    Swarm.Render.Image
+    Swarm.Render.Structures
+
+  build-depends:
+    swarm:swarm-scenario,
+    swarm:swarm-topography,
+    swarm:swarm-util,
+
+  hs-source-dirs: src/swarm-render
+  ghc-options:
+    -hiedir=.hie/src/swarm-render
+
+  default-language: Haskell2010
+  default-extensions:
+    -- Avoid unexpected unevaluated thunk buildup
+    -- See discussion in #415
+    StrictData
+
 library swarm-tui
   import:
     stan-config, common, ghc2021-extensions,
@@ -1154,6 +1189,8 @@ executable swarm-scene
   build-depends:
     swarm:swarm-scenario,
     swarm:swarm-topography,
+    swarm:swarm-render,
+    swarm:swarm-util,
 
   hs-source-dirs: app/scene
   ghc-options:
@@ -1330,7 +1367,6 @@ test-suite tournament-host
 test-suite standalone-topography
   import:
     stan-config, common, ghc2021-extensions,
-    JuicyPixels,
     MissingH,
     base,
     bytestring,
@@ -1350,6 +1386,7 @@ test-suite standalone-topography
     swarm:swarm-scenario,
     swarm:swarm-topography,
     swarm:swarm-util,
+    swarm:swarm-render,
 
   hs-source-dirs: test/standalone-topography/src
   ghc-options: