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

-- Orphan Hashable instances needed to derive Hashable Display

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

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

  -- ** Rendering
  displayChar,
  hidden,

  -- ** Neighbor-based boundary rendering
  getBoundaryDisplay,

  -- ** Construction
  defaultTerrainDisplay,
  defaultEntityDisplay,
  defaultRobotDisplay,
) where

import Control.Applicative ((<|>))
import Control.Lens hiding (Const, from, (.=))
import Control.Monad (when)
import Data.Hashable (Hashable)
import Data.List.Extra (enumerate)
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 Graphics.Text.Width
import Swarm.Language.Syntax.Direction (AbsoluteDir (..), Direction (..))
import Swarm.Util (applyWhen, maxOn, quote)
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
  deriving (Attribute -> Attribute -> Bool
(Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool) -> Eq Attribute
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Attribute -> Attribute -> Bool
== :: Attribute -> Attribute -> Bool
$c/= :: Attribute -> Attribute -> Bool
/= :: Attribute -> Attribute -> Bool
Eq, Eq Attribute
Eq Attribute =>
(Attribute -> Attribute -> Ordering)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Bool)
-> (Attribute -> Attribute -> Attribute)
-> (Attribute -> Attribute -> Attribute)
-> Ord 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
$ccompare :: Attribute -> Attribute -> Ordering
compare :: Attribute -> Attribute -> Ordering
$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
>= :: Attribute -> Attribute -> Bool
$cmax :: Attribute -> Attribute -> Attribute
max :: Attribute -> Attribute -> Attribute
$cmin :: Attribute -> Attribute -> Attribute
min :: Attribute -> Attribute -> Attribute
Ord, Priority -> Attribute -> ShowS
[Attribute] -> ShowS
Attribute -> String
(Priority -> Attribute -> ShowS)
-> (Attribute -> String)
-> ([Attribute] -> ShowS)
-> Show Attribute
forall a.
(Priority -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Priority -> Attribute -> ShowS
showsPrec :: Priority -> Attribute -> ShowS
$cshow :: Attribute -> String
show :: Attribute -> String
$cshowList :: [Attribute] -> ShowS
showList :: [Attribute] -> ShowS
Show, (forall x. Attribute -> Rep Attribute x)
-> (forall x. Rep Attribute x -> Attribute) -> Generic Attribute
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
$cfrom :: forall x. Attribute -> Rep Attribute x
from :: forall x. Attribute -> Rep Attribute x
$cto :: forall x. Rep Attribute x -> Attribute
to :: forall x. Rep Attribute x -> Attribute
Generic, Eq Attribute
Eq Attribute =>
(Priority -> Attribute -> Priority)
-> (Attribute -> Priority) -> Hashable Attribute
Priority -> Attribute -> Priority
Attribute -> Priority
forall a.
Eq a =>
(Priority -> a -> Priority) -> (a -> Priority) -> Hashable a
$chashWithSalt :: Priority -> Attribute -> Priority
hashWithSalt :: Priority -> Attribute -> Priority
$chash :: Attribute -> Priority
hash :: Attribute -> Priority
Hashable)

readAttribute :: Text -> Attribute
readAttribute :: Text -> Attribute
readAttribute = \case
  Text
"robot" -> Attribute
ARobot
  Text
"entity" -> Attribute
AEntity
  Text
"default" -> Attribute
ADefault
  Text
w -> Text -> Attribute
AWorld Text
w

instance FromJSON Attribute where
  parseJSON :: Value -> Parser Attribute
parseJSON = String -> (Text -> Parser Attribute) -> Value -> Parser Attribute
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"attribute" ((Text -> Parser Attribute) -> Value -> Parser Attribute)
-> (Text -> Parser Attribute) -> Value -> Parser Attribute
forall a b. (a -> b) -> a -> b
$ Attribute -> Parser Attribute
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Attribute -> Parser Attribute)
-> (Text -> Attribute) -> Text -> Parser Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Attribute
readAttribute

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

