{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

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

  -- ** Formatted keyword lists
  keywordsCommands,
  keywordsDirections,
  operatorNames,
  builtinFunctionList,

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

import Control.Effect.Lift
import Control.Effect.Throw (Throw, throwError)
import Control.Lens (view, (^.))
import Control.Lens.Combinators (to)
import Control.Monad (zipWithM, zipWithM_)
import Data.Containers.ListUtils (nubOrd)
import Data.Foldable (find, toList)
import Data.List (transpose)
import Data.Map.Lazy (Map, (!))
import Data.Map.Lazy qualified as Map
import Data.Maybe (fromMaybe, isJust, listToMaybe)
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.Pedagogy
import Swarm.Doc.Schema.Render
import Swarm.Doc.Util
import Swarm.Game.Display (displayChar)
import Swarm.Game.Entity (Entity, EntityMap (entitiesByName), entityDisplay, entityName, loadEntities)
import Swarm.Game.Entity qualified as E
import Swarm.Game.Failure (SystemFailure (CustomFailure))
import Swarm.Game.Recipe (Recipe, loadRecipes, recipeCatalysts, recipeInputs, recipeOutputs, recipeTime, recipeWeight)
import Swarm.Game.Robot (Robot, equippedDevices, instantiateRobot, robotInventory)
import Swarm.Game.Scenario (Scenario, loadStandaloneScenario, scenarioRobots)
import Swarm.Game.World.Gen (extractEntities)
import Swarm.Game.World.Typecheck (Some (..), TTerm)
import Swarm.Language.Capability (Capability)
import Swarm.Language.Capability qualified as Capability
import Swarm.Language.Key (specialKeyNames)
import Swarm.Language.Pretty (prettyText)
import Swarm.Language.Syntax (Const (..))
import Swarm.Language.Syntax qualified as Syntax
import Swarm.Language.Text.Markdown as Markdown (docToMark)
import Swarm.Language.Typecheck (inferConst)
import Swarm.Util (both, listEnums, quote)
import Swarm.Util.Effect (simpleErrorHandle)
import Swarm.Web (swarmApiMarkdown)
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 :: 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 -> Maybe SheetType -> GenerateDocs
  -- | List command introductions by tutorial
  TutorialCoverage :: GenerateDocs
  -- | Web API endpoints
  WebAPIEndpoints :: GenerateDocs
  deriving (GenerateDocs -> GenerateDocs -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GenerateDocs -> GenerateDocs -> Bool
$c/= :: GenerateDocs -> GenerateDocs -> Bool
== :: GenerateDocs -> GenerateDocs -> Bool
$c== :: GenerateDocs -> GenerateDocs -> Bool
Eq, Int -> GenerateDocs -> ShowS
[GenerateDocs] -> ShowS
GenerateDocs -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GenerateDocs] -> ShowS
$cshowList :: [GenerateDocs] -> ShowS
show :: GenerateDocs -> String
$cshow :: GenerateDocs -> String
showsPrec :: Int -> GenerateDocs -> ShowS
$cshowsPrec :: Int -> GenerateDocs -> ShowS
Show)

-- | An enumeration of the editors supported by Swarm (currently,
--   Emacs and VS Code).
data EditorType = Emacs | VSCode | Vim
  deriving (EditorType -> EditorType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EditorType -> EditorType -> Bool
$c/= :: EditorType -> EditorType -> Bool
== :: EditorType -> EditorType -> Bool
$c== :: EditorType -> EditorType -> Bool
Eq, Int -> EditorType -> ShowS
[EditorType] -> ShowS
EditorType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EditorType] -> ShowS
$cshowList :: [EditorType] -> ShowS
show :: EditorType -> String
$cshow :: EditorType -> String
showsPrec :: Int -> EditorType -> ShowS
$cshowsPrec :: Int -> EditorType -> ShowS
Show, Int -> EditorType
EditorType -> Int
EditorType -> [EditorType]
EditorType -> EditorType
EditorType -> EditorType -> [EditorType]
EditorType -> EditorType -> EditorType -> [EditorType]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: EditorType -> EditorType -> EditorType -> [EditorType]
$cenumFromThenTo :: EditorType -> EditorType -> EditorType -> [EditorType]
enumFromTo :: EditorType -> EditorType -> [EditorType]
$cenumFromTo :: EditorType -> EditorType -> [EditorType]
enumFromThen :: EditorType -> EditorType -> [EditorType]
$cenumFromThen :: EditorType -> EditorType -> [EditorType]
enumFrom :: EditorType -> [EditorType]
$cenumFrom :: EditorType -> [EditorType]
fromEnum :: EditorType -> Int
$cfromEnum :: EditorType -> Int
toEnum :: Int -> EditorType
$ctoEnum :: Int -> EditorType
pred :: EditorType -> EditorType
$cpred :: EditorType -> EditorType
succ :: EditorType -> EditorType
$csucc :: EditorType -> EditorType
Enum, EditorType
forall a. a -> a -> Bounded a
maxBound :: EditorType
$cmaxBound :: EditorType
minBound :: EditorType
$cminBound :: EditorType
Bounded)

