From 20bc4aa10dffcbcc42139afafa10aa5f7a5090bb Mon Sep 17 00:00:00 2001
From: Griffin Smith <grfn@gws.fyi>
Date: Sun, 28 Jun 2020 16:39:17 -0400
Subject: feat(xan): Add a Marker entity type

It's useful, when developing new level gen techniques, to be able to
specially mark certain areas of the map during devlopment. This adds a
Marker entity type, which renders as a red X on the map and provides a
programmable description when examined. In the future it'll probably be
nice to toggle markers on/off just like we do with revealAll, but for
now it'll be fine to just remove the code to render them like we do with
debug traces.

Change-Id: Ief5d090809a0a4cbcc28f90e4902a5e38d42eeb5
Reviewed-on: https://cl.tvl.fyi/c/depot/+/724
Reviewed-by: glittershark <grfn@gws.fyi>
---
 .../xanthous/src/Xanthous/Entities/Entities.hs     |  3 ++
 .../xanthous/src/Xanthous/Entities/Marker.hs       | 42 ++++++++++++++++++++++
 2 files changed, 45 insertions(+)
 create mode 100644 users/glittershark/xanthous/src/Xanthous/Entities/Marker.hs

diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs
index 62e6e15c98..a0c037a1b4 100644
--- a/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs
+++ b/users/glittershark/xanthous/src/Xanthous/Entities/Entities.hs
@@ -13,6 +13,7 @@ import           Xanthous.Entities.Character
 import           Xanthous.Entities.Item
 import           Xanthous.Entities.Creature
 import           Xanthous.Entities.Environment
+import           Xanthous.Entities.Marker
 import           Xanthous.Game.State
 import           Xanthous.Util.QuickCheck
 import           Data.Aeson.Generic.DerivingVia
@@ -27,6 +28,7 @@ instance Arbitrary SomeEntity where
     , SomeEntity <$> arbitrary @Door
     , SomeEntity <$> arbitrary @GroundMessage
     , SomeEntity <$> arbitrary @Staircase
+    , SomeEntity <$> arbitrary @Marker
     ]
 
 instance FromJSON SomeEntity where
@@ -40,6 +42,7 @@ instance FromJSON SomeEntity where
       "Door" -> SomeEntity @Door <$> obj .: "data"
       "GroundMessage" -> SomeEntity @GroundMessage <$> obj .: "data"
       "Staircase" -> SomeEntity @Staircase <$> obj .: "data"
+      "Marker" -> SomeEntity @Marker <$> obj .: "data"
       _ -> fail . unpack $ "Invalid entity type \"" <> entityType <> "\""
 
 deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameLevel
diff --git a/users/glittershark/xanthous/src/Xanthous/Entities/Marker.hs b/users/glittershark/xanthous/src/Xanthous/Entities/Marker.hs
new file mode 100644
index 0000000000..92969ec342
--- /dev/null
+++ b/users/glittershark/xanthous/src/Xanthous/Entities/Marker.hs
@@ -0,0 +1,42 @@
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Marker ( Marker(..) ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.Aeson
+import           Test.QuickCheck
+import qualified Graphics.Vty.Attributes as Vty
+import qualified Graphics.Vty.Image as Vty
+import           Brick.Widgets.Core (raw)
+--------------------------------------------------------------------------------
+import           Xanthous.Game.State
+import           Xanthous.Data.Entities (EntityAttributes(..))
+import           Xanthous.Data.EntityChar (style)
+--------------------------------------------------------------------------------
+
+-- | Mark on the map - for use in debugging / development only.
+newtype Marker = Marker Text
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Semigroup, Monoid, ToJSON, FromJSON, Arbitrary) via Text
+
+instance Brain Marker where step = brainVia Brainless
+
+instance Entity Marker where
+  entityAttributes = const EntityAttributes
+    { _blocksVision = False
+    , _blocksObject = False
+    , _collision = Stop
+    }
+  description (Marker m) = "[M] " <> m
+  entityChar = const $ "X" & style .~ markerStyle
+  entityCollision = const Nothing
+
+instance Draw Marker where
+  draw = const . raw $ Vty.char markerStyle 'X'
+  drawPriority = const maxBound
+
+markerStyle :: Vty.Attr
+markerStyle = Vty.defAttr
+  `Vty.withForeColor` Vty.red
+  `Vty.withBackColor` Vty.black
-- 
cgit 1.4.1