data ChildInheritance
  = Invisible
  | Inherit
  | DefaultDisplay
  deriving (ChildInheritance -> ChildInheritance -> Bool
(ChildInheritance -> ChildInheritance -> Bool)
-> (ChildInheritance -> ChildInheritance -> Bool)
-> Eq ChildInheritance
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ChildInheritance -> ChildInheritance -> Bool
== :: ChildInheritance -> ChildInheritance -> Bool
$c/= :: ChildInheritance -> ChildInheritance -> Bool
/= :: ChildInheritance -> ChildInheritance -> Bool
Eq, Eq ChildInheritance
Eq ChildInheritance =>
(ChildInheritance -> ChildInheritance -> Ordering)
-> (ChildInheritance -> ChildInheritance -> Bool)
-> (ChildInheritance -> ChildInheritance -> Bool)
-> (ChildInheritance -> ChildInheritance -> Bool)
-> (ChildInheritance -> ChildInheritance -> Bool)
-> (ChildInheritance -> ChildInheritance -> ChildInheritance)
-> (ChildInheritance -> ChildInheritance -> ChildInheritance)
-> Ord ChildInheritance
ChildInheritance -> ChildInheritance -> Bool
ChildInheritance -> ChildInheritance -> Ordering
ChildInheritance -> ChildInheritance -> ChildInheritance
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
$ccompare :: ChildInheritance -> ChildInheritance -> Ordering
compare :: ChildInheritance -> ChildInheritance -> Ordering
$c< :: ChildInheritance -> ChildInheritance -> Bool
< :: ChildInheritance -> ChildInheritance -> Bool
$c<= :: ChildInheritance -> ChildInheritance -> Bool
<= :: ChildInheritance -> ChildInheritance -> Bool
$c> :: ChildInheritance -> ChildInheritance -> Bool
> :: ChildInheritance -> ChildInheritance -> Bool
$c>= :: ChildInheritance -> ChildInheritance -> Bool
>= :: ChildInheritance -> ChildInheritance -> Bool
$cmax :: ChildInheritance -> ChildInheritance -> ChildInheritance
max :: ChildInheritance -> ChildInheritance -> ChildInheritance
$cmin :: ChildInheritance -> ChildInheritance -> ChildInheritance
min :: ChildInheritance -> ChildInheritance -> ChildInheritance
Ord, Priority -> ChildInheritance -> ShowS
[ChildInheritance] -> ShowS
ChildInheritance -> String
(Priority -> ChildInheritance -> ShowS)
-> (ChildInheritance -> String)
-> ([ChildInheritance] -> ShowS)
-> Show ChildInheritance
forall a.
(Priority -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Priority -> ChildInheritance -> ShowS
showsPrec :: Priority -> ChildInheritance -> ShowS
$cshow :: ChildInheritance -> String
show :: ChildInheritance -> String
$cshowList :: [ChildInheritance] -> ShowS
showList :: [ChildInheritance] -> ShowS
Show, (forall x. ChildInheritance -> Rep ChildInheritance x)
-> (forall x. Rep ChildInheritance x -> ChildInheritance)
-> Generic ChildInheritance
forall x. Rep ChildInheritance x -> ChildInheritance
forall x. ChildInheritance -> Rep ChildInheritance x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ChildInheritance -> Rep ChildInheritance x
from :: forall x. ChildInheritance -> Rep ChildInheritance x
$cto :: forall x. Rep ChildInheritance x -> ChildInheritance
to :: forall x. Rep ChildInheritance x -> ChildInheritance
Generic, Eq ChildInheritance
Eq ChildInheritance =>
(Priority -> ChildInheritance -> Priority)
-> (ChildInheritance -> Priority) -> Hashable ChildInheritance
Priority -> ChildInheritance -> Priority
ChildInheritance -> Priority
forall a.
Eq a =>
(Priority -> a -> Priority) -> (a -> Priority) -> Hashable a
$chashWithSalt :: Priority -> ChildInheritance -> Priority
hashWithSalt :: Priority -> ChildInheritance -> Priority
$chash :: ChildInheritance -> Priority
hash :: ChildInheritance -> Priority
Hashable)

-- | 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 -> Maybe Char
_boundaryOverride :: Maybe Char
  , Display -> Attribute
_displayAttr :: Attribute
  , Display -> Priority
_displayPriority :: Priority
  , Display -> Bool
_invisible :: Bool
  , Display -> ChildInheritance
_childInheritance :: ChildInheritance
  }
  deriving (Display -> Display -> Bool
(Display -> Display -> Bool)
-> (Display -> Display -> Bool) -> Eq Display
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Display -> Display -> Bool
== :: Display -> Display -> Bool
$c/= :: Display -> Display -> Bool
/= :: Display -> Display -> Bool
Eq, Eq Display
Eq Display =>
(Display -> Display -> Ordering)
-> (Display -> Display -> Bool)
-> (Display -> Display -> Bool)
-> (Display -> Display -> Bool)
-> (Display -> Display -> Bool)
-> (Display -> Display -> Display)
-> (Display -> Display -> Display)
-> Ord 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
$ccompare :: Display -> Display -> Ordering
compare :: Display -> Display -> Ordering
$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
>= :: Display -> Display -> Bool
$cmax :: Display -> Display -> Display
max :: Display -> Display -> Display
$cmin :: Display -> Display -> Display
min :: Display -> Display -> Display
Ord, Priority -> Display -> ShowS
[Display] -> ShowS
Display -> String
(Priority -> Display -> ShowS)
-> (Display -> String) -> ([Display] -> ShowS) -> Show Display
forall a.
(Priority -> a -> ShowS)
-> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Priority -> Display -> ShowS
showsPrec :: Priority -> Display -> ShowS
$cshow :: Display -> String
show :: Display -> String
$cshowList :: [Display] -> ShowS
showList :: [Display] -> ShowS
Show, (forall x. Display -> Rep Display x)
-> (forall x. Rep Display x -> Display) -> Generic Display
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
$cfrom :: forall x. Display -> Rep Display x
from :: forall x. Display -> Rep Display x
$cto :: forall x. Rep Display x -> Display
to :: forall x. Rep Display x -> Display
Generic, Eq Display
Eq Display =>
(Priority -> Display -> Priority)
-> (Display -> Priority) -> Hashable Display
Priority -> Display -> Priority
Display -> Priority
forall a.
Eq a =>
(Priority -> a -> Priority) -> (a -> Priority) -> Hashable a
$chashWithSalt :: Priority -> Display -> Priority
hashWithSalt :: Priority -> Display -> Priority
$chash :: Display -> Priority
hash :: 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 = (Display -> Priority) -> Display -> Display -> Display
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 display character to substitute when neighbor boundaries are present
boundaryOverride :: Lens' Display (Maybe Char)

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

-- | For robots, whether children of this inherit the parent's display
childInheritance :: Lens' Display ChildInheritance

instance FromJSON Display where
  parseJSON :: Value -> Parser Display
parseJSON Value
v = With Display Parser Display -> Display -> Parser Display
forall e (f :: * -> *) a. With e f a -> e -> f a
runE (Value -> With Display Parser Display
forall e a. FromJSONE e a => Value -> ParserE e a
parseJSONE Value
v) (Char -> Display
defaultEntityDisplay Char
' ')

instance FromJSONE Display Display where
  parseJSONE :: Value -> With Display Parser Display
parseJSONE = String
-> (Object -> With Display Parser Display)
-> Value
-> With Display Parser Display
forall e a.
String -> (Object -> ParserE e a) -> Value -> ParserE e a
withObjectE String
"Display" ((Object -> With Display Parser Display)
 -> Value -> With Display Parser Display)
-> (Object -> With Display Parser Display)
-> Value
-> With Display Parser Display
forall a b. (a -> b) -> a -> b
$ \Object
v -> do
    Display
defD <- With Display Parser Display
forall (f :: * -> *) e. Monad f => With e f e
getE
    Maybe Char
mc <- Parser (Maybe Char) -> With Display Parser (Maybe Char)
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Parser (Maybe Char) -> With Display Parser (Maybe Char))
-> Parser (Maybe Char) -> With Display Parser (Maybe Char)
forall a b. (a -> b) -> a -> b
$ Object
v Object -> Key -> Parser (Maybe Char)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"char"

    let c :: Char