-- | An enumeration of the kinds of cheat sheets we can produce.
data SheetType = Entities | Commands | Capabilities | Recipes | Scenario
  deriving (SheetType -> SheetType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SheetType -> SheetType -> Bool
$c/= :: SheetType -> SheetType -> Bool
== :: SheetType -> SheetType -> Bool
$c== :: SheetType -> SheetType -> Bool
Eq, Int -> SheetType -> ShowS
[SheetType] -> ShowS
SheetType -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SheetType] -> ShowS
$cshowList :: [SheetType] -> ShowS
show :: SheetType -> String
$cshow :: SheetType -> String
showsPrec :: Int -> SheetType -> ShowS
$cshowsPrec :: Int -> SheetType -> ShowS
Show, Int -> SheetType
SheetType -> Int
SheetType -> [SheetType]
SheetType -> SheetType
SheetType -> SheetType -> [SheetType]
SheetType -> SheetType -> SheetType -> [SheetType]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: SheetType -> SheetType -> SheetType -> [SheetType]
$cenumFromThenTo :: SheetType -> SheetType -> SheetType -> [SheetType]
enumFromTo :: SheetType -> SheetType -> [SheetType]
$cenumFromTo :: SheetType -> SheetType -> [SheetType]
enumFromThen :: SheetType -> SheetType -> [SheetType]
$cenumFromThen :: SheetType -> SheetType -> [SheetType]
enumFrom :: SheetType -> [SheetType]
$cenumFrom :: SheetType -> [SheetType]
fromEnum :: SheetType -> Int
$cfromEnum :: SheetType -> Int
toEnum :: Int -> SheetType
$ctoEnum :: Int -> SheetType
pred :: SheetType -> SheetType
$cpred :: SheetType -> SheetType
succ :: SheetType -> SheetType
$csucc :: SheetType -> SheetType
Enum, SheetType
forall a. a -> a -> Bounded a
maxBound :: SheetType
$cmaxBound :: SheetType
minBound :: SheetType
$cminBound :: SheetType
Bounded)

-- | A configuration record holding the URLs of the various cheat
--   sheets, to facilitate cross-linking.
data PageAddress = PageAddress
  { PageAddress -> Text
entityAddress :: Text
  , PageAddress -> Text
commandsAddress :: Text
  , PageAddress -> Text
capabilityAddress :: Text
  , PageAddress -> Text
recipesAddress :: Text
  }
  deriving (PageAddress -> PageAddress -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PageAddress -> PageAddress -> Bool
$c/= :: PageAddress -> PageAddress -> Bool
== :: PageAddress -> PageAddress -> Bool
$c== :: PageAddress -> PageAddress -> Bool
Eq, Int -> PageAddress -> ShowS
[PageAddress] -> ShowS
PageAddress -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PageAddress] -> ShowS
$cshowList :: [PageAddress] -> ShowS
show :: PageAddress -> String
$cshow :: PageAddress -> String
showsPrec :: Int -> PageAddress -> ShowS
$cshowsPrec :: Int -> PageAddress -> ShowS
Show)

-- | Generate the requested kind of documentation to stdout.
generateDocs :: GenerateDocs -> IO ()
generateDocs :: GenerateDocs -> IO ()
generateDocs = \case
  GenerateDocs
RecipeGraph -> IO String
generateRecipe 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 forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
40 Char
'-'
              String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ String
"-- " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show EditorType
et
              String -> IO ()
putStrLn forall a b. (a -> b) -> a -> b
$ forall a. Int -> a -> [a]
replicate Int
40 Char
'-'
              EditorType -> IO ()
generateEditorKeywords EditorType
et
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ EditorType -> IO ()
editorGen forall e. (Enum e, Bounded e) => [e]
listEnums
  GenerateDocs
SpecialKeyNames -> IO ()
generateSpecialKeyNames
  CheatSheet PageAddress
address Maybe SheetType
s -> case Maybe SheetType
s of
    Maybe SheetType
Nothing -> forall a. HasCallStack => String -> a
error String
"Not implemented for all Wikis"
    Just SheetType
st -> case SheetType
st of
      SheetType
Commands -> Text -> IO ()
T.putStrLn Text
commandsPage
      SheetType
Capabilities -> forall a. ThrowC SystemFailure IO a -> IO a
simpleErrorHandle forall a b. (a -> b) -> a -> b
$ do
        EntityMap
entities <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
m EntityMap
loadEntities
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ PageAddress -> EntityMap -> Text
capabilityPage PageAddress
address EntityMap
entities
      SheetType
Entities -> forall a. ThrowC SystemFailure IO a -> IO a
simpleErrorHandle forall a b. (a -> b) -> a -> b
$ do
        EntityMap
entities <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
m EntityMap
loadEntities
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ PageAddress -> [Entity] -> Text
entitiesPage PageAddress
address (forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ EntityMap -> Map Text Entity
entitiesByName EntityMap
entities)
      SheetType
Recipes -> forall a. ThrowC SystemFailure IO a -> IO a
simpleErrorHandle forall a b. (a -> b) -> a -> b
$ do
        EntityMap
entities <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
m EntityMap
loadEntities
        [Recipe Entity]
recipes <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
EntityMap -> m [Recipe Entity]
loadRecipes EntityMap
entities
        forall (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Lift IO) sig m =>
IO a -> m a
sendIO forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ PageAddress -> [Recipe Entity] -> Text
recipePage PageAddress
address [Recipe Entity]
recipes
      SheetType
Scenario -> IO ()
genScenarioSchemaDocs
  GenerateDocs
TutorialCoverage -> IO Text
renderTutorialProgression forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> IO ()
putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
  GenerateDocs
