{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Auto-generation of various forms of documentation.
module Swarm.Doc.Gen (
  -- ** Main document generation function + types
  generateDocs,
  GenerateDocs (..),
  SheetType (..),

  -- ** Wiki pages
  PageAddress (..),

  -- ** Recipe graph drawing
  EdgeFilter (..),
) where

import Control.Lens (view, (^.))
import Control.Monad (zipWithM, zipWithM_)
import Data.Aeson.Text (encodeToLazyText)
import Data.Containers.ListUtils (nubOrd)
import Data.Foldable (toList)
import Data.List qualified as List
import Data.List.Extra (enumerate)
import Data.Map.Lazy qualified as Map
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Text.Lazy.IO qualified as TL
import Swarm.Doc.Command (getCatalog)
import Swarm.Doc.Keyword
import Swarm.Doc.Pedagogy
import Swarm.Doc.Wiki.Cheatsheet
import Swarm.Game.Entity (Entity, entityName, entityYields)
import Swarm.Game.Recipe (recipeCatalysts, recipeInputs, recipeOutputs)
import Swarm.Game.Recipe.Graph qualified as RG
import Swarm.Language.Key (specialKeyNames)
import Swarm.Util (both)
import Text.Dot (Dot, NodeId, (.->.))
import Text.Dot qualified as Dot

-- ============================================================================
-- MAIN ENTRYPOINT TO CLI DOCUMENTATION GENERATOR
-- ============================================================================
--
-- These are the exported functions used by the executable.
--
-- ----------------------------------------------------------------------------

-- | An enumeration of the kinds of documentation we can generate.
data GenerateDocs where
  -- | Entity dependencies by recipes.
  RecipeGraph :: EdgeFilter -> GenerateDocs
  -- | Keyword lists for editors.
  EditorKeywords :: Maybe EditorType -> GenerateDocs
  -- | List of special key names recognized by 'Swarm.Language.Syntax.Key' command
  SpecialKeyNames :: GenerateDocs
  -- | Cheat sheets for inclusion on the Swarm wiki.
  CheatSheet :: PageAddress -> SheetType -> GenerateDocs
  -- | JSON representation of commands metadata matrix
  CommandsData :: GenerateDocs
  -- | List command introductions by tutorial
  TutorialCoverage :: GenerateDocs
  deriving (GenerateDocs -> GenerateDocs -> Bool
(GenerateDocs -> GenerateDocs -> Bool)
-> (GenerateDocs -> GenerateDocs -> Bool) -> Eq GenerateDocs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GenerateDocs -> GenerateDocs -> Bool
== :: GenerateDocs -> GenerateDocs -> Bool
$c/= :: GenerateDocs -> GenerateDocs -> Bool
/= :: GenerateDocs -> GenerateDocs -> Bool
Eq, Int -> GenerateDocs -> ShowS
[GenerateDocs] -> ShowS
GenerateDocs -> String
(Int -> GenerateDocs -> ShowS)
-> (GenerateDocs -> String)
-> ([GenerateDocs] -> ShowS)
-> Show GenerateDocs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GenerateDocs -> ShowS
showsPrec :: Int -> GenerateDocs -> ShowS
$cshow :: GenerateDocs -> String
show :: GenerateDocs -> String
$cshowList :: [GenerateDocs] -> ShowS
showList :: [GenerateDocs] -> ShowS
Show)

-- | Generate the requested kind of documentation to stdout.
generateDocs :: GenerateDocs -> IO ()
generateDocs :: GenerateDocs -> IO ()
generateDocs = \case
  RecipeGraph EdgeFilter
ef -> EdgeFilter -> IO String
generateRecipe EdgeFilter
ef IO String -> (String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
putStrLn
  EditorKeywords Maybe EditorType
e ->
    case Maybe EditorType
e of
      Just EditorType
et -> EditorType -> IO ()
generateEditorKeywords EditorType
et
      Maybe EditorType
Nothing -> do
        String -> IO ()
putStrLn String
"All editor completions:"
        let editorGen :: EditorType -> IO ()
editorGen EditorType
et = do
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
40 Char
'-'
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"-- " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> EditorType -> String
forall a. Show a => a -> String
show EditorType
et
              String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
40 Char
'-'
              EditorType -> IO ()
generateEditorKeywords EditorType
et
        (EditorType -> IO ()) -> [EditorType] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ EditorType -> IO ()
editorGen [EditorType]
forall a. (Enum a, Bounded a) => [a]
enumerate
  GenerateDocs
SpecialKeyNames -> IO ()
generateSpecialKeyNames
  CheatSheet PageAddress
address SheetType
s -> PageAddress -> SheetType -> IO ()
makeWikiPage PageAddress
address SheetType
s
  GenerateDocs
CommandsData -> Text -> IO ()
TL.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ CommandCatalog -> Text
forall a. ToJSON a => a -> Text
encodeToLazyText CommandCatalog
getCatalog
  GenerateDocs
TutorialCoverage -> IO Text
renderTutorialProgression IO Text -> (Text -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
putStrLn (String -> IO ()) -> (Text -> String) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

-- ----------------------------------------------------------------------------
-- GENERATE KEYWORDS: LIST OF WORDS TO BE HIGHLIGHTED
-- ----------------------------------------------------------------------------

-- | Generate a list of keywords in the format expected by one of the
--   supported editors.
generateEditorKeywords :: EditorType -> IO ()
generateEditorKeywords :: EditorType -> IO ()
generateEditorKeywords = \case
  EditorType
Emacs -> do
    String -> IO ()
putStrLn String
"(defvar swarm-mode-builtins '("
    Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ EditorType -> Text
builtinFunctionList EditorType
Emacs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"))"
    String -> IO ()
putStrLn String
"\n(defvar swarm-mode-commands '("
    Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ EditorType -> Text
keywordsCommands EditorType
Emacs
    Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ EditorType -> Text
keywordsDirections EditorType
Emacs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"))"
    String -> IO ()
putStrLn String
"\n (defvar swarm-mode-operators '("
    Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ EditorType -> Text
operatorNames EditorType
Emacs Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"))"
  EditorType
VSCode -> do
    String -> IO ()
putStrLn String
"Functions and commands:"
    Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ EditorType -> Text
builtinFunctionList EditorType
VSCode Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"|" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EditorType -> Text
keywordsCommands EditorType
VSCode
    String -> IO ()
putStrLn String
"\nDirections:"
    Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ EditorType -> Text
keywordsDirections EditorType
VSCode
    String -> IO ()
putStrLn String
"\nOperators:"
    Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ EditorType -> Text
operatorNames EditorType
VSCode
  EditorType
Vim -> do
    String -> IO ()
putStrLn String
"syn keyword Builtins "
    Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ EditorType -> Text
builtinFunctionList EditorType
Vim
    String -> IO ()
putStrLn String
"\nsyn keyword Command "
    Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ EditorType -> Text
keywordsCommands EditorType
Vim
    String -> IO ()
putStrLn String
"\nsyn keyword Direction "
    Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ EditorType -> Text
keywordsDirections EditorType
Vim
    String -> IO ()
putStrLn String
"\nsyn match Operators "
    Text -> IO ()
T.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EditorType -> Text
operatorNames EditorType
Vim Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"

-- ----------------------------------------------------------------------------
-- GENERATE SPECIAL KEY NAMES
-- ----------------------------------------------------------------------------

generateSpecialKeyNames :: IO ()
generateSpecialKeyNames :: IO ()
generateSpecialKeyNames =
  Text -> IO ()
T.putStr (Text -> IO ()) -> (Set Text -> Text) -> Set Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> Text) -> (Set Text -> [Text]) -> Set Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Text -> [Text]
forall a. Set a -> [a]
Set.toList (Set Text -> IO ()) -> Set Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Set Text
specialKeyNames

-- ----------------------------------------------------------------------------
-- GENERATE GRAPHVIZ: ENTITY DEPENDENCIES BY RECIPES
-- ----------------------------------------------------------------------------

generateRecipe :: EdgeFilter -> IO String
generateRecipe :: EdgeFilter -> IO String
generateRecipe EdgeFilter
ef = do
  RecipeGraph
graphData <- IO RecipeGraph
RG.classicScenarioRecipeGraph
  String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> (Dot () -> String) -> Dot () -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dot () -> String
forall a. Dot a -> String
Dot.showDot (Dot () -> IO String) -> Dot () -> IO String
forall a b. (a -> b) -> a -> b
$ RecipeGraph -> EdgeFilter -> Dot ()
recipesToDot RecipeGraph
graphData EdgeFilter
ef

data EdgeFilter = NoFilter | FilterForward | FilterNext
  deriving (EdgeFilter -> EdgeFilter -> Bool
(EdgeFilter -> EdgeFilter -> Bool)
-> (EdgeFilter -> EdgeFilter -> Bool) -> Eq EdgeFilter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EdgeFilter -> EdgeFilter -> Bool
== :: EdgeFilter -> EdgeFilter -> Bool
$c/= :: EdgeFilter -> EdgeFilter -> Bool
/= :: EdgeFilter -> EdgeFilter -> Bool
Eq, Int -> EdgeFilter -> ShowS
[EdgeFilter] -> ShowS
EdgeFilter -> String
(Int -> EdgeFilter -> ShowS)
-> (EdgeFilter -> String)
-> ([EdgeFilter] -> ShowS)
-> Show EdgeFilter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EdgeFilter -> ShowS
showsPrec :: Int -> EdgeFilter -> ShowS
$cshow :: EdgeFilter -> String
show :: EdgeFilter -> String
$cshowList :: [EdgeFilter] -> ShowS
showList :: [EdgeFilter] -> ShowS
Show)

filterEdge :: EdgeFilter -> Int -> Int -> Bool
filterEdge :: EdgeFilter -> Int -> Int -> Bool
filterEdge EdgeFilter
ef Int
i Int
o = case EdgeFilter
ef of
  EdgeFilter
NoFilter -> Bool
True
  EdgeFilter
FilterForward -> Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
o
  EdgeFilter
FilterNext -> Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
o

recipesToDot :: RG.RecipeGraph -> EdgeFilter -> Dot ()
recipesToDot :: RecipeGraph -> EdgeFilter -> Dot ()
recipesToDot RecipeGraph
graphData EdgeFilter
ef = do
  (String, String) -> Dot ()
Dot.attribute (String
"rankdir", String
"LR")
  (String, String) -> Dot ()
Dot.attribute (String
"ranksep", String
"2")
  NodeId
world <- String -> Dot NodeId
diamond String
"World"
  NodeId
base <- String -> Dot NodeId
diamond String
"Base"
  -- --------------------------------------------------------------------------
  -- add nodes for all the known entities
  let enames' :: [Text]
enames' = (Entity -> Text) -> [Entity] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Getting Text Entity Text -> Entity -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Entity Text
Lens' Entity Text
entityName) ([Entity] -> [Text])
-> (Set Entity -> [Entity]) -> Set Entity -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Entity -> [Entity]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set Entity -> [Text]) -> Set Entity -> [Text]
forall a b. (a -> b) -> a -> b
$ RecipeGraph -> Set Entity
RG.allEntities RecipeGraph
graphData
      enames :: [Text]
