{-# 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.Maybe (fromMaybe, isJust)
import Data.Yaml
import GHC.Generics (Generic)
import Swarm.Language.Syntax (Direction (..))
import Swarm.TUI.Attr (entityAttr, robotAttr, worldPrefix)
import Swarm.Util (maxOn, (?))
import Swarm.Util.Yaml (FromJSONE (..), With (runE), getE, liftE, withObjectE)
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 Value
v = forall e (f :: * -> *) a. With e f a -> e -> f a
runE (forall e a. FromJSONE e a => Value -> ParserE e a
parseJSONE Value
v) (Char -> Display
defaultEntityDisplay Char
' ')
instance FromJSONE Display Display where
parseJSONE :: Value -> ParserE Display Display
parseJSONE = forall e a.
String -> (Object -> ParserE e a) -> Value -> ParserE e a
withObjectE String
"Display" forall a b. (a -> b) -> a -> b
$ \Object
v -> do
Display
defD <- forall (f :: * -> *) e. Monad f => With e f e
getE
Maybe Char
mc <- forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE forall a b. (a -> b) -> a -> b
$ Object
v forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"char"
let c :: Char
c = forall a. a -> Maybe a -> a
fromMaybe (Display
defD forall s a. s -> Getting a s a -> a
^. Lens' Display Char
defaultChar) Maybe Char
mc
let dOM :: Map Direction Char
dOM = if forall a. Maybe a -> Bool
isJust Maybe Char
mc then forall a. Monoid a => a
mempty else Display
defD forall s a. s -> Getting a s a -> a
^. Lens' Display (Map Direction Char)
orientationMap
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE forall a b. (a -> b) -> a -> b
$
Char
-> Map Direction Char
-> Maybe Direction
-> AttrName
-> Priority
-> Bool
-> Display
Display Char
c
forall (f :: * -> *) a b. Functor 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
.!= Map Direction Char
dOM
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 a. Parser (Maybe a) -> a -> Parser a
.!= (Display
defD forall s a. s -> Getting a s a -> a
^. Lens' Display (Maybe Direction)
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
.!= (Display
defD forall s a. s -> Getting a s a -> a
^. Lens' Display AttrName
displayAttr)
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
.!= (Display
defD forall s a. s -> Getting a s a -> a
^. Lens' Display Priority
displayPriority)
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
.!= (Display
defD forall s a. s -> Getting a s a -> a
^. Lens' Display Bool
invisible)
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