WebAPIEndpoints -> String -> IO ()
putStrLn String
swarmApiMarkdown

-- ----------------------------------------------------------------------------
-- 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
"(x-builtins '("
    Text -> IO ()
T.putStr forall a b. (a -> b) -> a -> b
$ EditorType -> Text
builtinFunctionList EditorType
Emacs
    String -> IO ()
putStrLn String
"))\n(x-commands '("
    Text -> IO ()
T.putStr forall a b. (a -> b) -> a -> b
$ EditorType -> Text
keywordsCommands EditorType
Emacs
    Text -> IO ()
T.putStr forall a b. (a -> b) -> a -> b
$ EditorType -> Text
keywordsDirections EditorType
Emacs
    String -> IO ()
putStrLn String
"))"
  EditorType
VSCode -> do
    String -> IO ()
putStrLn String
"Functions and commands:"
    Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ EditorType -> Text
builtinFunctionList EditorType
VSCode forall a. Semigroup a => a -> a -> a
<> Text
"|" forall a. Semigroup a => a -> a -> a
<> EditorType -> Text
keywordsCommands EditorType
VSCode
    String -> IO ()
putStrLn String
"\nDirections:"
    Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ EditorType -> Text
keywordsDirections EditorType
VSCode
    String -> IO ()
putStrLn String
"\nOperators:"
    Text -> IO ()
T.putStrLn Text
operatorNames
  EditorType
Vim -> do
    String -> IO ()
putStr String
"syn keyword Builtins "
    Text -> IO ()
T.putStr forall a b. (a -> b) -> a -> b
$ EditorType -> Text
builtinFunctionList EditorType
Vim
    String -> IO ()
putStr String
"\nsyn keyword Command "
    Text -> IO ()
T.putStr forall a b. (a -> b) -> a -> b
$ EditorType -> Text
keywordsCommands EditorType
Vim
    String -> IO ()
putStr String
"\nsyn keyword Direction "
    Text -> IO ()
T.putStrLn forall a b. (a -> b) -> a -> b
$ EditorType -> Text
keywordsDirections EditorType
Vim

commands :: [Const]
commands :: [Const]
commands = forall a. (a -> Bool) -> [a] -> [a]
filter Const -> Bool
Syntax.isCmd [Const]
Syntax.allConst

operators :: [Const]
operators :: [Const]
operators = forall a. (a -> Bool) -> [a] -> [a]
filter Const -> Bool
Syntax.isOperator [Const]
Syntax.allConst

builtinFunctions :: [Const]
builtinFunctions :: [Const]
builtinFunctions = forall a. (a -> Bool) -> [a] -> [a]
filter Const -> Bool
Syntax.isBuiltinFunction [Const]
Syntax.allConst

builtinFunctionList :: EditorType -> Text
builtinFunctionList :: EditorType -> Text
builtinFunctionList EditorType
e = EditorType -> [Text] -> Text
editorList EditorType
e forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Const -> Text
constSyntax [Const]
builtinFunctions

editorList :: EditorType -> [Text] -> Text
editorList :: EditorType -> [Text] -> Text
editorList = \case
  EditorType
Emacs -> [Text] -> Text
T.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((Text
"  " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
quote)
  EditorType
VSCode -> Text -> [Text] -> Text
T.intercalate Text
"|"
  EditorType
Vim -> Text -> [Text] -> Text
T.intercalate Text
" "

constSyntax :: Const -> Text
constSyntax :: Const -> Text
constSyntax = ConstInfo -> Text
Syntax.syntax forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const -> ConstInfo
Syntax.constInfo

-- | Get formatted list of basic functions/commands.
keywordsCommands :: EditorType -> Text
keywordsCommands :: EditorType -> Text
keywordsCommands EditorType
e = EditorType -> [Text] -> Text
editorList EditorType
e forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Const -> Text
constSyntax [Const]
commands

-- | Get formatted list of directions.
keywordsDirections :: EditorType -> Text
keywordsDirections :: EditorType -> Text
keywordsDirections EditorType
e = EditorType -> [Text] -> Text
editorList EditorType
e forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Direction -> Text
Syntax.directionSyntax [Direction]
Syntax.allDirs

-- | A list of the names of all the operators in the language.
operatorNames :: Text
operatorNames :: Text
operatorNames = Text -> [Text] -> Text
T.intercalate Text
"|" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
escape forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const -> Text
constSyntax) [Const]
operators
 where
  special :: String
  special :: String
special = String
"*+$[]|^"
  slashNotComment :: Char -> Text
slashNotComment = \case
    Char
'/' -> Text
"/(?![/|*])"
    Char
c -> Char -> Text
T.singleton Char
c
  escape :: Text -> Text
escape = (Char -> Text) -> Text -> Text
T.concatMap (\Char
c -> if Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
special then Text -> Char -> Text
T.snoc Text
"\\\\" Char
c else Char -> Text
slashNotComment Char
c)

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

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

-- ----------------------------------------------------------------------------
-- GENERATE TABLES: COMMANDS, ENTITIES AND CAPABILITIES TO MARKDOWN TABLE
-- ----------------------------------------------------------------------------

escapeTable :: Text -> Text
escapeTable :: Text -> Text
escapeTable = (Char -> Text) -> Text -> Text
T.concatMap (\Char
c -> if Char
c forall a. Eq a => a -> a -> Bool
== Char
'|' then Text -> Char -> Text
T.snoc Text
"\\" Char
c else Char -> Text
T.singleton Char
c)