enames = (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Text
RG.ignoredEntities) [Text]
enames'
  Map Text NodeId
ebmap <- [(Text, NodeId)] -> Map Text NodeId
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, NodeId)] -> Map Text NodeId)
-> ([NodeId] -> [(Text, NodeId)]) -> [NodeId] -> Map Text NodeId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [NodeId] -> [(Text, NodeId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
enames ([NodeId] -> Map Text NodeId)
-> Dot [NodeId] -> Dot (Map Text NodeId)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> Dot NodeId) -> [Text] -> Dot [NodeId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (String -> Dot NodeId
box (String -> Dot NodeId) -> (Text -> String) -> Text -> Dot NodeId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) [Text]
enames
  -- --------------------------------------------------------------------------
  -- getters for the NodeId based on entity name or the whole entity
  let safeGetEntity :: Map k a -> k -> a
safeGetEntity Map k a
m k
e = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ k -> String
forall a. Show a => a -> String
show k
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" is not an entity!?") (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ Map k a
m Map k a -> k -> Maybe a
forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? k
e
      -- The above call to `error` (1) should never happen, and (2)
      -- even if it does, it will only crash recipe cheatsheet
      -- generation, not the game itself.
      getE :: Text -> NodeId
getE = Map Text NodeId -> Text -> NodeId
forall {k} {a}. (Show k, Ord k) => Map k a -> k -> a
safeGetEntity Map Text NodeId
ebmap
      nid :: Entity -> NodeId
nid = Text -> NodeId
getE (Text -> NodeId) -> (Entity -> Text) -> Entity -> NodeId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Text Entity Text -> Entity -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Entity Text
Lens' Entity Text
entityName
  -- --------------------------------------------------------------------------
  -- Get the starting inventories, entities present in the world and compute
  -- how hard each entity is to get - see 'recipeLevels'.
  let devs :: Set Entity
devs = RecipeGraph -> Set Entity
RG.startingDevices RecipeGraph
graphData
      inv :: Set Entity
inv = RecipeGraph -> Set Entity
RG.startingInventory RecipeGraph
graphData
      worldEntities :: Set Entity
worldEntities = RecipeGraph -> Set Entity
RG.worldEntities RecipeGraph
graphData
      levels :: [Set Entity]
levels = RecipeGraph -> [Set Entity]
RG.levels RecipeGraph
graphData
      recipes :: [Recipe Entity]
recipes = RecipeGraph -> [Recipe Entity]
RG.recipes RecipeGraph
graphData
  -- --------------------------------------------------------------------------
  -- Base inventory
  (NodeId
_bc, ()) <- Dot () -> Dot (NodeId, ())
forall a. Dot a -> Dot (NodeId, a)
Dot.cluster (Dot () -> Dot (NodeId, ())) -> Dot () -> Dot (NodeId, ())
forall a b. (a -> b) -> a -> b
$ do
    (String, String) -> Dot ()
Dot.attribute (String
"style", String
"filled")
    (String, String) -> Dot ()
Dot.attribute (String
"color", String
"lightgrey")
    (Entity -> Dot ()) -> Set Entity -> Dot ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((NodeId
base NodeId -> NodeId -> Dot ()
---<>) (NodeId -> Dot ()) -> (Entity -> NodeId) -> Entity -> Dot ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity -> NodeId
nid) Set Entity
devs
    (Entity -> Dot ()) -> Set Entity -> Dot ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((NodeId
base NodeId -> NodeId -> Dot ()
.->.) (NodeId -> Dot ()) -> (Entity -> NodeId) -> Entity -> Dot ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity -> NodeId
nid) Set Entity
inv
  -- --------------------------------------------------------------------------
  -- World entities
  (NodeId
_wc, ()) <- Dot () -> Dot (NodeId, ())
forall a. Dot a -> Dot (NodeId, a)
Dot.cluster (Dot () -> Dot (NodeId, ())) -> Dot () -> Dot (NodeId, ())
forall a b. (a -> b) -> a -> b
$ do
    (String, String) -> Dot ()
Dot.attribute (String
"style", String
"filled")
    (String, String) -> Dot ()
Dot.attribute (String
"color", String
"forestgreen")
    (Entity -> Dot ()) -> Set Entity -> Dot ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((NodeId -> NodeId -> Dot ()) -> (NodeId, NodeId) -> Dot ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry NodeId -> NodeId -> Dot ()
(Dot..->.) ((NodeId, NodeId) -> Dot ())
-> (Entity -> (NodeId, NodeId)) -> Entity -> Dot ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeId
world,) (NodeId -> (NodeId, NodeId))
-> (Entity -> NodeId) -> Entity -> (NodeId, NodeId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity -> NodeId
nid) Set Entity
worldEntities
  -- --------------------------------------------------------------------------
  let -- put a hidden node above and below entities and connect them by hidden edges
      wrapBelowAbove :: Set Entity -> Dot (NodeId, NodeId)
      wrapBelowAbove :: Set Entity -> Dot (NodeId, NodeId)
wrapBelowAbove Set Entity
ns = do
        NodeId
b <- Dot NodeId
hiddenNode
        NodeId
t <- Dot NodeId
hiddenNode
        let ns' :: [NodeId]
ns' = (Entity -> NodeId) -> [Entity] -> [NodeId]
forall a b. (a -> b) -> [a] -> [b]
map Entity -> NodeId
nid ([Entity] -> [NodeId]) -> [Entity] -> [NodeId]
forall a b. (a -> b) -> a -> b
$ Set Entity -> [Entity]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Entity
ns
        (NodeId -> Dot ()) -> [NodeId] -> Dot ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (NodeId
b NodeId -> NodeId -> Dot ()
.~>.) [NodeId]
ns'
        (NodeId -> Dot ()) -> [NodeId] -> Dot ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (NodeId -> NodeId -> Dot ()
.~>. NodeId
t) [NodeId]
ns'
        (NodeId, NodeId) -> Dot (NodeId, NodeId)
forall a. a -> Dot a
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeId
b, NodeId
t)
      -- put set of entities in nice
      subLevel :: Int -> Set Entity -> Dot (NodeId, NodeId)
      subLevel :: Int -> Set Entity -> Dot (NodeId, NodeId)
subLevel Int
i Set Entity
ns = ((NodeId, (NodeId, NodeId)) -> (NodeId, NodeId))
-> Dot (NodeId, (NodeId, NodeId)) -> Dot (NodeId, NodeId)
forall a b. (a -> b) -> Dot a -> Dot b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (NodeId, (NodeId, NodeId)) -> (NodeId, NodeId)
forall a b. (a, b) -> b
snd (Dot (NodeId, (NodeId, NodeId)) -> Dot (NodeId, NodeId))
-> (Dot (NodeId, NodeId) -> Dot (NodeId, (NodeId, NodeId)))
-> Dot (NodeId, NodeId)
-> Dot (NodeId, NodeId)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dot (NodeId, NodeId) -> Dot (NodeId, (NodeId, NodeId))
forall a. Dot a -> Dot (NodeId, a)
Dot.cluster (Dot (NodeId, NodeId) -> Dot (NodeId, NodeId))
-> Dot (NodeId, NodeId) -> Dot (NodeId, NodeId)
forall a b. (a -> b) -> a -> b
$ do
        (String, String) -> Dot ()
Dot.attribute (String
"style", String
"filled")
        (String, String) -> Dot ()
Dot.attribute (String
"color", String
"khaki")
        (NodeId, NodeId)
bt <- Set Entity -> Dot (NodeId, NodeId)
wrapBelowAbove Set Entity
ns
        (String, String) -> Dot ()
Dot.attribute (String
"rank", String
"sink")
        -- the normal label for cluster would be cover by lines
        NodeId
_bigLabel <-
          [(String, String)] -> Dot NodeId
Dot.node
            [ (String
"shape", String
"plain")
            , (String
"label", String
"Bottom Label")
            , (String
"fontsize", String
"20pt")
            , (String
"label", String
"Level #" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
i)
            ]
        (NodeId, NodeId) -> Dot (NodeId, NodeId)
forall a. a -> Dot a
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeId, NodeId)
bt
  -- --------------------------------------------------------------------------
  -- order entities into clusters based on how "far" they are from
  -- what is available at the start - see 'recipeLevels'.
  (NodeId, NodeId)
