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

-- Orphan Hashable instances needed to derive Hashable Display

-- |
-- Module      :  Swarm.Game.Display
-- Copyright   :  Brent Yorgey
-- Maintainer  :  byorgey@gmail.com
--
-- 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,
  Display,

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

  -- ** Rendering
  displayChar,
  renderDisplay,
  hidden,

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

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

-- Some orphan instances we need to be able to derive a Hashable
-- instance for Display
instance Hashable AttrName

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

-- | 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 Direction 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 AttrName

-- | 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 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]

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

-- | Render a display as a UI widget.
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]

-- | 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 -> 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

-- | 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 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
    }

-- | 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 overriden for the special base robot.
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