{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- Orphan Hashable instances needed to derive Hashable Display

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Utilities for describing how to display in-game entities in the TUI.
module Swarm.Game.Display (
  -- * The display record
  Priority,
  Attribute (..),
  Display,

  -- ** Fields
  defaultChar,
  orientationMap,
  curOrientation,
  displayAttr,
  displayPriority,
  invisible,

  -- ** Rendering
  displayChar,
  hidden,

  -- ** Construction
  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)

-- | Display priority.  Entities with higher priority will be drawn on
--   top of entities with lower priority.
type Priority = Int

-- | An internal attribute name.
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

-- | A record explaining how to display an entity in the TUI.
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

-- | The default character to use for display.
defaultChar :: Lens' Display Char

-- | For robots or other entities that have an orientation, this map
--   optionally associates different display characters with
--   different orientations.  If an orientation is not in the map,
--   the 'defaultChar' will be used.
orientationMap :: Lens' Display (Map AbsoluteDir Char)

-- | The display caches the current orientation of the entity, so we
--   know which character to use from the orientation map.
curOrientation :: Lens' Display (Maybe Direction)

-- | The attribute to use for display.
displayAttr :: Lens' Display Attribute

-- | This entity's display priority. Higher priorities are drawn
--   on top of lower.
displayPriority :: Lens' Display Priority

-- | Whether the entity is currently invisible.
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]

-- | Look up the character that should be used for a display.
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)

-- | Modify a display to use a @?@ character for entities that are
--   hidden/unknown.
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)

-- | The default way to display some terrain using the given character
--   and attribute, with priority 0.
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

-- | Construct a default display for an entity that uses only a single
--   display character, the default entity attribute, and priority 1.
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
    }

-- | Construct a default robot display for a given orientation, with
--   display characters @"X^>v<"@, the default robot attribute, and
--   priority 10.
--
--   Note that the 'defaultChar' is used for direction 'DDown'
--   and is overridden for the special base robot.
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