bottom <- Set Entity -> Dot (NodeId, NodeId)
wrapBelowAbove Set Entity
worldEntities
  [(NodeId, NodeId)]
ls <- (Int -> Set Entity -> Dot (NodeId, NodeId))
-> [Int] -> [Set Entity] -> Dot [(NodeId, NodeId)]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Int -> Set Entity -> Dot (NodeId, NodeId)
subLevel [Int
1 ..] (Int -> [Set Entity] -> [Set Entity]
forall a. Int -> [a] -> [a]
drop Int
1 [Set Entity]
levels)
  let invisibleLine :: [NodeId] -> [NodeId] -> Dot ()
invisibleLine = (NodeId -> NodeId -> Dot ()) -> [NodeId] -> [NodeId] -> Dot ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ NodeId -> NodeId -> Dot ()
(.~>.)
  [NodeId]
tls <- (Set Entity -> Dot NodeId) -> [Set Entity] -> Dot [NodeId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Dot NodeId -> Set Entity -> Dot NodeId
forall a b. a -> b -> a
const Dot NodeId
hiddenNode) [Set Entity]
levels
  [NodeId]
bls <- (Set Entity -> Dot NodeId) -> [Set Entity] -> Dot [NodeId]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Dot NodeId -> Set Entity -> Dot NodeId
forall a b. a -> b -> a
const Dot NodeId
hiddenNode) [Set Entity]
levels
  [NodeId] -> [NodeId] -> Dot ()
