{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Swarm.Game.Display (
Priority,
Display,
defaultChar,
orientationMap,
curOrientation,
displayAttr,
displayPriority,
invisible,
displayChar,
renderDisplay,
hidden,
defaultTerrainDisplay,
defaultEntityDisplay,
defaultRobotDisplay,
) where
import Brick (AttrName, Widget, str, withAttr)
import Control.Lens hiding (Const, from, (.=))
import Data.Hashable (Hashable)
import Data.Map (Map)
import Data.Map qualified as M
import Data.Yaml
import GHC.Generics (Generic)
import Swarm.Language.Syntax (Direction (..))
import Swarm.TUI.Attr (entityAttr, robotAttr, worldPrefix)
import Swarm.Util (maxOn, (?))
type Priority = Int
instance Hashable AttrName
data Display = Display
{ Display -> Char
_defaultChar :: Char
, Display -> Map Direction Char
_orientationMap :: Map Direction Char
, Display -> Maybe Direction
_curOrientation :: Maybe Direction
, Display -> AttrName
_displayAttr :: AttrName
, Display -> Priority
_displayPriority :: Priority
, Display -> Bool
_invisible :: Bool
}
deriving (Display -> Display -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Display -> Display -> Bool
$c/= :: Display -> Display -> Bool
== :: Display -> Display -> Bool
$c== :: Display -> Display -> Bool
Eq, Eq Display
Display -> Display -> Bool
Display -> Display -> Ordering
Display -> Display -> Display
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Display -> Display -> Display
$cmin :: Display -> Display -> Display
max :: Display -> Display -> Display
$cmax :: Display -> Display -> Display
>= :: Display -> Display -> Bool
$c>= :: Display -> Display -> Bool
> :: Display -> Display -> Bool
$c> :: Display -> Display -> Bool
<= :: Display -> Display -> Bool
$c<= :: Display -> Display -> Bool
< :: Display -> Display -> Bool
$c< :: Display -> Display -> Bool
compare :: Display -> Display -> Ordering
$ccompare :: Display -> Display -> Ordering
Ord, Priority -> Display -> ShowS
[Display] -> ShowS
Display -> String
forall a.
(Priority -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Display] -> ShowS
$cshowList :: [Display] -> ShowS
show :: Display -> String
$cshow :: Display -> String
showsPrec :: Priority -> Display -> ShowS
$cshowsPrec :: Priority -> Display -> ShowS
Show, forall x. Rep Display x -> Display
forall x. Display -> Rep Display x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Display x -> Display
$cfrom :: forall x. Display -> Rep Display x
Generic, Eq Display
Priority -> Display -> Priority
Display -> Priority
forall a.
Eq a
-> (Priority -> a -> Priority) -> (a -> Priority) -> Hashable a
hash :: Display -> Priority
$chash :: Display -> Priority
hashWithSalt :: Priority -> Display -> Priority
$chashWithSalt :: Priority -> Display -> Priority
Hashable)
instance Semigroup Display where
Display
d1 <> :: Display -> Display -> Display
<> Display
d2
| Display -> Bool
_invisible Display
d1 = Display
d2
| Display -> Bool
_invisible Display
d2 = Display
d1
| Bool
otherwise = forall b a. Ord b => (a -> b) -> a -> a -> a
maxOn Display -> Priority
_displayPriority Display
d1 Display
d2
makeLensesWith (lensRules & generateSignatures .~ False) ''Display
defaultChar :: Lens' Display Char
orientationMap :: Lens' Display (Map Direction Char)
curOrientation :: Lens' Display (Maybe Direction)
displayAttr :: Lens' Display AttrName
displayPriority :: Lens' Display Priority
invisible :: Lens' Display Bool
instance FromJSON Display where
parseJSON :: Value -> Parser Display
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"Display" forall a b. (a -> b) -> a -> b
$ \Object
v ->
Char
-> Map Direction Char
-> Maybe Direction
-> AttrName
-> Priority
-> Bool
-> Display
Display
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"char" forall a. Parser (Maybe a) -> a -> Parser a
.!= Char
' '
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"orientationMap" forall a. Parser (Maybe a) -> a -> Parser a
.!= forall k a. Map k a
M.empty
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"curOrientation"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (AttrName
worldPrefix forall a. Semigroup a => a -> a -> a
<>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"attr") forall a. Parser (Maybe a) -> a -> Parser a
.!= AttrName
entityAttr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"priority" forall a. Parser (Maybe a) -> a -> Parser a
.!= Priority
1
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"invisible" forall a. Parser (Maybe a) -> a -> Parser a
.!= Bool
False
instance ToJSON Display where
toJSON :: Display -> Value
toJSON Display
d =
[Pair] -> Value
object forall a b. (a -> b) -> a -> b
$
[ Key
"char" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Display
d forall s a. s -> Getting a s a -> a
^. Lens' Display Char
defaultChar)
, Key
"attr" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Display
d forall s a. s -> Getting a s a -> a
^. Lens' Display AttrName
displayAttr)
, Key
"priority" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Display
d forall s a. s -> Getting a s a -> a
^. Lens' Display Priority
displayPriority)
]
forall a. [a] -> [a] -> [a]
++ [Key
"orientationMap" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Display
d forall s a. s -> Getting a s a -> a
^. Lens' Display (Map Direction Char)
orientationMap) | Bool -> Bool
not (forall k a. Map k a -> Bool
M.null (Display
d forall s a. s -> Getting a s a -> a
^. Lens' Display (Map Direction Char)
orientationMap))]
forall a. [a] -> [a] -> [a]
++ [Key
"invisible" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Display
d forall s a. s -> Getting a s a -> a
^. Lens' Display Bool
invisible) | Display
d forall s a. s -> Getting a s a -> a
^. Lens' Display Bool
invisible]
displayChar :: Display -> Char
displayChar :: Display -> Char
displayChar Display
disp = case Display
disp forall s a. s -> Getting a s a -> a
^. Lens' Display (Maybe Direction)
curOrientation of
Maybe Direction
Nothing -> Display
disp forall s a. s -> Getting a s a -> a
^. Lens' Display Char
defaultChar
Just Direction
dir -> forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Direction
dir (Display
disp forall s a. s -> Getting a s a -> a
^. Lens' Display (Map Direction Char)
orientationMap) forall a. Maybe a -> a -> a
? (Display
disp forall s a. s -> Getting a s a -> a
^. Lens' Display Char
defaultChar)
renderDisplay :: Display -> Widget n
renderDisplay :: forall n. Display -> Widget n
renderDisplay Display
disp = forall n. AttrName -> Widget n -> Widget n
withAttr (Display
disp forall s a. s -> Getting a s a -> a
^. Lens' Display AttrName
displayAttr) forall a b. (a -> b) -> a -> b
$ forall n. String -> Widget n
str [Display -> Char
displayChar Display
disp]
hidden :: Display -> Display
hidden :: Display -> Display
hidden = (Lens' Display Char
defaultChar forall s t a b. ASetter s t a b -> b -> s -> t
.~ Char
'?') forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Lens' Display (Maybe Direction)
curOrientation forall s t a b. ASetter s t a b -> b -> s -> t
.~ forall a. Maybe a
Nothing)
defaultTerrainDisplay :: Char -> AttrName -> Display
defaultTerrainDisplay :: Char -> AttrName -> Display
defaultTerrainDisplay Char
c AttrName
attr =
Char -> Display
defaultEntityDisplay Char
c
forall a b. a -> (a -> b) -> b
& Lens' Display Priority
displayPriority forall s t a b. ASetter s t a b -> b -> s -> t
.~ Priority
0
forall a b. a -> (a -> b) -> b
& Lens' Display AttrName
displayAttr forall s t a b. ASetter s t a b -> b -> s -> t
.~ AttrName
attr
defaultEntityDisplay :: Char -> Display
defaultEntityDisplay :: Char -> Display
defaultEntityDisplay Char
c =
Display
{ _defaultChar :: Char
_defaultChar = Char
c
, _orientationMap :: Map Direction Char
_orientationMap = forall k a. Map k a
M.empty
, _curOrientation :: Maybe Direction
_curOrientation = forall a. Maybe a
Nothing
, _displayAttr :: AttrName
_displayAttr = AttrName
entityAttr
, _displayPriority :: Priority
_displayPriority = Priority
1
, _invisible :: Bool
_invisible = Bool
False
}
defaultRobotDisplay :: Display
defaultRobotDisplay :: Display
defaultRobotDisplay =
Display
{ _defaultChar :: Char
_defaultChar = Char
'X'
, _orientationMap :: Map Direction Char
_orientationMap =
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
[ (Direction
DEast, Char
'>')
, (Direction
DWest, Char
'<')
, (Direction
DSouth, Char
'v')
, (Direction
DNorth, Char
'^')
]
, _curOrientation :: Maybe Direction
_curOrientation = forall a. Maybe a
Nothing
, _displayAttr :: AttrName
_displayAttr = AttrName
robotAttr
, _displayPriority :: Priority
_displayPriority = Priority
10
, _invisible :: Bool
_invisible = Bool
False
}
instance Monoid Display where
mempty :: Display
mempty = Char -> Display
defaultEntityDisplay Char
' ' forall a b. a -> (a -> b) -> b
& Lens' Display Bool
invisible forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True