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..2f859fe50 --- /dev/null +++ b/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 diff --git a/src/swarm-render/Swarm/Render/Structures.hs b/src/swarm-render/Swarm/Render/Structures.hs new file mode 100644 index 000000000..2acd042c9 --- /dev/null +++ b/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 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..fac935865 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, @@ -1152,8 +1187,10 @@ executable swarm-scene main-is: Main.hs build-depends: + swarm:swarm-render, swarm:swarm-scenario, swarm:swarm-topography, + 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, @@ -1347,6 +1383,7 @@ test-suite standalone-topography other-modules: Paths_swarm autogen-modules: Paths_swarm build-depends: + swarm:swarm-render, swarm:swarm-scenario, swarm:swarm-topography, swarm:swarm-util, diff --git a/test/standalone-topography/src/Lib.hs b/test/standalone-topography/src/Lib.hs index c73991d8e..78e0da36b 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 defaultImageRendering mempty parentStruct referenceFilepath = dataDir "test/standalone-topography" fileStem <.> "png" if refreshReferenceImage then LBS.writeFile referenceFilepath encodedImgBytestring