invisibleLine [NodeId]
tls [NodeId]
bls
  [NodeId] -> [NodeId] -> Dot ()
invisibleLine [NodeId]
bls (Int -> [NodeId] -> [NodeId]
forall a. Int -> [a] -> [a]
drop Int
1 [NodeId]
tls)
  let sameBelowAbove :: (NodeId, NodeId) -> (NodeId, NodeId) -> Dot ()
sameBelowAbove (NodeId
b1, NodeId
t1) (NodeId
b2, NodeId
t2) = [NodeId] -> Dot ()
Dot.same [NodeId
b1, NodeId
b2] Dot () -> Dot () -> Dot ()
forall a b. Dot a -> Dot b -> Dot b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [NodeId] -> Dot ()
Dot.same [NodeId
t1, NodeId
t2]
  ((NodeId, NodeId) -> (NodeId, NodeId) -> Dot ())
-> [(NodeId, NodeId)] -> [(NodeId, NodeId)] -> Dot ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (NodeId, NodeId) -> (NodeId, NodeId) -> Dot ()
sameBelowAbove ((NodeId, NodeId)
bottom (NodeId, NodeId) -> [(NodeId, NodeId)] -> [(NodeId, NodeId)]
forall a. a -> [a] -> [a]
: [(NodeId, NodeId)]
ls) ([NodeId] -> [NodeId] -> [(NodeId, NodeId)]
forall a b. [a] -> [b] -> [(a, b)]
zip [NodeId]
bls [NodeId]
tls)
  -- --------------------------------------------------------------------------
  -- add node for the world and draw a line to each entity found in the wild
  -- finally draw recipes
  let eFilter :: Int -> Int -> Bool
