{-# 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 data
  RecipeGraphData (..),
  EdgeFilter (..),
  classicScenarioRecipeGraphData,
  ignoredEntities,
) where

import Control.Lens (view, (^.))
import Control.Monad (zipWithM, zipWithM_)
import Data.Containers.ListUtils (nubOrd)
import Data.Foldable (toList)
import Data.List qualified as List
import Data.List.Extra (enumerate)
import Data.Map.Lazy (Map, (!))
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 (Text, unpack)
import Data.Text qualified as T
import Data.Text.IO qualified as T
import Data.Tuple (swap)
import Swarm.Doc.Keyword
import Swarm.Doc.Pedagogy
import Swarm.Doc.Util
import Swarm.Doc.Wiki.Cheatsheet
import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityName, entityYields)
import Swarm.Game.Entity qualified as E
import Swarm.Game.Failure (simpleErrorHandle)
import Swarm.Game.Land
import Swarm.Game.Recipe (Recipe, recipeCatalysts, recipeInputs, recipeOutputs)
import Swarm.Game.Robot (Robot, equippedDevices, robotInventory)
import Swarm.Game.Scenario (GameStateInputs (..), ScenarioInputs (..), loadStandaloneScenario, scenarioLandscape)
import Swarm.Game.World.Gen (extractEntities)
import Swarm.Game.World.Typecheck (Some (..))
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
  -- | 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
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
  RecipeGraphData
graphData <- IO RecipeGraphData
classicScenarioRecipeGraphData
  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
$ RecipeGraphData -> EdgeFilter -> Dot ()
recipesToDot RecipeGraphData
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 :: RecipeGraphData -> EdgeFilter -> Dot ()
recipesToDot :: RecipeGraphData -> EdgeFilter -> Dot ()
recipesToDot RecipeGraphData
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 with 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
$ RecipeGraphData -> Set Entity
rgAllEntities RecipeGraphData
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
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
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
      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 = RecipeGraphData -> Set Entity
rgStartingDevices RecipeGraphData
graphData
      inv :: Set Entity
inv = RecipeGraphData -> Set Entity
rgStartingInventory RecipeGraphData
graphData
      worldEntities :: Set Entity
worldEntities = RecipeGraphData -> Set Entity
rgWorldEntities RecipeGraphData
graphData
      levels :: [Set Entity]
levels = RecipeGraphData -> [Set Entity]
rgLevels RecipeGraphData
graphData
      recipes :: [Recipe Entity]
recipes = RecipeGraphData -> [Recipe Entity]
rgRecipes RecipeGraphData
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
$ RecipeGraphData -> Set Entity
rgAllEntities RecipeGraphData
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)

data RecipeGraphData = RecipeGraphData
  { RecipeGraphData -> Set Entity
rgWorldEntities :: Set Entity
  , RecipeGraphData -> Set Entity
rgStartingDevices :: Set Entity
  , RecipeGraphData -> Set Entity
rgStartingInventory :: Set Entity
  , RecipeGraphData -> [Set Entity]
rgLevels :: [Set Entity]
  , RecipeGraphData -> Set Entity
rgAllEntities :: Set Entity
  , RecipeGraphData -> [Recipe Entity]
rgRecipes :: [Recipe Entity]
  }

classicScenarioRecipeGraphData :: IO RecipeGraphData
classicScenarioRecipeGraphData :: IO RecipeGraphData
classicScenarioRecipeGraphData = ThrowC SystemFailure IO RecipeGraphData -> IO RecipeGraphData
forall a. ThrowC SystemFailure IO a -> IO a
simpleErrorHandle (ThrowC SystemFailure IO RecipeGraphData -> IO RecipeGraphData)
-> ThrowC SystemFailure IO RecipeGraphData -> IO RecipeGraphData
forall a b. (a -> b) -> a -> b
$ do
  (Scenario
classic, GameStateInputs (ScenarioInputs WorldMap
worlds (TerrainEntityMaps TerrainMap
_ EntityMap
emap)) [Recipe Entity]
recipes) <-
    String -> ThrowC SystemFailure IO (Scenario, GameStateInputs)
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
String -> m (Scenario, GameStateInputs)
loadStandaloneScenario String
"data/scenarios/classic.yaml"
  Robot