separatingLine :: [Int] -> Text
separatingLine :: [Int] -> Text
separatingLine [Int]
ws = Char -> Text -> Text
T.cons Char
'|' forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.concat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Char -> Text
T.snoc Char
'|' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip Int -> Text -> Text
T.replicate Text
"-" forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
2 forall a. Num a => a -> a -> a
+)) [Int]
ws

listToRow :: [Int] -> [Text] -> Text
listToRow :: [Int] -> [Text] -> Text
listToRow [Int]
mw [Text]
xs = Char -> Text -> Text
wrap Char
'|' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
"|" forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Int -> Text -> Text
format [Int]
mw [Text]
xs
 where
  format :: Int -> Text -> Text
format Int
w Text
x = Char -> Text -> Text
wrap Char
' ' Text
x forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.replicate (Int
w forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
x) Text
" "

maxWidths :: [[Text]] -> [Int]
maxWidths :: [[Text]] -> [Int]
maxWidths = forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Text -> Int
T.length) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [[a]] -> [[a]]
transpose

-- ---------
-- COMMANDS
-- ---------

commandHeader :: [Text]
commandHeader :: [Text]
commandHeader = [Text
"Syntax", Text
"Type", Text
"Capability", Text
"Description"]

commandToList :: Const -> [Text]
commandToList :: Const -> [Text]
commandToList Const
c =
  forall a b. (a -> b) -> [a] -> [b]
map
    Text -> Text
escapeTable
    [ Text -> Text -> Text
addLink (Text
"#" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Const
c) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
codeQuote forall a b. (a -> b) -> a -> b
$ Const -> Text
constSyntax Const
c
    , Text -> Text
codeQuote forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PrettyPrec a => a -> Text
prettyText forall a b. (a -> b) -> a -> b
$ Const -> Polytype
inferConst Const
c
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Capability -> Text
Capability.capabilityName forall a b. (a -> b) -> a -> b
$ Const -> Maybe Capability
Capability.constCaps Const
c
    , ConstDoc -> Text
Syntax.briefDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstInfo -> ConstDoc
Syntax.constDoc forall a b. (a -> b) -> a -> b
$ Const -> ConstInfo
Syntax.constInfo Const
c
    ]

constTable :: [Const] -> Text
constTable :: [Const] -> Text
constTable [Const]
cs = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ [Text]
header forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> [Text] -> Text
listToRow [Int]
mw) [[Text]]
commandRows
 where
  mw :: [Int]
mw = [[Text]] -> [Int]
maxWidths ([Text]
commandHeader forall a. a -> [a] -> [a]
: [[Text]]
commandRows)
  commandRows :: [[Text]]
commandRows = forall a b. (a -> b) -> [a] -> [b]
map Const -> [Text]
commandToList [Const]
cs
  header :: [Text]
header = [[Int] -> [Text] -> Text
listToRow [Int]
mw [Text]
commandHeader, [Int] -> Text
separatingLine [Int]
mw]

commandToSection :: Const -> Text
commandToSection :: Const -> Text
commandToSection Const
c =
  [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$
    [ Text
"## " forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (forall a. Show a => a -> String
show Const
c)
    , Text
""
    , Text
"- syntax: " forall a. Semigroup a => a -> a -> a
<> Text -> Text
codeQuote (Const -> Text
constSyntax Const
c)
    , Text
"- type: " forall a. Semigroup a => a -> a -> a
<> (Text -> Text
codeQuote forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PrettyPrec a => a -> Text
prettyText forall a b. (a -> b) -> a -> b
$ Const -> Polytype
inferConst Const
c)
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((Text
"- required capabilities: " forall a. Semigroup a => a -> a -> a
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Capability -> Text
Capability.capabilityName) forall a b. (a -> b) -> a -> b
$ Const -> Maybe Capability
Capability.constCaps Const
c
    , Text
""
    , ConstDoc -> Text
Syntax.briefDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstInfo -> ConstDoc
Syntax.constDoc forall a b. (a -> b) -> a -> b
$ Const -> ConstInfo
Syntax.constInfo Const
c
    ]
      forall a. Semigroup a => a -> a -> a
<> let l :: Text
l = ConstDoc -> Text
Syntax.longDoc forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConstInfo -> ConstDoc
Syntax.constDoc forall a b. (a -> b) -> a -> b
$ Const -> ConstInfo
Syntax.constInfo Const
c
          in if Text -> Bool
T.null Text
l then [] else [Text
"", Text
l]

commandsPage :: Text
commandsPage :: Text
commandsPage =
  Text -> [Text] -> Text
T.intercalate Text
"\n\n" forall a b. (a -> b) -> a -> b
$
    [ Text
"# Commands"
    , [Const] -> Text
constTable [Const]
commands
    , Text
"# Builtin functions"
    , Text
"These functions are evaluated immediately once they have enough arguments."
    , [Const] -> Text
constTable [Const]
builtinFunctions
    , Text
"# Operators"
    , [Const] -> Text
constTable [Const]
operators
    , Text
"# Detailed descriptions"
    ]
      forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map Const -> Text
commandToSection ([Const]
commands forall a. Semigroup a => a -> a -> a
<> [Const]
builtinFunctions forall a. Semigroup a => a -> a -> a
<> [Const]
operators)

-- -------------
-- CAPABILITIES
-- -------------

capabilityHeader :: [Text]
capabilityHeader :: [Text]
capabilityHeader = [Text
"Name", Text
"Commands", Text
"Entities"]

capabilityRow :: PageAddress -> EntityMap -> Capability -> [Text]
capabilityRow :: PageAddress -> EntityMap -> Capability -> [Text]
capabilityRow PageAddress {Text
recipesAddress :: Text
capabilityAddress :: Text
commandsAddress :: Text
entityAddress :: Text
recipesAddress :: PageAddress -> Text
capabilityAddress :: PageAddress -> Text
commandsAddress :: PageAddress -> Text
entityAddress :: PageAddress -> Text
..} EntityMap
em Capability
cap =
  forall a b. (a -> b) -> [a] -> [b]
map
    Text -> Text
escapeTable
    [ Capability -> Text
Capability.capabilityName Capability
cap
    , Text -> [Text] -> Text
T.intercalate Text
", " (Const -> Text
linkCommand forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Const]
cs)
    , Text -> [Text] -> Text
T.intercalate Text
", " (Text -> Text
linkEntity forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity Text
entityName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Entity]
es)
    ]
 where
  linkEntity :: Text -> Text
