embed images without writing to disk

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

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

src/swarm-render/Swarm/Render/Structures.hs

@@ -1,92 +1,168 @@
 {-# 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
 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) =>
   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
+  (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."

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,