{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Swarm.Game.Display (
Priority,
Attribute (..),
Display,
defaultChar,
orientationMap,
curOrientation,
displayAttr,
displayPriority,
invisible,
displayChar,
hidden,
defaultTerrainDisplay,
defaultEntityDisplay,
defaultRobotDisplay,
) where
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.Text (Text)
import Data.Text qualified as T
import Data.Yaml
import GHC.Generics (Generic)
import Swarm.Language.Syntax (AbsoluteDir (..), Direction (..))
import Swarm.Util (maxOn)
import Swarm.Util.Lens (makeLensesNoSigs)
import Swarm.Util.Yaml (FromJSONE (..), With (runE), getE, liftE, withObjectE)
type Priority = Int
data Attribute = ADefault | ARobot | AEntity | AWorld Text | ATerrain Text
deriving (Attribute -> Attribute -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Attribute -> Attribute -> Bool
$c/= :: Attribute -> Attribute -> Bool
== :: Attribute -> Attribute -> Bool
$c== :: Attribute -> Attribute -> Bool
Eq, Eq Attribute
Attribute -> Attribute -> Bool
Attribute -> Attribute -> Ordering
Attribute -> Attribute -> Attribute
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 :: Attribute -> Attribute -> Attribute
$cmin :: Attribute -> Attribute -> Attribute
max :: Attribute -> Attribute -> Attribute
$cmax :: Attribute -> Attribute -> Attribute
>= :: Attribute -> Attribute -> Bool
$c>= :: Attribute -> Attribute -> Bool
> :: Attribute -> Attribute -> Bool
$c> :: Attribute -> Attribute -> Bool
<= :: Attribute -> Attribute -> Bool
$c<= :: Attribute -> Attribute -> Bool
< :: Attribute -> Attribute -> Bool
$c< :: Attribute -> Attribute -> Bool
compare :: Attribute -> Attribute -> Ordering
$ccompare :: Attribute -> Attribute -> Ordering
Ord, Priority -> Attribute -> ShowS
[Attribute] -> ShowS
Attribute -> String
forall a.
(Priority -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Attribute] -> ShowS
$cshowList :: [Attribute] -> ShowS
show :: Attribute -> String
$cshow :: Attribute -> String
showsPrec :: Priority -> Attribute -> ShowS
$cshowsPrec :: Priority -> Attribute -> ShowS
Show, forall x. Rep Attribute x -> Attribute
forall x. Attribute -> Rep Attribute x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Attribute x -> Attribute
$cfrom :: forall x. Attribute -> Rep Attribute x
Generic, Eq Attribute
Priority -> Attribute -> Priority
Attribute -> Priority
forall a.
Eq a
-> (Priority -> a -> Priority) -> (a -> Priority) -> Hashable a
hash :: Attribute -> Priority
$chash :: Attribute -> Priority
hashWithSalt :: Priority -> Attribute -> Priority
$chashWithSalt :: Priority -> Attribute -> Priority
Hashable)
terrainPrefix :: Text
terrainPrefix :: Text
terrainPrefix = Text
"terrain_"
instance FromJSON Attribute where
parseJSON :: Value -> Parser Attribute
parseJSON =
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"attribute" forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
Text
"robot" -> Attribute
ARobot
Text
"entity" -> Attribute
AEntity
Text
"default" -> Attribute
ADefault
Text
t | Text
terrainPrefix Text -> Text -> Bool
`T.isPrefixOf` Text
t -> Text -> Attribute
ATerrain forall a b. (a -> b) -> a -> b
$ Priority -> Text -> Text
T.drop (Text -> Priority
T.length Text
terrainPrefix) Text
t
Text
w -> Text -> Attribute
AWorld Text
w
instance ToJSON Attribute where
toJSON :: Attribute -> Value
toJSON = \case
Attribute
ADefault -> Text -> Value
String Text
"default"
Attribute
ARobot -> Text -> Value
String Text
"robot"
Attribute
AEntity -> Text -> Value
String Text
"entity"
AWorld Text
w -> Text -> Value
String Text
w
ATerrain Text
t -> Text -> Value
String forall a b. (a -> b) -> a -> b
$ Text
terrainPrefix forall a. Semigroup a => a -> a -> a
<> Text
t
data Display = Display
{ Display -> Char
_defaultChar :: Char
, Display -> Map AbsoluteDir Char
_orientationMap :: Map AbsoluteDir Char
, Display -> Maybe Direction
_curOrientation :: Maybe Direction
, Display -> Attribute
_displayAttr :: Attribute
, 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
makeLensesNoSigs ''Display
defaultChar :: Lens' Display Char
orientationMap :: Lens' Display (Map AbsoluteDir Char)
curOrientation :: Lens' Display (Maybe Direction)
displayAttr :: Lens' Display Attribute
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 AbsoluteDir 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 AbsoluteDir Char)
orientationMap
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE forall a b. (a -> b) -> a -> b
$
Char
-> Map AbsoluteDir Char
-> Maybe Direction
-> Attribute
-> 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 AbsoluteDir 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
<*> (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 Attribute
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 Attribute
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 AbsoluteDir 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 AbsoluteDir 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 = forall a. a -> Maybe a -> a
fromMaybe (Display
disp forall s a. s -> Getting a s a -> a
^. Lens' Display Char
defaultChar) forall a b. (a -> b) -> a -> b
$ do
DAbsolute AbsoluteDir
d <- Display
disp forall s a. s -> Getting a s a -> a
^. Lens' Display (Maybe Direction)
curOrientation
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AbsoluteDir
d (Display
disp forall s a. s -> Getting a s a -> a
^. Lens' Display (Map AbsoluteDir Char)
orientationMap)
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 -> Attribute -> Display
defaultTerrainDisplay :: Char -> Attribute -> Display
defaultTerrainDisplay Char
c Attribute
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 Attribute
displayAttr forall s t a b. ASetter s t a b -> b -> s -> t
.~ Attribute
attr
defaultEntityDisplay :: Char -> Display
defaultEntityDisplay :: Char -> Display
defaultEntityDisplay Char
c =
Display
{ _defaultChar :: Char
_defaultChar = Char
c
, _orientationMap :: Map AbsoluteDir Char
_orientationMap = forall k a. Map k a
M.empty
, _curOrientation :: Maybe Direction
_curOrientation = forall a. Maybe a
Nothing
, _displayAttr :: Attribute
_displayAttr = Attribute
AEntity
, _displayPriority :: Priority
_displayPriority = Priority
1
, _invisible :: Bool
_invisible = Bool
False
}
defaultRobotDisplay :: Display
defaultRobotDisplay :: Display
defaultRobotDisplay =
Display
{ _defaultChar :: Char
_defaultChar = Char
'X'
, _orientationMap :: Map AbsoluteDir Char
_orientationMap =
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
[ (AbsoluteDir
DEast, Char
'>')
, (AbsoluteDir
DWest, Char
'<')
, (AbsoluteDir
DSouth, Char
'v')
, (AbsoluteDir
DNorth, Char
'^')
]
, _curOrientation :: Maybe Direction
_curOrientation = forall a. Maybe a
Nothing
, _displayAttr :: Attribute
_displayAttr = Attribute
ARobot
, _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