linkEntity Text
t =
    if Text -> Bool
T.null Text
entityAddress
      then Text
t
      else Text -> Text -> Text
addLink (Text
entityAddress forall a. Semigroup a => a -> a -> a
<> Text
"#" forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text -> Text
T.replace Text
" " Text
"-" Text
t) Text
t
  linkCommand :: Const -> Text
linkCommand Const
c =
    ( if Text -> Bool
T.null Text
commandsAddress
        then forall a. a -> a
id
        else Text -> Text -> Text
addLink (Text
commandsAddress forall a. Semigroup a => a -> a -> a
<> Text
"#" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Const
c)
    )
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
codeQuote
      forall a b. (a -> b) -> a -> b
$ Const -> Text
constSyntax Const
c

  cs :: [Const]
cs = [Const
c | Const
c <- [Const]
Syntax.allConst, let mcap :: Maybe Capability
mcap = Const -> Maybe Capability
Capability.constCaps Const
c, forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (forall a. Eq a => a -> a -> Bool
== Capability
cap) Maybe Capability
mcap]
  es :: [Entity]
es = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ EntityMap -> Map Capability [Entity]
E.entitiesByCap EntityMap
em forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? Capability
cap

capabilityTable :: PageAddress -> EntityMap -> [Capability] -> Text
capabilityTable :: PageAddress -> EntityMap -> [Capability] -> Text
capabilityTable PageAddress
a EntityMap
em [Capability]
cs = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ [Text]
header forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> [Text] -> Text
listToRow [Int]
mw) [[Text]]
capabilityRows
 where
  mw :: [Int]
mw = [[Text]] -> [Int]
maxWidths ([Text]
capabilityHeader forall a. a -> [a] -> [a]
: [[Text]]
capabilityRows)
  capabilityRows :: [[Text]]
capabilityRows = forall a b. (a -> b) -> [a] -> [b]
map (PageAddress -> EntityMap -> Capability -> [Text]
capabilityRow PageAddress
a EntityMap
em) [Capability]
cs
  header :: [Text]
header = [[Int] -> [Text] -> Text
listToRow [Int]
mw [Text]
capabilityHeader, [Int] -> Text
separatingLine [Int]
mw]

capabilityPage :: PageAddress -> EntityMap -> Text
capabilityPage :: PageAddress -> EntityMap -> Text
capabilityPage PageAddress
a EntityMap
em = PageAddress -> EntityMap -> [Capability] -> Text
capabilityTable PageAddress
a EntityMap
em forall e. (Enum e, Bounded e) => [e]
listEnums

-- ---------
-- Entities
-- ---------

entityHeader :: [Text]
entityHeader :: [Text]
entityHeader = [Text
"?", Text
"Name", Text
"Capabilities", Text
"Properties*", Text
"Portable"]

entityToList :: Entity -> [Text]
entityToList :: Entity -> [Text]
entityToList Entity
e =
  forall a b. (a -> b) -> [a] -> [b]
map
    Text -> Text
escapeTable
    [ Text -> Text
codeQuote forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton forall a b. (a -> b) -> a -> b
$ Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Display
entityDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Display -> Char
displayChar
    , Text -> Text -> Text
addLink (Text
"#" forall a. Semigroup a => a -> a -> a
<> Text
linkID) forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity Text
entityName Entity
e
    , Text -> [Text] -> Text
T.intercalate Text
", " forall a b. (a -> b) -> a -> b
$ Capability -> Text
Capability.capabilityName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity (Set Capability)
E.entityCapabilities Entity
e)
    , Text -> [Text] -> Text
T.intercalate Text
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Text
tshow forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= EntityProperty
E.Portable) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set EntityProperty
props
    , if EntityProperty
E.Portable forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Set EntityProperty
props
        then Text
":heavy_check_mark:"
        else Text
":negative_squared_cross_mark:"
    ]
 where
  props :: Set EntityProperty
props = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity (Set EntityProperty)
E.entityProperties Entity
e
  linkID :: Text
linkID = Text -> Text -> Text -> Text
T.replace Text
" " Text
"-" forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity Text
entityName Entity
e

