diff --git a/app/scene/Main.hs b/app/scene/Main.hs index ddb952f9a..44a85351b 100644 --- a/app/scene/Main.hs +++ b/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 diff --git a/scripts/gen/img/preview-structures.sh b/scripts/gen/img/preview-structures.sh new file mode 100755 index 000000000..5c7ca1bd1 --- /dev/null +++ b/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 diff --git a/src/swarm-render/Swarm/Render/Image.hs b/src/swarm-render/Swarm/Render/Image.hs new file mode 100644 index 000000000..72a007814 --- /dev/null +++ b/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 diff --git a/src/swarm-render/Swarm/Render/Structures.hs b/src/swarm-render/Swarm/Render/Structures.hs new file mode 100644 index 000000000..244dd57b5 --- /dev/null +++ b/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 diff --git a/src/swarm-scenario/Swarm/Game/Scenario.hs b/src/swarm-scenario/Swarm/Game/Scenario.hs index cd632d564..03f550147 100644 --- a/src/swarm-scenario/Swarm/Game/Scenario.hs +++ b/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 diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs index f19373318..b77682c39 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure.hs +++ b/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) diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs index 69a30ed31..41190afaf 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Assembly.hs +++ b/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)) diff --git a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs b/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs index 81bb9eb8c..d8b0381ff 100644 --- a/src/swarm-topography/Swarm/Game/Scenario/Topography/Structure/Overlay.hs +++ b/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) = diff --git a/swarm.cabal b/swarm.cabal index ba012a7d9..609dd3da9 100644 --- a/swarm.cabal +++ b/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: diff --git a/test/standalone-topography/src/Lib.hs b/test/standalone-topography/src/Lib.hs index c73991d8e..c97ac3c9b 100644 --- a/test/standalone-topography/src/Lib.hs +++ b/test/standalone-topography/src/Lib.hs @@ -4,20 +4,14 @@ -- SPDX-License-Identifier: BSD-3-Clause module Lib (compareToReferenceImage) where -import Codec.Picture import Control.Arrow (left) import Data.ByteString.Lazy qualified as LBS import Data.Either.Utils (forceEither) import Data.Yaml (prettyPrintParseException) import Paths_swarm (getDataDir) -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.Overlay import Swarm.Game.World.Render +import Swarm.Render.Image import Swarm.Util.Yaml import System.FilePath import Test.Tasty.HUnit (Assertion, assertEqual) @@ -40,8 +34,7 @@ compareToReferenceImage :: compareToReferenceImage refreshReferenceImage fileStem = do dataDir <- getDataDir parentStruct <- parseStructures dataDir $ fileStem <.> "yaml" - let MergedStructure overlayArea _ _ = forceEither $ mergeStructures mempty Root parentStruct - encodedImgBytestring = encodePng $ makeImage $ gridContent overlayArea + let encodedImgBytestring = mkStructurePng mempty parentStruct referenceFilepath = dataDir "test/standalone-topography" fileStem <.> "png" if refreshReferenceImage then LBS.writeFile referenceFilepath encodedImgBytestring