c = Char -> Maybe Char -> Char
forall a. a -> Maybe a -> a
fromMaybe (Display
defD Display -> Getting Char Display Char -> Char
forall s a. s -> Getting a s a -> a
^. Getting Char Display Char
Lens' Display Char
defaultChar) Maybe Char
mc
    Char -> With Display Parser ()
forall {f :: * -> *}. MonadFail f => Char -> f ()
validateChar Char
c

    let dOM :: Map AbsoluteDir Char
dOM = if Maybe Char -> Bool
forall a. Maybe a -> Bool
isJust Maybe Char
mc then Map AbsoluteDir Char
forall a. Monoid a => a
mempty else Display
defD Display
-> Getting (Map AbsoluteDir Char) Display (Map AbsoluteDir Char)
-> Map AbsoluteDir Char
forall s a. s -> Getting a s a -> a
^. Getting (Map AbsoluteDir Char) Display (Map AbsoluteDir Char)
Lens' Display (Map AbsoluteDir Char)
orientationMap
    (Char -> With Display Parser ())
-> String -> With Display Parser ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Char -> With Display Parser ()
forall {f :: * -> *}. MonadFail f => Char -> f ()
validateChar (String -> With Display Parser ())
-> String -> With Display Parser ()
forall a b. (a -> b) -> a -> b
$ Map AbsoluteDir Char -> String
forall k a. Map k a -> [a]
M.elems Map AbsoluteDir Char
dOM

    Parser Display -> With Display Parser Display