eFilter = EdgeFilter -> Int -> Int -> Bool
filterEdge EdgeFilter
ef
      lvl :: Entity -> Int
lvl Entity
e = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (-Int
1) (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ (Set Entity -> Bool) -> [Set Entity] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
List.findIndex (Entity -> Set Entity -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Entity
e) [Set Entity]
levels
      recipeInOut :: Recipe Entity -> [(Entity, Entity)]
recipeInOut Recipe Entity
r = [(Entity
i, Entity
o) | (Int
_, Entity
i) <- Recipe Entity
r Recipe Entity
-> Getting [(Int, Entity)] (Recipe Entity) [(Int, Entity)]
-> [(Int, Entity)]
forall s a. s -> Getting a s a -> a
^. Getting [(Int, Entity)] (Recipe Entity) [(Int, Entity)]
forall e (f :: * -> *).
Functor f =>
(IngredientList e -> f (IngredientList e))
-> Recipe e -> f (Recipe e)
recipeInputs, (Int
_, Entity
o) <- Recipe Entity
r Recipe Entity
-> Getting [(Int, Entity)] (Recipe Entity) [(Int, Entity)]
-> [(Int, Entity)]
forall s a. s -> Getting a s a -> a
^. Getting [(Int, Entity)] (Recipe Entity) [(Int, Entity)]
forall e (f :: * -> *).
Functor f =>
(IngredientList e -> f (IngredientList e))
-> Recipe e -> f (Recipe e)
recipeOutputs, Entity -> Int
lvl Entity
i Int -> Int -> Bool
`eFilter` Entity -> Int
lvl Entity
o]
      recipeReqOut :: Recipe Entity -> [(Entity, Entity)]
recipeReqOut Recipe Entity
r = [(Entity
q, Entity
o) | (Int
_, Entity
q) <- Recipe Entity
r Recipe Entity
-> Getting [(Int, Entity)] (Recipe Entity) [(Int, Entity)]
-> [(Int, Entity)]
forall s a. s -> Getting a s a -> a
^. Getting [(Int, Entity)] (Recipe Entity) [(Int, Entity)]
forall e (f :: * -> *).
Functor f =>
(IngredientList e -> f (IngredientList e))
-> Recipe e -> f (Recipe e)
recipeCatalysts, (Int
_, Entity
o) <- Recipe Entity
r Recipe Entity
-> Getting [(Int, Entity)] (Recipe Entity) [(Int, Entity)]
-> [(Int, Entity)]
forall s a. s -> Getting a s a -> a
^. Getting [(Int, Entity)] (Recipe Entity) [(Int, Entity)]
forall e (f :: * -> *).
Functor f =>
(IngredientList e -> f (IngredientList e))
-> Recipe e -> f (Recipe e)
recipeOutputs, Entity -> Int
lvl Entity
q Int -> Int -> Bool
`eFilter` Entity -> Int
lvl Entity
o]
      recipesToPairs :: (a -> [p Entity Entity]) -> t a -> [p NodeId NodeId]
recipesToPairs a -> [p Entity Entity]
f t a
rs = (Entity -> NodeId) -> p Entity Entity -> p NodeId NodeId
forall (p :: * -> * -> *) a d.
Bifunctor p =>
(a -> d) -> p a a -> p d d
both Entity -> NodeId
nid (p Entity Entity -> p NodeId NodeId)
-> [p Entity Entity] -> [p NodeId NodeId]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [p Entity Entity] -> [p Entity Entity]
forall a. Ord a => [a] -> [a]
nubOrd ((a -> [p Entity Entity]) -> t a -> [p Entity Entity]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [p Entity Entity]
f t a
rs)
  ((NodeId, NodeId) -> Dot ()) -> [(NodeId, NodeId)] -> Dot ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((NodeId -> NodeId -> Dot ()) -> (NodeId, NodeId) -> Dot ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry NodeId -> NodeId -> Dot ()
(.->.)) ((Recipe Entity -> [(Entity, Entity)])
-> [Recipe Entity] -> [(NodeId, NodeId)]
forall {p :: * -> * -> *} {t :: * -> *} {a}.
(Bifunctor p, Ord (p Entity Entity), Foldable t) =>
(a -> [p Entity Entity]) -> t a -> [p NodeId NodeId]
recipesToPairs Recipe Entity -> [(Entity, Entity)]
recipeInOut [Recipe Entity]
recipes)
  ((NodeId, NodeId) -> Dot ()) -> [(NodeId, NodeId)] -> Dot ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((NodeId -> NodeId -> Dot ()) -> (NodeId, NodeId) -> Dot ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry NodeId -> NodeId -> Dot ()
(---<>)) ((Recipe Entity -> [(Entity, Entity)])
-> [Recipe Entity] -> [(NodeId, NodeId)]
forall {p :: * -> * -> *} {t :: * -> *} {a}.
(Bifunctor p, Ord (p Entity Entity), Foldable t) =>
(a -> [p Entity Entity]) -> t a -> [p NodeId NodeId]
recipesToPairs Recipe Entity -> [(Entity, Entity)]
recipeReqOut [Recipe Entity]
recipes)
  -- --------------------------------------------------------------------------
  -- also draw an edge for each entity that "yields" another entity
  let yieldPairs :: [(Text, Text)]
yieldPairs = (Entity -> Maybe (Text, Text)) -> [Entity] -> [(Text, Text)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Entity
e -> (Entity
e Entity -> Getting Text Entity Text -> Text
forall s a. s -> Getting a s a -> a
^. Getting Text Entity Text
Lens' Entity Text
entityName,) (Text -> (Text, Text)) -> Maybe Text -> Maybe (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Entity
e Entity -> Getting (Maybe Text) Entity (Maybe Text) -> Maybe Text
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Text) Entity (Maybe Text)
Lens' Entity (Maybe Text)
entityYields)) ([Entity] -> [(Text, Text)])
-> (Set Entity -> [Entity]) -> Set Entity -> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Entity -> [Entity]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Set Entity -> [(Text, Text)]) -> Set Entity -> [(Text, Text)]
forall a b. (a -> b) -> a -> b
$ RecipeGraph -> Set Entity
RG.allEntities RecipeGraph
graphData
  ((NodeId, NodeId) -> Dot ()) -> [(NodeId, NodeId)] -> Dot ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((NodeId -> NodeId -> Dot ()) -> (NodeId, NodeId) -> Dot ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry NodeId -> NodeId -> Dot ()
(.-<>.)) ((Text -> NodeId) -> (Text, Text) -> (NodeId, NodeId)
forall (p :: * -> * -> *) a d.
Bifunctor p =>
(a -> d) -> p a a -> p d d
both Text -> NodeId
getE ((Text, Text) -> (NodeId, NodeId))
-> [(Text, Text)] -> [(NodeId, NodeId)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Text)]
yieldPairs)