entityTable :: [Entity] -> Text
entityTable :: [Entity] -> Text
entityTable [Entity]
es = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ [Text]
header forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> [Text] -> Text
listToRow [Int]
mw) [[Text]]
entityRows
 where
  mw :: [Int]
mw = [[Text]] -> [Int]
maxWidths ([Text]
entityHeader forall a. a -> [a] -> [a]
: [[Text]]
entityRows)
  entityRows :: [[Text]]
entityRows = forall a b. (a -> b) -> [a] -> [b]
map Entity -> [Text]
entityToList [Entity]
es
  header :: [Text]
header = [[Int] -> [Text] -> Text
listToRow [Int]
mw [Text]
entityHeader, [Int] -> Text
separatingLine [Int]
mw]

entityToSection :: Entity -> Text
entityToSection :: Entity -> Text
entityToSection Entity
e =
  [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$
    [ Text
"## " forall a. Semigroup a => a -> a -> a
<> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity Text
E.entityName Entity
e
    , Text
""
    , Text
" - Char: " forall a. Semigroup a => a -> a -> a
<> (Text -> Text
codeQuote forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
T.singleton forall a b. (a -> b) -> a -> b
$ Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Display
entityDisplay forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Display -> Char
displayChar)
    ]
      forall a. Semigroup a => a -> a -> a
<> [Text
" - Properties: " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> Text
tshow forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set EntityProperty
props) | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null Set EntityProperty
props]
      forall a. Semigroup a => a -> a -> a
<> [Text
" - Capabilities: " forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
", " (Capability -> Text
Capability.capabilityName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Capability]
caps) | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Capability]
caps]
      forall a. Semigroup a => a -> a -> a
<> [Text
"\n"]
      forall a. Semigroup a => a -> a -> a
<> [forall a. PrettyPrec a => Document a -> Text
Markdown.docToMark forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity (Document Syntax)
E.entityDescription Entity
e]
 where
  props :: Set EntityProperty
props = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity (Set EntityProperty)
E.entityProperties Entity
e
  caps :: [Capability]
caps = forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity (Set Capability)
E.entityCapabilities Entity
e

entitiesPage :: PageAddress -> [Entity] -> Text
entitiesPage :: PageAddress -> [Entity] -> Text
entitiesPage PageAddress
_a [Entity]
es =
  Text -> [Text] -> Text
T.intercalate Text
"\n\n" forall a b. (a -> b) -> a -> b
$
    [ Text
"# Entities"
    , Text
"This is a quick-overview table of entities - click the name for detailed description."
    , Text
"*) As a note, most entities have the Portable property, so we show it in a separate column."
    , [Entity] -> Text
entityTable [Entity]
es
    ]
      forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map Entity -> Text
entityToSection [Entity]
es

-- -------------
-- RECIPES
-- -------------

recipeHeader :: [Text]
recipeHeader :: [Text]
recipeHeader = [Text
"In", Text
"Out", Text
"Required", Text
"Time", Text
"Weight"]

recipeRow :: PageAddress -> Recipe Entity -> [Text]
recipeRow :: PageAddress -> Recipe Entity -> [Text]
recipeRow PageAddress {Text
recipesAddress :: Text
capabilityAddress :: Text
commandsAddress :: Text
entityAddress :: Text
recipesAddress :: PageAddress -> Text
capabilityAddress :: PageAddress -> Text
commandsAddress :: PageAddress -> Text
entityAddress :: PageAddress -> Text
..} Recipe Entity
r =
  forall a b. (a -> b) -> [a] -> [b]
map
    Text -> Text
escapeTable
    [ Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Show a => (a, Entity) -> Text
formatCE forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall e. Lens' (Recipe e) (IngredientList e)
recipeInputs Recipe Entity
r)
    , Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Show a => (a, Entity) -> Text
formatCE forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall e. Lens' (Recipe e) (IngredientList e)
recipeOutputs Recipe Entity
r)
    , Text -> [Text] -> Text
T.intercalate Text
", " (forall a b. (a -> b) -> [a] -> [b]
map forall {a}. Show a => (a, Entity) -> Text
formatCE forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall e. Lens' (Recipe e) (IngredientList e)
recipeCatalysts Recipe Entity
r)
    , forall a. Show a => a -> Text
tshow forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall e. Lens' (Recipe e) Integer
recipeTime Recipe Entity
r
    , forall a. Show a => a -> Text
tshow forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall e. Lens' (Recipe e) Integer
recipeWeight Recipe Entity
r
    ]
 where
  formatCE :: (a, Entity) -> Text
formatCE (a
c, Entity
e) = [Text] -> Text
T.unwords [forall a. Show a => a -> Text
tshow a
c, Text -> Text
linkEntity forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity Text
entityName Entity
e]
  linkEntity :: Text -> Text
linkEntity Text
t =
    if Text -> Bool
T.null Text
entityAddress
      then Text
t
      else Text -> Text -> Text
addLink (Text
entityAddress forall a. Semigroup a => a -> a -> a
<> Text
"#" forall a. Semigroup a => a -> a -> a
<> Text -> Text -> Text -> Text
T.replace Text
" " Text
"-" Text
t) Text
t