baseRobot <- ScenarioLandscape -> ThrowC SystemFailure IO Robot
forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw SystemFailure) sig m =>
ScenarioLandscape -> m Robot
instantiateBaseRobot (Scenario
classic Scenario
-> Getting ScenarioLandscape Scenario ScenarioLandscape
-> ScenarioLandscape
forall s a. s -> Getting a s a -> a
^. Getting ScenarioLandscape Scenario ScenarioLandscape
Lens' Scenario ScenarioLandscape
scenarioLandscape)
  let classicTerm :: Some (TTerm '[])
classicTerm = WorldMap
worlds WorldMap -> Text -> Some (TTerm '[])
forall k a. Ord k => Map k a -> k -> a
! Text
"classic"
  let devs :: Set Entity
devs = Robot -> Set Entity
startingDevices Robot
baseRobot
  let inv :: Set Entity
inv = Map Entity Int -> Set Entity
forall k a. Map k a -> Set k
Map.keysSet (Map Entity Int -> Set Entity) -> Map Entity Int -> Set Entity
forall a b. (a -> b) -> a -> b
$ Robot -> Map Entity Int
startingInventory Robot
baseRobot
  let worldEntities :: Set Entity
worldEntities = case Some (TTerm '[])
classicTerm of Some TTy α
_ TTerm '[] α
t -> TTerm '[] α -> Set Entity
forall (g :: [*]) a. TTerm g a -> Set Entity
extractEntities TTerm '[] α
t
  RecipeGraphData -> ThrowC SystemFailure IO RecipeGraphData
forall a. a -> ThrowC SystemFailure IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
    RecipeGraphData
      { rgStartingDevices :: Set Entity
rgStartingDevices = Set Entity
devs
      , rgStartingInventory :: Set Entity
rgStartingInventory = Set Entity
inv
      , rgWorldEntities :: Set Entity
rgWorldEntities = Set Entity
worldEntities
      , rgLevels :: [Set Entity]
rgLevels = EntityMap -> [Recipe Entity] -> Set Entity -> [Set Entity]
recipeLevels EntityMap
emap [Recipe Entity]
recipes ([Set Entity] -> Set Entity
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set Entity
worldEntities, Set Entity
devs, Set Entity
inv])
      , rgAllEntities :: Set Entity
rgAllEntities = [Entity] -> Set Entity
forall a. Ord a => [a] -> Set a
Set.fromList ([Entity] -> Set Entity)
-> (Map Text Entity -> [Entity]) -> Map Text Entity -> Set Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Entity -> [Entity]
forall k a. Map k a -> [a]
Map.elems (Map Text Entity -> Set Entity) -> Map Text Entity -> Set Entity
forall a b. (a -> b) -> a -> b
$ EntityMap -> Map Text Entity
entitiesByName EntityMap
emap
      , rgRecipes :: [Recipe Entity]
rgRecipes = [Recipe Entity]
recipes
      }

-- ----------------------------------------------------------------------------
-- RECIPE LEVELS
-- ----------------------------------------------------------------------------

-- | Order entities in sets depending on how soon it is possible to obtain them.
--
-- So:
--  * Level 0 - starting entities (for example those obtainable in the world)
--  * Level N+1 - everything possible to make (or drill or harvest) from Level N
--
-- This is almost a BFS, but the requirement is that the set of entities
-- required for recipe is subset of the entities known in Level N.
--
-- If we ever depend on some graph library, this could be rewritten
-- as some BFS-like algorithm with added recipe nodes, but you would
-- need to enforce the condition that recipes need ALL incoming edges.
recipeLevels :: EntityMap -> [Recipe Entity] -> Set Entity -> [Set Entity]
recipeLevels :: EntityMap -> [Recipe Entity] -> Set Entity -> [Set Entity]
recipeLevels EntityMap
emap [Recipe Entity]
recipes Set Entity
start = [Set Entity]
levels
 where
  recipeParts :: Recipe e -> (IngredientList e, IngredientList e)
recipeParts Recipe e
r = ((Recipe e
r Recipe e
-> Getting (IngredientList e) (Recipe e) (IngredientList e)
-> IngredientList e
forall s a. s -> Getting a s a -> a
^. Getting (IngredientList e) (Recipe e) (IngredientList e)
forall e (f :: * -> *).
Functor f =>
(IngredientList e -> f (IngredientList e))
-> Recipe e -> f (Recipe e)
recipeInputs) IngredientList e -> IngredientList e -> IngredientList e
forall a. Semigroup a => a -> a -> a
<> (Recipe e
r Recipe e
-> Getting (IngredientList e) (Recipe e) (IngredientList e)
-> IngredientList e
forall s a. s -> Getting a s a -> a
^. Getting (IngredientList e) (Recipe e) (IngredientList e)
forall e (f :: * -> *).
Functor f =>
(IngredientList e -> f (IngredientList e))
-> Recipe e -> f (Recipe e)
recipeCatalysts), Recipe e
r Recipe e
-> Getting (IngredientList e) (Recipe e) (IngredientList e)
-> IngredientList e
forall s a. s -> Getting a s a -> a
^. Getting (IngredientList e) (Recipe e) (IngredientList e)
forall e (f :: * -> *).
Functor f =>
(IngredientList e -> f (IngredientList e))
-> Recipe e -> f (Recipe e)
recipeOutputs)
  m :: [(Set Entity, Set Entity)]
  m :: [(Set Entity, Set Entity)]
m = (Recipe Entity -> (Set Entity, Set Entity))
-> [Recipe Entity] -> [(Set Entity, Set Entity)]
forall a b. (a -> b) -> [a] -> [b]
map (([(Int, Entity)] -> Set Entity)
-> ([(Int, Entity)], [(Int, Entity)]) -> (Set Entity, Set Entity)
forall (p :: * -> * -> *) a d.
Bifunctor p =>
(a -> d) -> p a a -> p d d
both ([Entity] -> Set Entity
forall a. Ord a => [a] -> Set a
Set.fromList ([Entity] -> Set Entity)
-> ([(Int, Entity)] -> [Entity]) -> [(Int, Entity)] -> Set Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Entity) -> Entity) -> [(Int, Entity)] -> [Entity]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Entity) -> Entity
forall a b. (a, b) -> b
snd) (([(Int, Entity)], [(Int, Entity)]) -> (Set Entity, Set Entity))
-> (Recipe Entity -> ([(Int, Entity)], [(Int, Entity)]))
-> Recipe Entity
-> (Set Entity, Set Entity)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Recipe Entity -> ([(Int, Entity)], [(Int, Entity)])
forall {e}. Recipe e -> (IngredientList e, IngredientList e)
recipeParts) [Recipe Entity]
recipes
  levels :: [Set Entity]
  levels :: [Set Entity]
