{-# LANGUAGE OverloadedStrings #-}
module Swarm.TUI.View.Attribute.Attr (
swarmAttrMap,
worldAttributes,
worldPrefix,
meterAttributeNames,
messageAttributeNames,
toAttrName,
getWorldAttrName,
mkBrickColor,
entityAttr,
robotAttr,
highlightAttr,
notifAttr,
infoAttr,
boldAttr,
italicAttr,
dimAttr,
magentaAttr,
cyanAttr,
lightCyanAttr,
yellowAttr,
beigeAttr,
blueAttr,
greenAttr,
redAttr,
grayAttr,
defAttr,
customEditFocusedAttr,
) where
import Brick
import Brick.Forms (focusedFormInputAttr, invalidFormInputAttr)
import Brick.Widgets.Dialog
import Brick.Widgets.Edit qualified as E
import Brick.Widgets.List (listSelectedFocusedAttr)
import Control.Arrow ((***))
import Data.Colour.Palette.BrewerSet
import Data.Colour.SRGB (RGB (..))
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NE
import Data.Map qualified as M
import Data.Maybe (fromMaybe)
import Data.Text (unpack)
import Graphics.Vty qualified as V
import Swarm.Game.Display (Attribute (..))
import Swarm.Game.Entity.Cosmetic
import Swarm.Game.Entity.Cosmetic.Assignment
import Swarm.TUI.View.Attribute.Util
toAttrName :: Attribute -> AttrName
toAttrName :: Attribute -> AttrName
toAttrName = \case
Attribute
ARobot -> AttrName
robotAttr
Attribute
AEntity -> AttrName
entityAttr
AWorld Text
n -> AttrName
worldPrefix AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName (Text -> String
unpack Text
n)
Attribute
ADefault -> AttrName
defAttr
toVtyAttr :: PreservableColor -> V.Attr
toVtyAttr :: PreservableColor -> Attr
toVtyAttr PreservableColor
hifi = case (TrueColor -> Color) -> PreservableColor -> ColorLayers Color
forall a b. (a -> b) -> ColorLayers a -> ColorLayers b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TrueColor -> Color
mkBrickColor PreservableColor
hifi of
FgOnly Color
c -> Color -> Attr
fg Color
c
BgOnly Color
c -> Color -> Attr
bg Color
c
FgAndBg Color
foreground Color
background -> Color
foreground Color -> Color -> Attr
`on` Color
background
mkBrickColor :: TrueColor -> V.Color
mkBrickColor :: TrueColor -> Color
mkBrickColor = \case
Triple (RGB Word8
r Word8
g Word8
b) -> Word8 -> Word8 -> Word8 -> Color
forall i. Integral i => i -> i -> i -> Color
V.linearColor Word8
r Word8
g Word8
b
AnsiColor NamedColor
x -> case NamedColor
x of
NamedColor
White -> Color
V.white
NamedColor
BrightRed -> Color
V.brightRed
NamedColor
Red -> Color
V.red
NamedColor
Green -> Color
V.green
NamedColor
Blue -> Color
V.blue
NamedColor
BrightYellow -> Color
V.brightYellow
NamedColor
Yellow -> Color
V.yellow
swarmAttrMap :: AttrMap
swarmAttrMap :: AttrMap
swarmAttrMap =
Attr -> [(AttrName, Attr)] -> AttrMap
attrMap
Attr
V.defAttr
([(AttrName, Attr)] -> AttrMap) -> [(AttrName, Attr)] -> AttrMap
forall a b. (a -> b) -> a -> b
$ NonEmpty (AttrName, Attr) -> [(AttrName, Attr)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (AttrName, Attr)
activityMeterAttributes
[(AttrName, Attr)] -> [(AttrName, Attr)] -> [(AttrName, Attr)]
forall a. Semigroup a => a -> a -> a
<> NonEmpty (AttrName, Attr) -> [(AttrName, Attr)]
forall a. NonEmpty a -> [a]
NE.toList NonEmpty (AttrName, Attr)
robotMessageAttributes
[(AttrName, Attr)] -> [(AttrName, Attr)] -> [(AttrName, Attr)]
forall a. Semigroup a => a -> a -> a
<> ((WorldAttr, PreservableColor) -> (AttrName, Attr))
-> [(WorldAttr, PreservableColor)] -> [(AttrName, Attr)]
forall a b. (a -> b) -> [a] -> [b]
map (WorldAttr -> AttrName
getWorldAttrName (WorldAttr -> AttrName)
-> (PreservableColor -> Attr)
-> (WorldAttr, PreservableColor)
-> (AttrName, Attr)
forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** PreservableColor -> Attr
toVtyAttr) (Map WorldAttr PreservableColor -> [(WorldAttr, PreservableColor)]
forall k a. Map k a -> [(k, a)]
M.toList Map WorldAttr PreservableColor
worldAttributes)
[(AttrName, Attr)] -> [(AttrName, Attr)] -> [(AttrName, Attr)]
forall a. Semigroup a => a -> a -> a
<> [
(AttrName
robotAttr, Color -> Attr
fg Color
V.white Attr -> Word8 -> Attr
`V.withStyle` Word8
V.bold)
,
(AttrName
highlightAttr, Color -> Attr
fg Color
V.cyan)
, (AttrName
invalidFormInputAttr, Color -> Attr
fg Color
V.red)
, (AttrName
focusedFormInputAttr, Attr
V.defAttr)
, (AttrName
customEditFocusedAttr, Color
V.black Color -> Color -> Attr
`on` Color
V.yellow)
, (AttrName
listSelectedFocusedAttr, Color -> Attr
bg Color
V.blue)
, (AttrName
infoAttr, Color -> Attr
fg (forall i. Integral i => i -> i -> i -> Color
V.rgbColor @Int Int
100 Int
100 Int
100))
, (AttrName
buttonSelectedAttr, Color -> Attr
bg Color
V.blue)
, (AttrName
notifAttr, Color -> Attr
fg Color
V.yellow Attr -> Word8 -> Attr
`V.withStyle` Word8
V.bold)
, (AttrName
dimAttr, Attr
V.defAttr Attr -> Word8 -> Attr
`V.withStyle` Word8
V.dim)
, (AttrName
boldAttr, Attr
V.defAttr Attr -> Word8 -> Attr
`V.withStyle` Word8
V.bold)
, (AttrName
italicAttr, Attr
V.defAttr Attr -> Word8 -> Attr
`V.withStyle` Word8
V.italic)
,
(AttrName
redAttr, Color -> Attr
fg Color
V.red)
, (AttrName
greenAttr, Color -> Attr
fg Color
V.green)
, (AttrName
blueAttr, Color -> Attr
fg Color
V.blue)
, (AttrName
yellowAttr, Color -> Attr
fg Color
V.yellow)
, (AttrName
beigeAttr, Color -> Attr
fg (forall i. Integral i => i -> i -> i -> Color
V.rgbColor @Int Int
238 Int
217 Int
196))
, (AttrName
cyanAttr, Color -> Attr
fg Color
V.cyan)
, (AttrName
lightCyanAttr, Color -> Attr
fg (forall i. Integral i => i -> i -> i -> Color
V.rgbColor @Int Int
200 Int
255 Int
255))
, (AttrName
magentaAttr, Color -> Attr
fg Color
V.magenta)
, (AttrName
grayAttr, Color -> Attr
fg (forall i. Integral i => i -> i -> i -> Color
V.rgbColor @Int Int
128 Int
128 Int
128))
,
(AttrName
defAttr, Attr
V.defAttr)
]
worldPrefix :: AttrName
worldPrefix :: AttrName
worldPrefix = String -> AttrName
attrName String
"world"
getWorldAttrName :: WorldAttr -> AttrName
getWorldAttrName :: WorldAttr -> AttrName
getWorldAttrName (WorldAttr String
n) = AttrName
worldPrefix AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<> String -> AttrName
attrName String
n
entityAttr :: AttrName
entityAttr :: AttrName
entityAttr = WorldAttr -> AttrName
getWorldAttrName (WorldAttr -> AttrName) -> WorldAttr -> AttrName
forall a b. (a -> b) -> a -> b
$ (WorldAttr, PreservableColor) -> WorldAttr
forall a b. (a, b) -> a
fst (WorldAttr, PreservableColor)
entity
robotMessagePrefix :: AttrName
robotMessagePrefix :: AttrName
robotMessagePrefix = String -> AttrName
attrName String
"robotMessage"
robotMessageAttributes :: NonEmpty (AttrName, V.Attr)
robotMessageAttributes :: NonEmpty (AttrName, Attr)
robotMessageAttributes =
NonEmpty AttrName -> NonEmpty Attr -> NonEmpty (AttrName, Attr)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty AttrName
indices (NonEmpty Attr -> NonEmpty (AttrName, Attr))
-> NonEmpty Attr -> NonEmpty (AttrName, Attr)
forall a b. (a -> b) -> a -> b
$ NonEmpty Attr -> Maybe (NonEmpty Attr) -> NonEmpty Attr
forall a. a -> Maybe a -> a
fromMaybe (Attr -> NonEmpty Attr
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attr -> NonEmpty Attr) -> Attr -> NonEmpty Attr
forall a b. (a -> b) -> a -> b
$ Color -> Attr
fg Color
V.white) (Maybe (NonEmpty Attr) -> NonEmpty Attr)
-> Maybe (NonEmpty Attr) -> NonEmpty Attr
forall a b. (a -> b) -> a -> b
$ [Attr] -> Maybe (NonEmpty Attr)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Attr]
brewers
where
indices :: NonEmpty AttrName
indices = (Int -> AttrName) -> NonEmpty Int -> NonEmpty AttrName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map ((AttrName
robotMessagePrefix AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<>) (AttrName -> AttrName) -> (Int -> AttrName) -> Int -> AttrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AttrName
attrName (String -> AttrName) -> (Int -> String) -> Int -> AttrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) (NonEmpty Int -> NonEmpty AttrName)
-> NonEmpty Int -> NonEmpty AttrName
forall a b. (a -> b) -> a -> b
$ (Int
0 :: Int) Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| [Int
1 ..]
brewers :: [Attr]
brewers = (Kolor -> Attr) -> [Kolor] -> [Attr]
forall a b. (a -> b) -> [a] -> [b]
map (Color -> Attr
fg (Color -> Attr) -> (Kolor -> Color) -> Kolor -> Attr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kolor -> Color
kolorToAttrColor) ([Kolor] -> [Attr]) -> [Kolor] -> [Attr]
forall a b. (a -> b) -> a -> b
$ ColorCat -> Int -> [Kolor]
brewerSet ColorCat
Set3 Int
12
messageAttributeNames :: NonEmpty AttrName
messageAttributeNames :: NonEmpty AttrName
messageAttributeNames = ((AttrName, Attr) -> AttrName)
-> NonEmpty (AttrName, Attr) -> NonEmpty AttrName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (AttrName, Attr) -> AttrName
forall a b. (a, b) -> a
fst NonEmpty (AttrName, Attr)
robotMessageAttributes
activityMeterPrefix :: AttrName
activityMeterPrefix :: AttrName
activityMeterPrefix = String -> AttrName
attrName String
"activityMeter"
activityMeterAttributes :: NonEmpty (AttrName, V.Attr)
activityMeterAttributes :: NonEmpty (AttrName, Attr)
activityMeterAttributes =
NonEmpty AttrName -> NonEmpty Attr -> NonEmpty (AttrName, Attr)
forall a b. NonEmpty a -> NonEmpty b -> NonEmpty (a, b)
NE.zip NonEmpty AttrName
indices (NonEmpty Attr -> NonEmpty (AttrName, Attr))
-> NonEmpty Attr -> NonEmpty (AttrName, Attr)
forall a b. (a -> b) -> a -> b
$ NonEmpty Attr -> Maybe (NonEmpty Attr) -> NonEmpty Attr
forall a. a -> Maybe a -> a
fromMaybe (Attr -> NonEmpty Attr
forall a. a -> NonEmpty a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attr -> NonEmpty Attr) -> Attr -> NonEmpty Attr
forall a b. (a -> b) -> a -> b
$ Color -> Attr
bg Color
V.black) (Maybe (NonEmpty Attr) -> NonEmpty Attr)
-> Maybe (NonEmpty Attr) -> NonEmpty Attr
forall a b. (a -> b) -> a -> b
$ [Attr] -> Maybe (NonEmpty Attr)
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Attr]
brewers
where
indices :: NonEmpty AttrName
indices = (Int -> AttrName) -> NonEmpty Int -> NonEmpty AttrName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map ((AttrName
activityMeterPrefix AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<>) (AttrName -> AttrName) -> (Int -> AttrName) -> Int -> AttrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> AttrName
attrName (String -> AttrName) -> (Int -> String) -> Int -> AttrName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show) (NonEmpty Int -> NonEmpty AttrName)
-> NonEmpty Int -> NonEmpty AttrName
forall a b. (a -> b) -> a -> b
$ (Int
0 :: Int) Int -> [Int] -> NonEmpty Int
forall a. a -> [a] -> NonEmpty a
:| [Int
1 ..]
brewers :: [Attr]
brewers = (Kolor -> Attr) -> [Kolor] -> [Attr]
forall a b. (a -> b) -> [a] -> [b]
map Kolor -> Attr
bgWithAutoForeground ([Kolor] -> [Attr]) -> [Kolor] -> [Attr]
forall a b. (a -> b) -> a -> b
$ [Kolor] -> [Kolor]
forall a. [a] -> [a]
reverse ([Kolor] -> [Kolor]) -> [Kolor] -> [Kolor]
forall a b. (a -> b) -> a -> b
$ ColorCat -> Int -> [Kolor]
brewerSet ColorCat
RdYlGn Int
7
meterAttributeNames :: NonEmpty AttrName
meterAttributeNames :: NonEmpty AttrName
meterAttributeNames = ((AttrName, Attr) -> AttrName)
-> NonEmpty (AttrName, Attr) -> NonEmpty AttrName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (AttrName, Attr) -> AttrName
forall a b. (a, b) -> a
fst NonEmpty (AttrName, Attr)
activityMeterAttributes
robotAttr :: AttrName
robotAttr :: AttrName
robotAttr = String -> AttrName
attrName String
"robot"
highlightAttr
, notifAttr
, infoAttr
, boldAttr
, italicAttr
, dimAttr
, defAttr ::
AttrName
highlightAttr :: AttrName
highlightAttr = String -> AttrName
attrName String
"highlight"
notifAttr :: AttrName
notifAttr = String -> AttrName
attrName String
"notif"
infoAttr :: AttrName
infoAttr = String -> AttrName
attrName String
"info"
boldAttr :: AttrName
boldAttr = String -> AttrName
attrName String
"bold"
italicAttr :: AttrName
italicAttr = String -> AttrName
attrName String
"italics"
dimAttr :: AttrName
dimAttr = String -> AttrName
attrName String
"dim"
defAttr :: AttrName
defAttr = String -> AttrName
attrName String
"def"
customEditFocusedAttr :: AttrName
customEditFocusedAttr :: AttrName
customEditFocusedAttr = String -> AttrName
attrName String
"custom" AttrName -> AttrName -> AttrName
forall a. Semigroup a => a -> a -> a
<> AttrName
E.editFocusedAttr
redAttr, greenAttr, blueAttr, yellowAttr, beigeAttr, cyanAttr, lightCyanAttr, magentaAttr, grayAttr :: AttrName
redAttr :: AttrName
redAttr = String -> AttrName
attrName String
"red"
greenAttr :: AttrName
greenAttr = String -> AttrName
attrName String
"green"
blueAttr :: AttrName
blueAttr = String -> AttrName
attrName String
"blue"
yellowAttr :: AttrName
yellowAttr = String -> AttrName
attrName String
"yellow"
beigeAttr :: AttrName
beigeAttr = String -> AttrName
attrName String
"beige"
cyanAttr :: AttrName
cyanAttr = String -> AttrName
attrName String
"cyan"
lightCyanAttr :: AttrName
lightCyanAttr = String -> AttrName
attrName String
"lightCyan"
magentaAttr :: AttrName
magentaAttr = String -> AttrName
attrName String
"magenta"
grayAttr :: AttrName
grayAttr = String -> AttrName
attrName String
"gray"