forall (f :: * -> *) a e. Functor f => f a -> With e f a
liftE (Parser Display -> With Display Parser Display)
-> Parser Display -> With Display Parser Display
forall a b. (a -> b) -> a -> b
$ do
      let _defaultChar :: Char
_defaultChar = Char
c
          _boundaryOverride :: Maybe a
_boundaryOverride = Maybe a
forall a. Maybe a
Nothing
      Map AbsoluteDir Char
_orientationMap <- Object
v Object -> Key -> Parser (Maybe (Map AbsoluteDir Char))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"orientationMap" Parser (Maybe (Map AbsoluteDir Char))
-> Map AbsoluteDir Char -> Parser (Map AbsoluteDir Char)
forall a. Parser (Maybe a) -> a -> Parser a
.!= Map AbsoluteDir Char
dOM
      Maybe Direction
_curOrientation <- Object
v Object -> Key -> Parser (Maybe (Maybe Direction))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"curOrientation" Parser (Maybe (Maybe Direction))
-> Maybe Direction -> Parser (Maybe Direction)
forall a. Parser (Maybe a) -> a -> Parser a
.!= (Display
defD Display
-> Getting (Maybe Direction) Display (Maybe Direction)
-> Maybe Direction
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Direction) Display (Maybe Direction)
Lens' Display (Maybe Direction)
curOrientation)
      Attribute
_displayAttr <- (Object
v Object -> Key -> Parser (Maybe Attribute)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"attr") Parser (Maybe Attribute) -> Attribute -> Parser Attribute
forall a. Parser (Maybe a) -> a -> Parser a
.!= (Display
defD Display -> Getting Attribute Display Attribute -> Attribute
forall s a. s -> Getting a s a -> a
^. Getting Attribute Display Attribute
Lens' Display Attribute
displayAttr)
      Priority
_displayPriority <- Object
v Object -> Key -> Parser (Maybe Priority)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"priority" Parser (Maybe Priority) -> Priority -> Parser Priority
forall a. Parser (Maybe a) -> a -> Parser a
.!= (Display
defD Display -> Getting Priority Display Priority -> Priority
forall s a. s -> Getting a s a -> a
^. Getting Priority Display Priority
Lens' Display Priority
displayPriority)
      Bool
_invisible <- Object
v Object -> Key -> Parser (Maybe Bool)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"invisible" Parser (Maybe Bool) -> Bool -> Parser Bool
forall a. Parser (Maybe a) -> a -> Parser a
.!= (Display
defD Display -> Getting Bool Display Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Display Bool
Lens' Display Bool
invisible)
      let _childInheritance :: ChildInheritance
_childInheritance = ChildInheritance
Inherit
      Display -> Parser Display
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Display {Bool
Char
Priority
Maybe Char
Maybe Direction
Map AbsoluteDir Char
ChildInheritance
Attribute
forall a. Maybe a
_defaultChar :: Char
_orientationMap :: Map AbsoluteDir Char
_curOrientation :: Maybe Direction
_boundaryOverride :: Maybe Char
_displayAttr :: Attribute
_displayPriority :: Priority
_invisible :: Bool
_childInheritance :: ChildInheritance
_defaultChar :: Char
_boundaryOverride :: forall a. Maybe a
_orientationMap :: Map AbsoluteDir Char
_curOrientation :: Maybe Direction
_displayAttr :: Attribute
_displayPriority :: Priority
_invisible :: Bool
_childInheritance :: ChildInheritance
..}
   where
    validateChar :: Char -> f ()
