{-# LANGUAGE OverloadedStrings #-}
module Swarm.TUI.View.Util where
import Brick hiding (Direction, Location)
import Brick.Widgets.Dialog
import Brick.Widgets.List qualified as BL
import Control.Lens hiding (Const, from)
import Control.Monad.Reader (withReaderT)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Map.Strict qualified as M
import Data.Maybe (catMaybes, fromMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Graphics.Vty qualified as V
import Swarm.Game.Entity as E
import Swarm.Game.Location
import Swarm.Game.Scenario (scenarioName)
import Swarm.Game.ScenarioInfo (scenarioItemName)
import Swarm.Game.State
import Swarm.Game.Terrain
import Swarm.Language.Pretty (prettyText)
import Swarm.Language.Syntax (Syntax)
import Swarm.Language.Text.Markdown qualified as Markdown
import Swarm.Language.Types (Polytype)
import Swarm.TUI.Model
import Swarm.TUI.Model.UI
import Swarm.TUI.View.Attribute.Attr
import Swarm.TUI.View.CellDisplay
import Swarm.Util (listEnums)
import Witch (from, into)
generateModal :: AppState -> ModalType -> Modal
generateModal :: AppState -> ModalType -> Modal
generateModal AppState
s ModalType
mt = ModalType -> Dialog ButtonAction Name -> Modal
Modal ModalType
mt (forall n a.
Eq n =>
Maybe (Widget n)
-> Maybe (n, [([Char], n, a)]) -> Int -> Dialog a n
dialog (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall n. [Char] -> Widget n
str [Char]
title) Maybe (Name, [([Char], Name, ButtonAction)])
buttons (Int
maxModalWindowWidth forall a. Ord a => a -> a -> a
`min` Int
requiredWidth))
where
currentScenario :: Maybe ScenarioInfoPair
currentScenario = AppState
s forall s a. s -> Getting a s a -> a
^. Lens' AppState UIState
uiState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' UIState (Maybe ScenarioInfoPair)
scenarioRef
currentSeed :: Int
currentSeed = AppState
s forall s a. s -> Getting a s a -> a
^. Lens' AppState GameState
gameState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameState Int
seed
haltingMessage :: Maybe [Char]
haltingMessage = case AppState
s forall s a. s -> Getting a s a -> a
^. Lens' AppState UIState
uiState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' UIState Menu
uiMenu of
Menu
NoMenu -> forall a. a -> Maybe a
Just [Char]
"Quit"
Menu
_ -> forall a. Maybe a
Nothing
descriptionWidth :: Int
descriptionWidth = Int
100
helpWidth :: Int
helpWidth = Int
80
([Char]
title, Maybe (Name, [([Char], Name, ButtonAction)])
buttons, Int
requiredWidth) =
case ModalType
mt of
ModalType
HelpModal -> ([Char]
" Help ", forall a. Maybe a
Nothing, Int
helpWidth)
ModalType
RobotsModal -> ([Char]
"Robots", forall a. Maybe a
Nothing, Int
descriptionWidth)
ModalType
RecipesModal -> ([Char]
"Available Recipes", forall a. Maybe a
Nothing, Int
descriptionWidth)
ModalType
CommandsModal -> ([Char]
"Available Commands", forall a. Maybe a
Nothing, Int
descriptionWidth)
ModalType
MessagesModal -> ([Char]
"Messages", forall a. Maybe a
Nothing, Int
descriptionWidth)
ScenarioEndModal ScenarioOutcome
WinModal ->
let nextMsg :: [Char]
nextMsg = [Char]
"Next challenge!"
stopMsg :: [Char]
stopMsg = forall a. a -> Maybe a -> a
fromMaybe [Char]
"Return to the menu" Maybe [Char]
haltingMessage
continueMsg :: [Char]
continueMsg = [Char]
"Keep playing"
in ( [Char]
""
, forall a. a -> Maybe a
Just
( Button -> Name
Button Button
NextButton
, [ ([Char]
nextMsg, Button -> Name
Button Button
NextButton, ScenarioInfoPair -> ButtonAction
Next ScenarioInfoPair
scene)
| Just ScenarioInfoPair
scene <- [Menu -> Maybe ScenarioInfoPair
nextScenario (AppState
s forall s a. s -> Getting a s a -> a
^. Lens' AppState UIState
uiState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' UIState Menu
uiMenu)]
]
forall a. [a] -> [a] -> [a]
++ [ ([Char]
stopMsg, Button -> Name
Button Button
QuitButton, ButtonAction
QuitAction)
, ([Char]
continueMsg, Button -> Name
Button Button
KeepPlayingButton, ButtonAction
KeepPlaying)
]
)
, forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]
nextMsg, [Char]
stopMsg, [Char]
continueMsg]) forall a. Num a => a -> a -> a
+ Int
32
)
ScenarioEndModal ScenarioOutcome
LoseModal ->
let stopMsg :: [Char]
stopMsg = forall a. a -> Maybe a -> a
fromMaybe [Char]
"Return to the menu" Maybe [Char]
haltingMessage
continueMsg :: [Char]
continueMsg = [Char]
"Keep playing"
maybeStartOver :: Maybe ([Char], Name, ButtonAction)
maybeStartOver = do
ScenarioInfoPair
cs <- Maybe ScenarioInfoPair
currentScenario
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
"Start over", Button -> Name
Button Button
StartOverButton, Int -> ScenarioInfoPair -> ButtonAction
StartOver Int
currentSeed ScenarioInfoPair
cs)
in ( [Char]
""
, forall a. a -> Maybe a
Just
( Button -> Name
Button Button
QuitButton
, forall a. [Maybe a] -> [a]
catMaybes
[ forall a. a -> Maybe a
Just ([Char]
stopMsg, Button -> Name
Button Button
QuitButton, ButtonAction
QuitAction)
, Maybe ([Char], Name, ButtonAction)
maybeStartOver
, forall a. a -> Maybe a
Just ([Char]
continueMsg, Button -> Name
Button Button
KeepPlayingButton, ButtonAction
KeepPlaying)
]
)
, forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length [[Char]
stopMsg, [Char]
continueMsg]) forall a. Num a => a -> a -> a
+ Int
32
)
DescriptionModal Entity
e -> (Entity -> [Char]
descriptionTitle Entity
e, forall a. Maybe a
Nothing, Int
descriptionWidth)
ModalType
QuitModal ->
let stopMsg :: [Char]
stopMsg = forall a. a -> Maybe a -> a
fromMaybe ([Char]
"Quit to" forall a. [a] -> [a] -> [a]
++ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" ([Char]
" " forall a. [a] -> [a] -> [a]
++) (forall target source. From source target => source -> target
into @String forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AppState -> Maybe Text
curMenuName AppState
s) forall a. [a] -> [a] -> [a]
++ [Char]
" menu") Maybe [Char]
haltingMessage
maybeStartOver :: Maybe ([Char], Name, ButtonAction)
maybeStartOver = do
ScenarioInfoPair
cs <- Maybe ScenarioInfoPair
currentScenario
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
"Start over", Button -> Name
Button Button
StartOverButton, Int -> ScenarioInfoPair -> ButtonAction
StartOver Int
currentSeed ScenarioInfoPair
cs)
in ( [Char]
""
, forall a. a -> Maybe a
Just
( Button -> Name
Button Button
CancelButton
, forall a. [Maybe a] -> [a]
catMaybes
[ forall a. a -> Maybe a
Just ([Char]
"Keep playing", Button -> Name
Button Button
CancelButton, ButtonAction
Cancel)
, Maybe ([Char], Name, ButtonAction)
maybeStartOver
, forall a. a -> Maybe a
Just ([Char]
stopMsg, Button -> Name
Button Button
QuitButton, ButtonAction
QuitAction)
]
)
, Text -> Int
T.length (Menu -> Text
quitMsg (AppState
s forall s a. s -> Getting a s a -> a
^. Lens' AppState UIState
uiState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' UIState Menu
uiMenu)) forall a. Num a => a -> a -> a
+ Int
4
)
ModalType
GoalModal ->
let goalModalTitle :: Text
goalModalTitle = case Maybe ScenarioInfoPair
currentScenario of
Maybe ScenarioInfoPair
Nothing -> Text
"Goal"
Just (Scenario
scenario, ScenarioInfo
_) -> Scenario
scenario forall s a. s -> Getting a s a -> a
^. Lens' Scenario Text
scenarioName
in ([Char]
" " forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
goalModalTitle forall a. Semigroup a => a -> a -> a
<> [Char]
" ", forall a. Maybe a
Nothing, Int
descriptionWidth)
ModalType
KeepPlayingModal -> ([Char]
"", forall a. a -> Maybe a
Just (Button -> Name
Button Button
CancelButton, [([Char]
"OK", Button -> Name
Button Button
CancelButton, ButtonAction
Cancel)]), Int
80)
ModalType
TerrainPaletteModal -> ([Char]
"Terrain", forall a. Maybe a
Nothing, Int
w)
where
wordLength :: Int
wordLength = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) (forall e. (Enum e, Bounded e) => [e]
listEnums :: [TerrainType])
w :: Int
w = Int
wordLength forall a. Num a => a -> a -> a
+ Int
6
ModalType
EntityPaletteModal -> ([Char]
"Entity", forall a. Maybe a
Nothing, Int
30)
drawType :: Polytype -> Widget Name
drawType :: Polytype -> Widget Name
drawType = forall n. AttrName -> Widget n -> Widget n
withAttr AttrName
infoAttr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Int -> Widget n -> Widget n
padLeftRight Int
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Text -> Widget n
txt forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PrettyPrec a => a -> Text
prettyText
drawMarkdown :: Markdown.Document Syntax -> Widget Name
drawMarkdown :: Document Syntax -> Widget Name
drawMarkdown Document Syntax
d = do
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Fixed forall a b. (a -> b) -> a -> b
$ do
Context Name
ctx <- forall n. RenderM n (Context n)
getContext
let w :: Int
w = Context Name
ctx forall s a. s -> Getting a s a -> a
^. forall n. Lens' (Context n) Int
availWidthL
let docLines :: [[[StreamNode]]]
docLines = Int -> [StreamNode] -> [[StreamNode]]
Markdown.chunksOf Int
w forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToStream a => a -> [StreamNode]
Markdown.toStream forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall c. Document c -> [Paragraph c]
Markdown.paragraphs Document Syntax
d
forall n. Widget n -> RenderM n (Result n)
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Widget Name] -> Widget Name
layoutParagraphs forall a b. (a -> b) -> a -> b
$ forall n. [Widget n] -> Widget n
vBox forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall n. [Widget n] -> Widget n
hBox forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {n}. StreamNode -> Widget n
mTxt) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[[StreamNode]]]
docLines
where
mTxt :: StreamNode -> Widget n
mTxt = \case
Markdown.TextNode Set TxtAttr
as Text
t -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr forall {n}. TxtAttr -> Widget n -> Widget n
applyAttr (forall n. Text -> Widget n
txt Text
t) Set TxtAttr
as
Markdown.CodeNode Text
t -> forall n. AttrName -> Widget n -> Widget n
withAttr AttrName
highlightAttr forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
txt Text
t
Markdown.RawNode [Char]
f Text
t -> forall n. AttrName -> Widget n -> Widget n
withAttr ([Char] -> AttrName
rawAttr [Char]
f) forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
txt Text
t
applyAttr :: TxtAttr -> Widget n -> Widget n
applyAttr TxtAttr
a = forall n. AttrName -> Widget n -> Widget n
withAttr forall a b. (a -> b) -> a -> b
$ case TxtAttr
a of
TxtAttr
Markdown.Strong -> AttrName
boldAttr
TxtAttr
Markdown.Emphasis -> AttrName
italicAttr
rawAttr :: [Char] -> AttrName
rawAttr = \case
[Char]
"entity" -> AttrName
greenAttr
[Char]
"type" -> AttrName
magentaAttr
[Char]
_snippet -> AttrName
highlightAttr
drawLabeledTerrainSwatch :: TerrainType -> Widget Name
drawLabeledTerrainSwatch :: TerrainType -> Widget Name
drawLabeledTerrainSwatch TerrainType
a =
forall {n}. Widget n
tile forall n. Widget n -> Widget n -> Widget n
<+> forall n. [Char] -> Widget n
str [Char]
materialName
where
tile :: Widget n
tile = forall n. Padding -> Widget n -> Widget n
padRight (Int -> Padding
Pad Int
1) forall a b. (a -> b) -> a -> b
$ forall n. Display -> Widget n
renderDisplay forall a b. (a -> b) -> a -> b
$ Map TerrainType Display
terrainMap forall k a. Ord k => Map k a -> k -> a
M.! TerrainType
a
materialName :: [Char]
materialName = forall a. [a] -> [a]
init forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show TerrainType
a
descriptionTitle :: Entity -> String
descriptionTitle :: Entity -> [Char]
descriptionTitle Entity
e = [Char]
" " forall a. [a] -> [a] -> [a]
++ forall source target. From source target => source -> target
from @Text (Entity
e forall s a. s -> Getting a s a -> a
^. Lens' Entity Text
entityName) forall a. [a] -> [a] -> [a]
++ [Char]
" "
maxModalWindowWidth :: Int
maxModalWindowWidth :: Int
maxModalWindowWidth = Int
500
curMenuName :: AppState -> Maybe Text
AppState
s = case AppState
s forall s a. s -> Getting a s a -> a
^. Lens' AppState UIState
uiState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' UIState Menu
uiMenu of
NewGameMenu (List Name ScenarioItem
_ :| (List Name ScenarioItem
parentMenu : [List Name ScenarioItem]
_)) ->
forall a. a -> Maybe a
Just (List Name ScenarioItem
parentMenu forall s a. s -> Getting a s a -> a
^. forall (t :: * -> *) e n.
(Splittable t, Traversable t, Semigroup (t e)) =>
Traversal' (GenericList n t e) e
BL.listSelectedElementL 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 ScenarioItem -> Text
scenarioItemName)
NewGameMenu NonEmpty (List Name ScenarioItem)
_ -> forall a. a -> Maybe a
Just Text
"Scenarios"
Menu
_ -> forall a. Maybe a
Nothing
quitMsg :: Menu -> Text
quitMsg :: Menu -> Text
quitMsg Menu
m = Text
"Are you sure you want to " forall a. Semigroup a => a -> a -> a
<> Text
quitAction forall a. Semigroup a => a -> a -> a
<> Text
"? All progress on this scenario will be lost!"
where
quitAction :: Text
quitAction = case Menu
m of
Menu
NoMenu -> Text
"quit"
Menu
_ -> Text
"return to the menu"
locationToString :: Location -> String
locationToString :: Location -> [Char]
locationToString (Location Int32
x Int32
y) =
[[Char]] -> [Char]
unwords forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> [Char]
show [Int32
x, Int32
y]
displayParagraphs :: [Text] -> Widget Name
displayParagraphs :: [Text] -> Widget Name
displayParagraphs = [Widget Name] -> Widget Name
layoutParagraphs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall n. Text -> Widget n
txtWrap
layoutParagraphs :: [Widget Name] -> Widget Name
layoutParagraphs :: [Widget Name] -> Widget Name
layoutParagraphs [Widget Name]
ps = forall n. [Widget n] -> Widget n
vBox forall a b. (a -> b) -> a -> b
$ forall n. Padding -> Widget n -> Widget n
padBottom (Int -> Padding
Pad Int
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Widget Name]
ps
data EllipsisSide = Beginning | End
withEllipsis :: EllipsisSide -> Text -> Widget Name
withEllipsis :: EllipsisSide -> Text -> Widget Name
withEllipsis EllipsisSide
side Text
t =
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Fixed forall a b. (a -> b) -> a -> b
$ do
Context Name
ctx <- forall n. RenderM n (Context n)
getContext
let w :: Int
w = Context Name
ctx forall s a. s -> Getting a s a -> a
^. forall n. Lens' (Context n) Int
availWidthL
ellipsis :: Text
ellipsis = Int -> Text -> Text
T.replicate Int
3 forall a b. (a -> b) -> a -> b
$ Char -> Text
T.singleton Char
'.'
tLength :: Int
tLength = Text -> Int
T.length Text
t
newText :: Text
newText =
if Int
tLength forall a. Ord a => a -> a -> Bool
> Int
w
then case EllipsisSide
side of
EllipsisSide
Beginning -> Text
ellipsis forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
T.drop (Int
w forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
ellipsis) Text
t
EllipsisSide
End -> Int -> Text -> Text
T.take (Int
w forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
ellipsis) Text
t forall a. Semigroup a => a -> a -> a
<> Text
ellipsis
else Text
t
forall n. Widget n -> RenderM n (Result n)
render forall a b. (a -> b) -> a -> b
$ forall n. Text -> Widget n
txt Text
newText
maybeScroll :: (Ord n, Show n) => n -> Widget n -> Widget n
maybeScroll :: forall n. (Ord n, Show n) => n -> Widget n -> Widget n
maybeScroll n
vpName Widget n
contents =
forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Greedy Size
Greedy forall a b. (a -> b) -> a -> b
$ do
Context n
ctx <- forall n. RenderM n (Context n)
getContext
Result n
result <- forall r' r (m :: * -> *) a.
(r' -> r) -> ReaderT r m a -> ReaderT r' m a
withReaderT (forall n. Lens' (Context n) Int
availHeightL forall s t a b. ASetter s t a b -> b -> s -> t
.~ Int
10000) (forall n. Widget n -> RenderM n (Result n)
render Widget n
contents)
if Image -> Int
V.imageHeight (Result n
result forall s a. s -> Getting a s a -> a
^. forall n. Lens' (Result n) Image
imageL) forall a. Ord a => a -> a -> Bool
<= Context n
ctx forall s a. s -> Getting a s a -> a
^. forall n. Lens' (Context n) Int
availHeightL
then forall (m :: * -> *) a. Monad m => a -> m a
return Result n
result
else
forall n. Widget n -> RenderM n (Result n)
render
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. VScrollBarOrientation -> Widget n -> Widget n
withVScrollBars VScrollBarOrientation
OnRight
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n.
(Ord n, Show n) =>
n -> ViewportType -> Widget n -> Widget n
viewport n
vpName ViewportType
Vertical
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Size -> Size -> RenderM n (Result n) -> Widget n
Widget Size
Fixed Size
Fixed
forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return Result n
result