recipeTable :: PageAddress -> [Recipe Entity] -> Text
recipeTable :: PageAddress -> [Recipe Entity] -> Text
recipeTable PageAddress
a [Recipe Entity]
rs = [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$ [Text]
header forall a. Semigroup a => a -> a -> a
<> forall a b. (a -> b) -> [a] -> [b]
map ([Int] -> [Text] -> Text
listToRow [Int]
mw) [[Text]]
recipeRows
 where
  mw :: [Int]
mw = [[Text]] -> [Int]
maxWidths ([Text]
recipeHeader forall a. a -> [a] -> [a]
: [[Text]]
recipeRows)
  recipeRows :: [[Text]]
recipeRows = forall a b. (a -> b) -> [a] -> [b]
map (PageAddress -> Recipe Entity -> [Text]
recipeRow PageAddress
a) [Recipe Entity]
rs
  header :: [Text]
header = [[Int] -> [Text] -> Text
listToRow [Int]
mw [Text]
recipeHeader, [Int] -> Text
separatingLine [Int]
mw]

recipePage :: PageAddress -> [Recipe Entity] -> Text
recipePage :: PageAddress -> [Recipe Entity] -> Text
recipePage = PageAddress -> [Recipe Entity] -> Text
recipeTable

getBaseRobot :: Has (Throw SystemFailure) sig m => Scenario -> m Robot
getBaseRobot :: forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw SystemFailure) sig m =>
Scenario -> m Robot
getBaseRobot Scenario
s = case forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Scenario [TRobot]
scenarioRobots Scenario
s of
  Just TRobot
r -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> TRobot -> Robot
instantiateRobot Int
0 TRobot
r
  Maybe TRobot
Nothing -> forall e (sig :: (* -> *) -> * -> *) (m :: * -> *) a.
Has (Throw e) sig m =>
e -> m a
throwError forall a b. (a -> b) -> a -> b
$ Text -> SystemFailure
CustomFailure Text
"Scenario contains no robots"

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

generateRecipe :: IO String
generateRecipe :: IO String
generateRecipe = forall a. ThrowC SystemFailure IO a -> IO a
simpleErrorHandle forall a b. (a -> b) -> a -> b
$ do
  (Scenario
classic, (WorldMap
worlds, EntityMap
entities, [Recipe Entity]
recipes)) <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
(Has (Throw SystemFailure) sig m, Has (Lift IO) sig m) =>
String -> m (Scenario, (WorldMap, EntityMap, [Recipe Entity]))
loadStandaloneScenario String
"data/scenarios/classic.yaml"
  Robot
baseRobot <- forall (sig :: (* -> *) -> * -> *) (m :: * -> *).
Has (Throw SystemFailure) sig m =>
Scenario -> m Robot
getBaseRobot Scenario
classic
  forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Dot a -> String