validateChar Char
c =
      Bool -> f () -> f ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Priority
charWidth Priority -> Priority -> Bool
forall a. Ord a => a -> a -> Bool
> Priority
1)
        (f () -> f ()) -> (Text -> f ()) -> Text -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> f ()
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
        (String -> f ()) -> (Text -> String) -> Text -> f ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
        (Text -> f ()) -> Text -> f ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unwords
          [ Text
"Character"
          , Text -> Text
quote (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Char -> Text
T.singleton Char
c
          , Text
"is too wide:"
          , String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Priority -> String
forall a. Show a => a -> String
show Priority
charWidth
          ]
     where
      charWidth :: Priority
charWidth = Char -> Priority
safeWcwidth Char
c

instance ToJSON Display where
  toJSON :: Display -> Value
toJSON Display
d =
    [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$
      [ Key
"char" Key -> Char -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Display
d Display -> Getting Char Display Char -> Char
forall s a. s -> Getting a s a -> a
^. Getting Char Display Char
Lens' Display Char
defaultChar)
      , Key
"attr" Key -> Attribute -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Display
d Display -> Getting Attribute Display Attribute -> Attribute
forall s a. s -> Getting a s a -> a
^. Getting Attribute Display Attribute
Lens' Display Attribute
displayAttr)
      ]
        [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Key
"priority" Key -> Priority -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Display
d Display -> Getting Priority Display Priority -> Priority
forall s a. s -> Getting a s a -> a
^. Getting Priority Display Priority
Lens' Display Priority
displayPriority) | (Display
d Display -> Getting Priority Display Priority -> Priority
forall s a. s -> Getting a s a -> a
^. Getting Priority Display Priority
Lens' Display Priority
displayPriority) Priority -> Priority -> Bool
forall a. Eq a => a -> a -> Bool
/= (Char -> Display
defaultEntityDisplay Char
' ' Display -> Getting Priority Display Priority -> Priority
forall s a. s -> Getting a s a -> a
^. Getting Priority Display Priority
Lens' Display Priority
displayPriority)]
        [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Key
"orientationMap" Key -> Map AbsoluteDir Char -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Display
d Display
-> Getting (Map AbsoluteDir Char) Display (Map AbsoluteDir Char)
-> Map AbsoluteDir Char
forall s a. s -> Getting a s a -> a
^. Getting (Map AbsoluteDir Char) Display (Map AbsoluteDir Char)
Lens' Display (Map AbsoluteDir Char)
orientationMap) | Bool -> Bool
not (Map AbsoluteDir Char -> Bool
forall k a. Map k a -> Bool
M.null (Display
d Display
-> Getting (Map AbsoluteDir Char) Display (Map AbsoluteDir Char)
-> Map AbsoluteDir Char
forall s a. s -> Getting a s a -> a
^. Getting (Map AbsoluteDir Char) Display (Map AbsoluteDir Char)
Lens' Display (Map AbsoluteDir Char)
orientationMap))]
        [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Key
"invisible" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Display
d Display -> Getting Bool Display Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Display Bool
Lens' Display Bool
invisible) | Display
d Display -> Getting Bool Display Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Display Bool
Lens' Display Bool
invisible]

-- | Look up the character that should be used for a display.
displayChar :: Display -> Char
displayChar :: Display -> Char
displayChar Display
disp =
  Char -> Maybe Char -> Char
forall a. a -> Maybe a -> a
fromMaybe (Display
disp Display -> Getting Char Display Char -> Char
forall s a. s -> Getting a s a -> a
^. Getting Char Display Char
Lens' Display Char
defaultChar) (Maybe Char -> Char) -> Maybe Char -> Char
forall a b. (a -> b) -> a -> b
$
    Display