levels = [Set Entity] -> [Set Entity]
forall a. [a] -> [a]
reverse ([Set Entity] -> [Set Entity]) -> [Set Entity] -> [Set Entity]
forall a b. (a -> b) -> a -> b
$ [Set Entity] -> Set Entity -> [Set Entity]
go [Set Entity
start] Set Entity
start
   where
    isKnown :: Set a -> (Set a, b) -> Bool
isKnown Set a
known (Set a
i, b
_o) = Set a -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Set a -> Bool) -> Set a -> Bool
forall a b. (a -> b) -> a -> b
$ Set a
i Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set a
known
    lookupYield :: Entity -> Entity
lookupYield Entity
e = case Getting (Maybe Text) Entity (Maybe Text) -> Entity -> Maybe Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Text) Entity (Maybe Text)
Lens' Entity (Maybe Text)
entityYields Entity
e of
      Maybe Text
Nothing -> Entity
e
      Just Text
yn -> case Text -> EntityMap -> Maybe Entity
E.lookupEntityName Text
yn EntityMap
emap of
        Maybe Entity
Nothing -> String -> Entity
forall a. HasCallStack => String -> a
error String
"unknown yielded entity"
        Just Entity
ye -> Entity
ye
    yielded :: Set Entity -> Set Entity
yielded = (Entity -> Entity) -> Set Entity -> Set Entity
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map Entity -> Entity
lookupYield
    nextLevel :: Set Entity -> Set Entity