Dot.showDot forall a b. (a -> b) -> a -> b
$ Robot -> Some (TTerm '[]) -> EntityMap -> [Recipe Entity] -> Dot ()
recipesToDot Robot
baseRobot (WorldMap
worlds forall k a. Ord k => Map k a -> k -> a
! Text
"classic") EntityMap
entities [Recipe Entity]
recipes

recipesToDot :: Robot -> Some (TTerm '[]) -> EntityMap -> [Recipe Entity] -> Dot ()
recipesToDot :: Robot -> Some (TTerm '[]) -> EntityMap -> [Recipe Entity] -> Dot ()
recipesToDot Robot
baseRobot Some (TTerm '[])
classicTerm EntityMap
emap [Recipe Entity]
recipes = 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' = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> Set k
Map.keysSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityMap -> Map Text Entity
entitiesByName forall a b. (a -> b) -> a -> b
$ EntityMap
emap
      enames :: [Text]
enames = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set Text
ignoredEntities) [Text]
enames'
  Map Text NodeId
ebmap <- forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
enames forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Dot NodeId
box 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 Text a -> Text -> a
safeGetEntity Map Text a
m Text
e = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
e forall a. Semigroup a => a -> a -> a
<> String
" is not an entity!?") forall a b. (a -> b) -> a -> b
$ Map Text a
m forall k a. Ord k => Map k a -> k -> Maybe a
Map.!? Text
e
      getE :: Text -> NodeId
getE = forall {a}. Map Text a -> Text -> a
safeGetEntity Map Text NodeId
ebmap
      nid :: Entity -> NodeId
nid = Text -> NodeId
getE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view 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 = Robot -> Set Entity
startingDevices Robot
baseRobot
      inv :: Map Entity Int
inv = Robot -> Map Entity Int
startingInventory Robot
baseRobot
      worldEntities :: Set Entity
worldEntities = case Some (TTerm '[])
classicTerm of Some TTy α
_ TTerm '[] α
t -> forall (g :: [*]) a. TTerm g a -> Set Entity
extractEntities TTerm '[] α
t
      levels :: [Set Entity]
levels = [Recipe Entity] -> Set Entity -> [Set Entity]
recipeLevels [Recipe Entity]
recipes (forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions [Set Entity
worldEntities, Set Entity
devs])
  -- --------------------------------------------------------------------------
  -- Base inventory
  (NodeId
_bc, ()) <- forall a. Dot a -> Dot (NodeId, a)
Dot.cluster 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")
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((NodeId
base NodeId -> NodeId -> Dot ()
---<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity -> NodeId
nid) Set Entity
devs
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((NodeId
base NodeId -> NodeId -> Dot ()
.->.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entity -> NodeId
nid forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList Map Entity Int
inv
  -- --------------------------------------------------------------------------
  -- World entities
  (NodeId
_wc, ()) <- forall a. Dot a -> Dot (NodeId, a)
Dot.cluster 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")
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry NodeId -> NodeId -> Dot ()
(Dot..->.) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NodeId
world,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> NodeId
getE forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Entity Text
entityName) (forall (t :: * -> *) a. Foldable t => t a -> [a]
toList 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' = forall a b. (a -> b) -> [a] -> [b]
map Entity -> NodeId
nid forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Set Entity
ns
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (NodeId
b NodeId -> NodeId -> Dot ()
.~>.) [NodeId]
ns'
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (NodeId -> NodeId -> Dot ()
.~>. NodeId
t) [NodeId]
ns'
        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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Dot a -> Dot (NodeId, a)
Dot.cluster 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 #" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
i)
            ]
        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 <- 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 ..] (forall a. Int -> [a] -> [a]
drop Int
1 [Set Entity]
levels)
  let invisibleLine :: [NodeId] -> [NodeId] -> Dot ()
invisibleLine = forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ NodeId -> NodeId -> Dot ()
(.~>.)
  [NodeId]
tls <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. a -> b -> a
const Dot NodeId
hiddenNode) [Set Entity]
levels
  [NodeId]
bls <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (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 (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] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [NodeId] -> Dot ()
Dot.same [NodeId
t1, NodeId
t2]
  forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ (NodeId, NodeId) -> (NodeId, NodeId) -> Dot ()
sameBelowAbove ((NodeId, NodeId)
bottom forall a. a -> [a] -> [a]
: [(NodeId, NodeId)]
ls) (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 recipeInOut :: Recipe b -> [(b, b)]
recipeInOut Recipe b
r = [(forall a b. (a, b) -> b
snd (Int, b)
i, forall a b. (a, b) -> b
snd (Int, b)
o) | (Int, b)
i <- Recipe b
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeInputs, (Int, b)
o <- Recipe b
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeOutputs]
      recipeReqOut :: Recipe b -> [(b, b)]
recipeReqOut Recipe b
r = [(forall a b. (a, b) -> b
snd (Int, b)
q, forall a b. (a, b) -> b
snd (Int, b)
o) | (Int, b)
q <- Recipe b
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeCatalysts, (Int, b)
o <- Recipe b
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeOutputs]
      recipesToPairs :: (a -> [p Entity Entity]) -> t a -> [p NodeId NodeId]
recipesToPairs a -> [p Entity Entity]
f t a
rs = forall (p :: * -> * -> *) a d.
Bifunctor p =>
(a -> d) -> p a a -> p d d
both Entity -> NodeId
nid forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Ord a => [a] -> [a]
nubOrd (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap a -> [p Entity Entity]
f t a
rs)
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry NodeId -> NodeId -> Dot ()
(.->.)) (forall {p :: * -> * -> *} {t :: * -> *} {a}.
(Bifunctor p, Ord (p Entity Entity), Foldable t) =>
(a -> [p Entity Entity]) -> t a -> [p NodeId NodeId]
recipesToPairs forall {b}. Recipe b -> [(b, b)]
recipeInOut [Recipe Entity]
recipes)
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry NodeId -> NodeId -> Dot ()
(---<>)) (forall {p :: * -> * -> *} {t :: * -> *} {a}.
(Bifunctor p, Ord (p Entity Entity), Foldable t) =>
(a -> [p Entity Entity]) -> t a -> [p NodeId NodeId]
recipesToPairs forall {b}. Recipe b -> [(b, b)]
recipeReqOut [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) 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 :: [Recipe Entity] -> Set Entity -> [Set Entity]
recipeLevels :: [Recipe Entity] -> Set Entity -> [Set Entity]
recipeLevels [Recipe Entity]
recipes Set Entity
start = [Set Entity]
levels
 where
  recipeParts :: Recipe e -> (IngredientList e, IngredientList e)
recipeParts Recipe e
r = ((Recipe e
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeInputs) forall a. Semigroup a => a -> a -> a
<> (Recipe e
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeCatalysts), Recipe e
r forall s a. s -> Getting a s a -> a
^. forall e. Lens' (Recipe e) (IngredientList e)
recipeOutputs)
  m :: [(Set Entity, Set Entity)]
  m :: [(Set Entity, Set Entity)]
m = forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) a d.
Bifunctor p =>
(a -> d) -> p a a -> p d d
both (forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {e}. Recipe e -> (IngredientList e, IngredientList e)
recipeParts) [Recipe Entity]
recipes
  levels :: [Set Entity]
  levels :: [Set Entity]
levels = forall a. [a] -> [a]
reverse 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) = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ Set a
i forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set a
known
    nextLevel :: Set Entity -> Set Entity
nextLevel Set Entity
known = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (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 forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set Entity
known
       in if 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 forall a. a -> [a] -> [a]
: [Set Entity]
ls) (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 = forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inventory -> IngredientList Entity
E.elems forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' Robot Inventory
equippedDevices

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

-- | Ignore utility entities that are just used for tutorials and challenges.
ignoredEntities :: Set Text
ignoredEntities :: Set Text
ignoredEntities =
  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"
    ]

-- ----------------------------------------------------------------------------
-- 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 forall a b. (a -> b) -> a -> b
$ [(String
"style", String
"filled"), (String
"label", String
label)] 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")]

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