disp Display -> Getting (Maybe Char) Display (Maybe Char) -> Maybe Char
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Char) Display (Maybe Char)
Lens' Display (Maybe Char)
boundaryOverride Maybe Char -> Maybe Char -> Maybe Char
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> do
      DAbsolute AbsoluteDir
d <- Display
disp Display
-> Getting (Maybe Direction) Display (Maybe Direction)
-> Maybe Direction
forall s a. s -> Getting a s a -> a
^. Getting (Maybe Direction) Display (Maybe Direction)
Lens' Display (Maybe Direction)
curOrientation
      AbsoluteDir -> Map AbsoluteDir Char -> Maybe Char
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup AbsoluteDir
d (Display
disp Display
-> Getting (Map AbsoluteDir Char) Display (Map AbsoluteDir Char)
-> Map AbsoluteDir Char
forall s a. s -> Getting a s a -> a
^. Getting (Map AbsoluteDir Char) Display (Map AbsoluteDir Char)
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 = ((Char -> Identity Char) -> Display -> Identity Display
Lens' Display Char
defaultChar ((Char -> Identity Char) -> Display -> Identity Display)
-> Char -> Display -> Display
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Char
'?') (Display -> Display) -> (Display -> Display) -> Display -> Display
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe Direction -> Identity (Maybe Direction))
-> Display -> Identity Display
Lens' Display (Maybe Direction)
curOrientation ((Maybe Direction -> Identity (Maybe Direction))
 -> Display -> Identity Display)
-> Maybe Direction -> Display -> Display
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Direction
forall a. Maybe a
Nothing)

-- | The default way to display some terrain using the given character
--   and attribute, with priority 0.
defaultTerrainDisplay :: Attribute -> Display
defaultTerrainDisplay :: Attribute -> Display
defaultTerrainDisplay Attribute
attr =
  Char -> Display
defaultEntityDisplay Char
' '
    Display -> (Display -> Display) -> Display
forall a b. a -> (a -> b) -> b
& (Priority -> Identity Priority) -> Display -> Identity Display
Lens' Display Priority
displayPriority ((Priority -> Identity Priority) -> Display -> Identity Display)
-> Priority -> Display -> Display
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Priority
0
    Display -> (Display -> Display) -> Display
forall a b. a -> (a -> b) -> b
& (Attribute -> Identity Attribute) -> Display -> Identity Display
Lens' Display Attribute
displayAttr ((Attribute -> Identity Attribute) -> Display -> Identity Display)
-> Attribute -> Display -> Display
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 = Map AbsoluteDir Char
forall k a. Map k a
M.empty
    , _curOrientation :: Maybe Direction
_curOrientation = Maybe Direction
forall a. Maybe a
Nothing
    , _boundaryOverride :: Maybe Char
_boundaryOverride = Maybe Char
forall a. Maybe a
Nothing
    , _displayAttr :: Attribute
_displayAttr = Attribute
AEntity
    , _displayPriority :: Priority
_displayPriority = Priority
1
    , _invisible :: Bool
_invisible = Bool
False
    , _childInheritance :: ChildInheritance
_childInheritance = ChildInheritance
Inherit
    }

-- | 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 =
        [(AbsoluteDir, Char)] -> Map AbsoluteDir Char
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
'^')
          ]
    , _boundaryOverride :: Maybe Char
_boundaryOverride = Maybe Char
forall a. Maybe a
Nothing
    , _curOrientation :: Maybe Direction
_curOrientation = Maybe Direction
forall a. Maybe a
Nothing
    , _displayAttr :: Attribute
_displayAttr = Attribute
ARobot
    , _displayPriority :: Priority
_displayPriority = Priority
10
    , _invisible :: Bool
_invisible = Bool
False
    , _childInheritance :: ChildInheritance
_childInheritance = ChildInheritance
Inherit
    }

instance Monoid Display where
  mempty :: Display
mempty = Char -> Display
defaultEntityDisplay Char
' ' Display -> (Display -> Display) -> Display
forall a b. a -> (a -> b) -> b
& (Bool -> Identity Bool) -> Display -> Identity Display
Lens' Display Bool
invisible ((Bool -> Identity Bool) -> Display -> Identity Display)
-> Bool -> Display -> Display
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Bool
True

-- * Boundary rendering

