From 57b5dea7e8109233bb0e231d78b217cfe0404ca8 Mon Sep 17 00:00:00 2001 From: Karl Ostmo Date: Sun, 19 Jan 2025 00:22:30 -0800 Subject: [PATCH] embed images without writing to disk --- scripts/gen/img/preview-structures.sh | 8 +- src/swarm-render/Swarm/Render/Image.hs | 23 ++- src/swarm-render/Swarm/Render/Structures.hs | 182 ++++++++++++++------ swarm.cabal | 19 +- 4 files changed, 165 insertions(+), 67 deletions(-) diff --git a/scripts/gen/img/preview-structures.sh b/scripts/gen/img/preview-structures.sh index 5c7ca1bd1..dde93038d 100755 --- a/scripts/gen/img/preview-structures.sh +++ b/scripts/gen/img/preview-structures.sh @@ -7,7 +7,7 @@ SCENARIO_PATH=${1?"Usage: $0 SCENARIO_PATH"} IMG_WIDTH=200 IMG_HEIGHT=150 -DOT_OUTPUT_PATH=structures.dot +FINAL_IMG_PATH=final8.png EXECUTABLE_NAME=swarm-scene @@ -19,11 +19,7 @@ mkdir -p $OUTPUT_DIR cabal run $EXECUTABLE_NAME -- \ $SCENARIO_PATH structures \ --fail-blank \ - --dest $OUTPUT_DIR/$DOT_OUTPUT_PATH \ + --dest $FINAL_IMG_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 index 04df3a788..d435cedd9 100644 --- a/src/swarm-render/Swarm/Render/Image.hs +++ b/src/swarm-render/Swarm/Render/Image.hs @@ -3,6 +3,7 @@ module Swarm.Render.Image ( TransparencyHandling (..), ImgRendering (..), + mkStructureImage, mkStructurePng, defaultImageRendering, ) where @@ -34,19 +35,31 @@ data ImgRendering = ImgRendering defaultImageRendering :: ImgRendering defaultImageRendering = ImgRendering 1 Transparent -mkStructurePng :: +mkStructureImage :: 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 + Image PixelRGBA8 +mkStructureImage (ImgRendering scaleFactor transparencyMode) sMap parentStruct = + imgPipeline . makeImage $ gridContent overlayArea where imgPipeline = illustrateTransparency transparencyMode . scalePixelImage scaleFactor overlayArea = forceMerge sMap parentStruct -illustrateTransparency :: TransparencyHandling -> Image PixelRGBA8 -> Image PixelRGBA8 +mkStructurePng :: + ToPixel a => + ImgRendering -> + Map StructureName (NamedArea (PStructure (Maybe a))) -> + PStructure (Maybe a) -> + LBS.ByteString +mkStructurePng r sMap parentStruct = + encodePng $ mkStructureImage r sMap parentStruct + +illustrateTransparency :: + TransparencyHandling -> + Image PixelRGBA8 -> + Image PixelRGBA8 illustrateTransparency mode img@(Image w h _) = case mode of Transparent -> img DiagonalIndicators -> mkNewImage img diff --git a/src/swarm-render/Swarm/Render/Structures.hs b/src/swarm-render/Swarm/Render/Structures.hs index 2acd042c9..d24f8aac1 100644 --- a/src/swarm-render/Swarm/Render/Structures.hs +++ b/src/swarm-render/Swarm/Render/Structures.hs @@ -1,17 +1,25 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} -- | -- SPDX-License-Identifier: BSD-3-Clause module Swarm.Render.Structures where +import Codec.Picture as JP 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.Foldable (foldl') +import Data.GraphViz +import Data.GraphViz.Attributes.Complete as GVA +import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Map (Map) import Data.Map qualified as M import Data.Text qualified as T +import Data.Text.Lazy qualified as LT +import Diagrams.Backend.Rasterific +import Diagrams.Prelude hiding (p2) +import Diagrams.TwoD.GraphViz +import Diagrams.TwoD.Image import Swarm.Failure (SystemFailure) import Swarm.Game.Entity.Cosmetic import Swarm.Game.Scenario @@ -19,55 +27,126 @@ 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.Structure.Named (getStructureName) import Swarm.Game.Scenario.Topography.WorldPalette import Swarm.Render.Image +import Swarm.Util import Swarm.Util.Content (getTerrainEntityColor) -import System.FilePath -import Text.Dot + +instance IsName StructureName renderStructuresGraph :: - M.Map k (NamedStructure a) -> - Dot () -renderStructuresGraph sMap = - nlg + ImgRendering -> + Map StructureName (NamedStructure (Maybe PreservableColor)) -> + IO (Diagram B) +renderStructuresGraph imgRendering sMap = do + g' <- layoutGraph' params Dot g + + putStrLn . LT.unpack . printDotGraph $ graphToDot params g + let drawing = + drawGraph + (place . maybe mempty fst . (`M.lookup` nodeDiagrams)) + (\_ _ _ _ _ _ -> mempty) + g' + + drawingWithEdges = foldl' (\d (n1, n2) -> connectOutside n1 n2 d) drawing edgeList + + -- mapM_ (print . snd) $ M.elems nodeDiagrams + + return $ drawingWithEdges # frame 1 where - gEdges = makeGraphEdges $ M.elems sMap + params :: GraphvizParams Int StructureName e () StructureName + params = + defaultDiaParams + { fmtEdge = const [arrowTo noArrow] + , fmtNode = nodeFmt + } + + nodeFmt (_, s) = maybe mempty getSize . (`M.lookup` nodeDiagrams) $ s + where + getSize = f . snd - 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") - ] + -- Image dimensions in terms of pixels are manipulated. + -- + -- Explicit width/height are expected to be provided in inches. + -- Internally, they are then multiplied by 72 + -- (see https://gitlab.com/graphviz/graphviz/-/blob/main/lib/sparse/DotIO.c#L482 ) + -- to obtain a dimension in units of "points". + -- + -- Conversely, if an "image" attribute is supplied to a node, + -- its width and height in pixels is actually scaled to an + -- internal value by a factor of (72 / 96 = 0.75), where 96 is a configurable DPI + -- at the graph level (see https://graphviz.org/docs/attrs/dpi/ ), + -- https://gitlab.com/graphviz/graphviz/-/blob/main/lib/gvc/gvusershape.c#L752-753 + -- https://gitlab.com/graphviz/graphviz/-/blob/main/cmake/config_checks.cmake#L74 + -- + -- Therefore, if one wants to use an explicit width and height replicate an identical + -- behavior of the "image" property, one must take the pixel dimensions of the image + -- and divide them by 96 for use as the "height" and "width" properties. + + f (V2 w h) = + [ GVA.Shape GVA.BoxShape + , -- , FixedSize GrowAsNeeded + FixedSize SetNodeSize + , Width $ fromIntegral w / 96 + , Height $ fromIntegral h / 96 + , GVA.Label $ GVA.StrLabel "" + -- , GVA.Image $ LT.fromStrict $ "blarg/" <> getStructureName s <> ".png" + ] + + nodeDiagrams = M.fromList $ map (\n -> (n, drawNode n)) nodeList + drawNode n = + (d, b) where - imgPath = sname <.> "png" - sname = T.unpack $ getStructureName b + d = + vsep + 5 + [ boxThing # named n + , scale 15 . text . T.unpack $ nameText + ] + -- boxThing = roundedRect 30 15 2 <> structureThumbnail + boxThing = fst structureThumbnail + -- b = boxExtents $ boundingBox boxThing + b = snd structureThumbnail + + nameText = getStructureName n + structureThumbnail = maybe (defaultDiagram, V2 1 1) getImg $ M.lookup n sMap -renderImages :: + defaultDiagram = + scale 10 $ + vsep + 1 + [ text "Not found" + , text "World" + ] + + getImg x = (scale 0.75 . image . embeddedImage . ImageRGBA8 $ i, V2 w h) + where + i@(JP.Image w h _) = genStructureImage imgRendering sMap x + + gEdges = makeGraphEdges $ M.elems sMap + + edgeList = [(m, n) | (_, n, neighbors) <- gEdges, m <- neighbors] + nodeList = [a | (_, a, _) <- gEdges] + g = + mkGraph + nodeList + [(m, n, ()) | (m, n) <- edgeList] + +genStructureImage :: ImgRendering -> - FilePath -> + Map StructureName (NamedArea (PStructure (Maybe PreservableColor))) -> + NamedArea (PStructure (Maybe PreservableColor)) -> + Image PixelRGBA8 +genStructureImage imgRendering modifiedMap s = + mkStructureImage imgRendering modifiedMap $ structure s + +applyStructureColors :: 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 + NamedArea (PStructure (Maybe Cell)) -> + NamedArea (PStructure (Maybe PreservableColor)) +applyStructureColors aMap = + (fmap . fmap) (getTerrainEntityColor aMap . toCellPaintDisplay =<<) doRenderStructures :: (Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) => @@ -75,18 +154,15 @@ doRenderStructures :: 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 + (scenario, _) <- loadStandaloneScenario scenarioFilepath - -- attribute ("imagepath", imgOutputFolder) + let sMap = scenario ^. scenarioDiagnostic . scenarioStructureMap + aMap = scenario ^. scenarioLandscape . scenarioCosmetics sendIO $ do - renderImages (ImgRendering 8 DiagonalIndicators) imgOutputFolder aMap sMap - writeFile outputFilepath $ showDot sGraph + g <- + renderStructuresGraph (ImgRendering 8 DiagonalIndicators) $ + M.map (applyStructureColors aMap) sMap + putStrLn $ "Rendering to path: " ++ outputFilepath + renderRasterific outputFilepath (mkWidth 1600) g + putStrLn "Finished rendering." diff --git a/swarm.cabal b/swarm.cabal index fac935865..ab79738f0 100644 --- a/swarm.cabal +++ b/swarm.cabal @@ -182,6 +182,15 @@ common data-fix common deriving-compat build-depends: deriving-compat >=0.6 && <0.7 +common diagrams-graphviz + build-depends: diagrams-graphviz >=1.4.1 && <1.4.2 + +common diagrams-lib + build-depends: diagrams-lib >=1.4.6 && <1.4.8 + +common diagrams-rasterific + build-depends: diagrams-rasterific >=1.4.2 && <1.4.4 + common directory build-depends: directory >=1.3 && <1.4 @@ -218,6 +227,9 @@ common generic-data common githash build-depends: githash >=0.1.6 && <0.2 +common graphviz + build-depends: graphviz >=2999.20.1 && <2999.20.3 + common hashable build-depends: hashable >=1.3.4 && <1.5 @@ -986,10 +998,11 @@ library swarm-render stan-config, common, ghc2021-extensions, base, containers, - dotgen, - filepath, + diagrams-graphviz, + diagrams-lib, + diagrams-rasterific, fused-effects, - lens, + graphviz, MissingH, JuicyPixels, bytestring,