nextLevel Set Entity
known = [Set Entity] -> Set Entity
forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions ([Set Entity] -> Set Entity) -> [Set Entity] -> Set Entity
forall a b. (a -> b) -> a -> b
$ Set Entity -> Set Entity
yielded Set Entity
known Set Entity -> [Set Entity] -> [Set Entity]
forall a. a -> [a] -> [a]
: ((Set Entity, Set Entity) -> Set Entity)
-> [(Set Entity, Set Entity)] -> [Set Entity]
forall a b. (a -> b) -> [a] -> [b]
map (Set Entity, Set Entity) -> Set Entity
forall a b. (a, b) -> b
snd (((Set Entity, Set Entity) -> Bool)
-> [(Set Entity, Set Entity)] -> [(Set Entity, Set Entity)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Set Entity -> (Set Entity, Set Entity) -> Bool
forall {a} {b}. Ord a => Set a -> (Set a, b) -> Bool
isKnown Set Entity
known) [(Set Entity, Set Entity)]
m)
    go :: [Set Entity] -> Set Entity -> [Set Entity]
go [Set Entity]
ls Set Entity
known =
      let n :: Set Entity
n = Set Entity -> Set Entity
nextLevel Set Entity
known Set Entity -> Set Entity -> Set Entity
forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set Entity
known
       in if Set Entity -> Bool
forall a. Set a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set Entity
n
            then [Set Entity]
ls
            else [Set Entity] -> Set Entity -> [Set Entity]
go (Set Entity
n Set Entity -> [Set Entity] -> [Set Entity]
forall a. a -> [a] -> [a]
: [Set Entity]
ls) (Set Entity -> Set Entity -> Set Entity
forall a. Ord a => Set a -> Set a -> Set a
Set.union Set Entity
n Set Entity
known)

startingDevices :: Robot -> Set Entity
startingDevices :: Robot -> Set Entity
startingDevices = [Entity] -> Set Entity
forall a. Ord a => [a] -> Set a
Set.fromList ([Entity] -> Set Entity)
-> (Robot -> [Entity]) -> Robot -> Set Entity
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Entity) -> Entity) -> [(Int, Entity)] -> [Entity]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Entity) -> Entity
forall a b. (a, b) -> b
snd ([(Int, Entity)] -> [Entity])
-> (Robot -> [(Int, Entity)]) -> Robot -> [Entity]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inventory -> [(Int, Entity)]
E.elems (Inventory -> [(Int, Entity)])
-> (Robot -> Inventory) -> Robot -> [(Int, Entity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Inventory Robot Inventory -> Robot -> Inventory
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Inventory Robot Inventory
Lens' Robot Inventory
equippedDevices

startingInventory :: Robot -> Map Entity Int
startingInventory :: Robot -> Map Entity Int
startingInventory = [(Entity, Int)] -> Map Entity Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Entity, Int)] -> Map Entity Int)
-> (Robot -> [(Entity, Int)]) -> Robot -> Map Entity Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Entity) -> (Entity, Int))
-> [(Int, Entity)] -> [(Entity, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Entity) -> (Entity, Int)
forall a b. (a, b) -> (b, a)
swap ([(Int, Entity)] -> [(Entity, Int)])
-> (Robot -> [(Int, Entity)]) -> Robot -> [(Entity, Int)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inventory -> [(Int, Entity)]
E.elems (Inventory -> [(Int, Entity)])
-> (Robot -> Inventory) -> Robot -> [(Int, Entity)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Inventory Robot Inventory -> Robot -> Inventory
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Inventory Robot Inventory
Lens' Robot Inventory
robotInventory

-- | Ignore utility entities that are just used for tutorials and challenges.
ignoredEntities :: Set Text
ignoredEntities :: Set Text
ignoredEntities =
  [Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList
    [ Text
"upper left corner"
    , Text
"upper right corner"
    , Text
"lower left corner"
    , Text
"lower right corner"
    , Text
"horizontal wall"
    , Text
"vertical wall"
    , Text
"left and vertical wall"
    , Text
"up and horizontal wall"
    , Text
"right and vertical wall"
    , Text
"down and horizontal wall"
    ]

-- ----------------------------------------------------------------------------
-- 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")]