-- | This type is isomorphic to 'Bool' but
-- is more compact for readability of the
-- 'glyphForNeighbors' cases.
data Presence
  = -- | present
    X
  | -- | absent
    O

emptyNeighbors :: Neighbors Presence
emptyNeighbors :: Neighbors Presence
emptyNeighbors = Presence -> Presence -> Presence -> Presence -> Neighbors Presence
forall a. a -> a -> a -> a -> Neighbors a
Neighbors Presence
O Presence
O Presence
O Presence
O

data Neighbors a = Neighbors
  { forall a. Neighbors a -> a
e :: a
  , forall a. Neighbors a -> a
w :: a
  , forall a. Neighbors a -> a
n :: a
  , forall a. Neighbors a -> a
s :: a
  }

computeNeighborPresence :: (AbsoluteDir -> Bool) -> Neighbors Presence
computeNeighborPresence :: (AbsoluteDir -> Bool) -> Neighbors Presence
computeNeighborPresence AbsoluteDir -> Bool
checkPresence =
  (AbsoluteDir -> Neighbors Presence -> Neighbors Presence)
-> Neighbors Presence -> [AbsoluteDir] -> Neighbors Presence
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr AbsoluteDir -> Neighbors Presence -> Neighbors Presence
assignPresence Neighbors Presence
emptyNeighbors [AbsoluteDir]
forall a. (Enum a, Bounded a) => [a]
enumerate
 where
  assignPresence :: AbsoluteDir -> Neighbors Presence -> Neighbors Presence
assignPresence AbsoluteDir
d = Bool
-> (Neighbors Presence -> Neighbors Presence)
-> Neighbors Presence
-> Neighbors Presence
forall a. Bool -> (a -> a) -> a -> a
applyWhen (AbsoluteDir -> Bool
checkPresence AbsoluteDir
d) ((Neighbors Presence -> Neighbors Presence)
 -> Neighbors Presence -> Neighbors Presence)
-> (Neighbors Presence -> Neighbors Presence)
-> Neighbors Presence
-> Neighbors Presence
forall a b. (a -> b) -> a -> b
$ AbsoluteDir -> Presence -> Neighbors Presence -> Neighbors Presence
forall a. AbsoluteDir -> a -> Neighbors a -> Neighbors a
setNeighbor AbsoluteDir
d Presence
X

setNeighbor :: AbsoluteDir -> a -> Neighbors a -> Neighbors a
setNeighbor :: forall a. AbsoluteDir -> a -> Neighbors a -> Neighbors a
setNeighbor AbsoluteDir
DNorth a
x Neighbors a
y = Neighbors a
y {n = x}
setNeighbor AbsoluteDir
DSouth a
x Neighbors a
y = Neighbors a
y {s = x}
setNeighbor AbsoluteDir
DEast a
x Neighbors a
y = Neighbors a
y {e = x}
setNeighbor AbsoluteDir
DWest a
x Neighbors a
y = Neighbors a
y {w = x}