-- ----------------------------------------------------------------------------
-- GRAPHVIZ HELPERS
-- ----------------------------------------------------------------------------

customNode :: [(String, String)] -> String -> Dot NodeId
customNode :: [(String, String)] -> String -> Dot NodeId
customNode [(String, String)]
attrs String
label = [(String, String)] -> Dot NodeId
Dot.node ([(String, String)] -> Dot NodeId)
-> [(String, String)] -> Dot NodeId
forall a b. (a -> b) -> a -> b
$ [(String
"style", String
"filled"), (String
"label", String
label)] [(String, String)] -> [(String, String)] -> [(String, String)]
forall a. Semigroup a => a -> a -> a
<> [(String, String)]
attrs

box, diamond :: String -> Dot NodeId
box :: String -> Dot NodeId
box = [(String, String)] -> String -> Dot NodeId
customNode [(String
"shape", String
"box")]
diamond :: String -> Dot NodeId
diamond = [(String, String)] -> String -> Dot NodeId
customNode [(String
"shape", String
"diamond")]

-- | Hidden node - used for layout.
hiddenNode :: Dot NodeId
hiddenNode :: Dot NodeId
hiddenNode = [(String, String)] -> Dot NodeId
Dot.node [(String
"style", String
"invis")]

-- | Edge for yielded entities.
(.-<>.) :: NodeId -> NodeId -> Dot ()
NodeId
e1 .-<>. :: NodeId -> NodeId -> Dot ()
.-<>. NodeId
e2 = NodeId -> NodeId -> [(String, String)] -> Dot ()
Dot.edge NodeId
e1 NodeId
e2 [(String, String)]
attrs
 where
  attrs :: [(String, String)]
attrs = [(String
"arrowhead", String
"diamond"), (String
"color", String
"purple")]

-- | Hidden edge - used for layout.
(.~>.) :: NodeId -> NodeId -> Dot ()
NodeId
i .~>. :: NodeId -> NodeId -> Dot ()
.~>. NodeId
j = NodeId -> NodeId -> [(String, String)] -> Dot ()
Dot.edge NodeId
i NodeId
j [(String
"style", String
"invis")]

-- | Edge for recipe requirements and outputs.
(---<>) :: NodeId -> NodeId -> Dot ()
NodeId
e1 ---<> :: NodeId -> NodeId -> Dot ()
---<> NodeId
e2 = NodeId -> NodeId -> [(String, String)] -> Dot ()
Dot.edge NodeId
e1 NodeId
e2 [(String, String)]
attrs
 where
  attrs :: [(String, String)]
attrs = [(String
"arrowhead", String
"diamond"), (String
"color", String
"blue")]