WIP: preview structures

app/scene/Main.hs

@@ -5,15 +5,30 @@
 module Main where
 
 import Options.Applicative
+import Structures
+import Swarm.Failure (simpleErrorHandle)
 import Swarm.Game.Scenario.Topography.Area (AreaDimensions (..))
 import Swarm.Game.World.Render (FailureMode (..), OuputFormat (..), RenderComputationContext (..), RenderOpts (..), doRenderCmd)
 
+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,8 @@ 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 $ do
+      doRenderStructures mapPath

app/scene/Structures.hs

@@ -0,0 +1,45 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- |
+-- SPDX-License-Identifier: BSD-3-Clause
+module Structures where
+
+import Control.Carrier.Throw.Either
+import Control.Effect.Lift
+import Control.Lens ((^.))
+import Data.Map qualified as M
+import Data.Text qualified as T
+import Swarm.Failure (SystemFailure)
+import Swarm.Game.Scenario
+import Swarm.Game.Scenario.Topography.Structure
+import Swarm.Game.Scenario.Topography.Structure.Assembly
+import Swarm.Game.Scenario.Topography.Structure.Named
+import Text.Dot
+
+renderStructuresGraph ::
+  M.Map k (NamedStructure a) ->
+  String
+renderStructuresGraph sMap =
+  showDot nlg
+ where
+  gEdges = makeGraphEdges $ M.elems sMap
+
+  edgeLookup = M.fromList $ map (\x@(_, b, _) -> (b, x)) gEdges
+  nlg =
+    netlistGraph
+      (\k -> maybe mempty (\(_a, b, _) -> [("label", T.unpack $ getStructureName b)]) $ M.lookup k edgeLookup)
+      (\k -> maybe mempty (\(_, _, c) -> c) $ M.lookup k edgeLookup)
+      ([(a, a) | (_, a, _) <- gEdges])
+
+doRenderStructures ::
+  (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
+  FilePath ->
+  m ()
+doRenderStructures fp = do
+  (myScenario, _gsi) <- loadStandaloneScenario fp
+  -- sendIO $ print $ myScenario ^. scenarioMetadata . scenarioName
+
+  let sMap = myScenario ^. scenarioDiagnostic . scenarioStructureMap
+      sGraph = renderStructuresGraph sMap
+
+  sendIO $ putStrLn sGraph

scripts/gen/img/preview-structures.sh

@@ -0,0 +1,15 @@
+#!/bin/bash -xe
+
+cd $(git rev-parse --show-toplevel)
+
+SCENARIO_PATH=${1?"Usage: $0 SCENARIO_PATH"}
+
+IMG_WIDTH=200
+IMG_HEIGHT=150
+
+IMG_OUTPUT_PATH=output.png
+RENDER_IMG_COMMAND="cabal run swarm-scene -- $SCENARIO_PATH  structures --fail-blank --dest $IMG_OUTPUT_PATH --png --width $IMG_WIDTH --height $IMG_HEIGHT"
+
+cabal build -j -O0 swarm:swarm-scene
+
+$RENDER_IMG_COMMAND | dot -Tsvg -o structures.svg

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/Assembly.hs

@@ -8,6 +8,7 @@
 module Swarm.Game.Scenario.Topography.Structure.Assembly (
   mergeStructures,
   makeStructureMap,
+  makeGraphEdges,
 
   -- * Exposed for unit tests:
   foldLayer,

swarm.cabal

@@ -1148,17 +1148,26 @@ executable swarm-scene
   import:
     stan-config, common, ghc2021-extensions,
     base,
+    containers,
+    dotgen,
+    fused-effects,
+    lens,
     optparse-applicative,
+    text,
 
   main-is: Main.hs
   build-depends:
     swarm:swarm-scenario,
     swarm:swarm-topography,
+    swarm:swarm-util,
 
   hs-source-dirs: app/scene
   ghc-options:
     -hiedir=.hie/app/scene
 
+  other-modules:
+    Structures
+
   default-language: Haskell2010
   ghc-options: -threaded
   default-extensions: ImportQualifiedPost