-- | For a center cell that itself is a boundary,
-- determine a glyph override for rendering, given certain
-- neighbor combinations.
glyphForNeighbors :: Neighbors Presence -> Maybe Char
glyphForNeighbors :: Neighbors Presence -> Maybe Char
glyphForNeighbors = \case
  Neighbors {e :: forall a. Neighbors a -> a
e = Presence
O, w :: forall a. Neighbors a -> a
w = Presence
O, n :: forall a. Neighbors a -> a
n = Presence
O, s :: forall a. Neighbors a -> a
s = Presence
O} -> Maybe Char
forall a. Maybe a
Nothing
  Neighbors {e :: forall a. Neighbors a -> a
e = Presence
X, w :: forall a. Neighbors a -> a
w = Presence
O, n :: forall a. Neighbors a -> a
n = Presence
O, s :: forall a. Neighbors a -> a
s = Presence
O} -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'╶'
  Neighbors {e :: forall a. Neighbors a -> a
e = Presence
O, w :: forall a. Neighbors a -> a
w = Presence
X, n :: forall a. Neighbors a -> a
n = Presence
O, s :: forall a. Neighbors a -> a
s = Presence
O} -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'╴'
  Neighbors {e :: forall a. Neighbors a -> a
e = Presence
X, w :: forall a. Neighbors a -> a
w = Presence
X, n :: forall a. Neighbors a -> a
n = Presence
O, s :: forall a. Neighbors a -> a
s = Presence
O} -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'─'
  Neighbors {e :: forall a. Neighbors a -> a
e = Presence
O, w :: forall a. Neighbors a -> a
w = Presence
O, n :: forall a. Neighbors a -> a
n = Presence
X, s :: forall a. Neighbors a -> a
s = Presence
O} -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'╵'
  Neighbors {e :: forall a. Neighbors a -> a
e = Presence
O, w :: forall a. Neighbors a -> a
w = Presence
O, n :: forall a. Neighbors a -> a
n = Presence
O, s :: forall a. Neighbors a -> a
s = Presence
X} -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'╷'
  Neighbors {e :: forall a. Neighbors a -> a
e = Presence
O, w :: forall a. Neighbors a -> a
w = Presence
O, n :: forall a. Neighbors a -> a
n = Presence
X, s :: forall a. Neighbors a -> a
s = Presence
X} -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'│'
  Neighbors {e :: forall a. Neighbors a -> a
e = Presence
X, w :: forall a. Neighbors a -> a
w = Presence
O, n :: forall a. Neighbors a -> a
n = Presence
X, s :: forall a. Neighbors a -> a
s = Presence
O} -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'└'
  Neighbors {e :: forall a. Neighbors a -> a
e = Presence
X, w :: forall a. Neighbors a -> a
w = Presence
O, n :: forall a. Neighbors a -> a
n = Presence
O, s :: forall a. Neighbors a -> a
s = Presence
X} -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'┌'
  Neighbors {e :: forall a. Neighbors a -> a
e = Presence
O, w :: forall a. Neighbors a -> a
w = Presence
X, n :: forall a. Neighbors a -> a
n = Presence
X, s :: forall a. Neighbors a -> a
s = Presence
O} -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'┘'
  Neighbors {e :: forall a. Neighbors a -> a
e = Presence
O, w :: forall a. Neighbors a -> a
w = Presence
X, n :: forall a. Neighbors a -> a
n = Presence
O, s :: forall a. Neighbors a -> a
s = Presence
X} -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'┐'
  Neighbors {e :: forall a. Neighbors a -> a
e = Presence
X, w :: forall a. Neighbors a -> a
w = Presence
X, n :: forall a. Neighbors a -> a
n = Presence
X, s :: forall a. Neighbors a -> a
s = Presence
O} -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'┴'
  Neighbors {e :: forall a. Neighbors a -> a
e = Presence
X, w :: forall a. Neighbors a -> a
w = Presence
X, n :: forall a. Neighbors a -> a
n = Presence
O, s :: forall a. Neighbors a -> a
s = Presence
X} -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'┬'
  Neighbors {e :: forall a. Neighbors a -> a
e = Presence
X, w :: forall a. Neighbors a -> a
w = Presence
O, n :: forall a. Neighbors a -> a
n = Presence
X, s :: forall a. Neighbors a -> a
s = Presence
X} -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'├'
  Neighbors {e :: forall a. Neighbors a -> a
e = Presence
O, w :: forall a. Neighbors a -> a
w = Presence
X, n :: forall a. Neighbors a -> a
n = Presence
X, s :: forall a. Neighbors a -> a
s = Presence
X} -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'┤'
  Neighbors {e :: forall a. Neighbors a -> a
e = Presence
X, w :: forall a. Neighbors a -> a
w = Presence
X, n :: forall a. Neighbors a -> a
n = Presence
X, s :: forall a. Neighbors a -> a
s = Presence
X} -> Char -> Maybe Char
forall a. a -> Maybe a
Just Char
'┼'

getBoundaryDisplay :: (AbsoluteDir -> Bool) -> Maybe Char
getBoundaryDisplay :: (AbsoluteDir -> Bool) -> Maybe Char
getBoundaryDisplay = Neighbors Presence -> Maybe Char
glyphForNeighbors (Neighbors Presence -> Maybe Char)
-> ((AbsoluteDir -> Bool) -> Neighbors Presence)
-> (AbsoluteDir -> Bool)
-> Maybe Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbsoluteDir -> Bool) -> Neighbors Presence
computeNeighborPresence