{-# 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.Yaml
import GHC.Generics (Generic)
import Swarm.Language.Syntax (Direction (..))
import Swarm.TUI.Attr (entityAttr, robotAttr, worldPrefix)
import Swarm.Util (maxOn, (?))

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

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