From 71b628c604556bc2d829f12980db99c9a526ec84 Mon Sep 17 00:00:00 2001
From: Griffin Smith <root@gws.fyi>
Date: Sat, 30 Nov 2019 19:55:43 -0500
Subject: Add messages on the ground

Add support for a "GroundMessage" entity type, support for a Read
command to read them, and randomly place an initial, tone-setting
tutorial message on the ground near the character at the beginning of
the game.
---
 src/Xanthous/Entities/Entities.hs    |  2 ++
 src/Xanthous/Entities/Environment.hs | 37 +++++++++++++++++++++++++++++-------
 2 files changed, 32 insertions(+), 7 deletions(-)

(limited to 'src/Xanthous/Entities')

diff --git a/src/Xanthous/Entities/Entities.hs b/src/Xanthous/Entities/Entities.hs
index 7e41fc8b7b3a..802aecddebdf 100644
--- a/src/Xanthous/Entities/Entities.hs
+++ b/src/Xanthous/Entities/Entities.hs
@@ -26,6 +26,7 @@ instance Arbitrary SomeEntity where
     , SomeEntity <$> arbitrary @Creature
     , SomeEntity <$> arbitrary @Wall
     , SomeEntity <$> arbitrary @Door
+    , SomeEntity <$> arbitrary @GroundMessage
     ]
 
 instance FromJSON SomeEntity where
@@ -37,6 +38,7 @@ instance FromJSON SomeEntity where
       "Creature" -> SomeEntity @Creature <$> obj .: "data"
       "Wall" -> SomeEntity @Wall <$> obj .: "data"
       "Door" -> SomeEntity @Door <$> obj .: "data"
+      "GroundMessage" -> SomeEntity @GroundMessage <$> obj .: "data"
       _ -> fail . unpack $ "Invalid entity type \"" <> entityType <> "\""
 
 deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState
diff --git a/src/Xanthous/Entities/Environment.hs b/src/Xanthous/Entities/Environment.hs
index 8baa07650f7c..0690e47e5441 100644
--- a/src/Xanthous/Entities/Environment.hs
+++ b/src/Xanthous/Entities/Environment.hs
@@ -1,22 +1,29 @@
 {-# LANGUAGE TemplateHaskell #-}
 module Xanthous.Entities.Environment
-  ( Wall(..)
+  (
+    -- * Walls
+    Wall(..)
+    -- * Doors
   , Door(..)
   , open
   , locked
+    -- * Messages
+  , GroundMessage(..)
   ) where
 --------------------------------------------------------------------------------
 import Xanthous.Prelude
+--------------------------------------------------------------------------------
 import Test.QuickCheck
-import Test.QuickCheck.Arbitrary.Generic
 import Brick (str)
 import Brick.Widgets.Border.Style (unicode)
 import Brick.Types (Edges(..))
 import Data.Aeson
+import Data.Aeson.Generic.DerivingVia
 --------------------------------------------------------------------------------
 import Xanthous.Entities.Draw.Util
 import Xanthous.Data
 import Xanthous.Game.State
+import Xanthous.Util.QuickCheck
 --------------------------------------------------------------------------------
 
 data Wall = Wall
@@ -31,7 +38,6 @@ instance FromJSON Wall where
     "Wall" -> pure Wall
     _      -> fail "Invalid Wall: expected Wall"
 
--- deriving via Brainless Wall instance Brain Wall
 instance Brain Wall where step = brainVia Brainless
 
 instance Entity Wall where
@@ -56,11 +62,9 @@ data Door = Door
   }
   deriving stock (Show, Eq, Ord, Generic)
   deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON)
+  deriving Arbitrary via GenericArbitrary Door
 makeLenses ''Door
 
-instance Arbitrary Door where
-  arbitrary = genericArbitrary
-
 instance Draw Door where
   drawWithNeighbors neighs door
     | door ^. open
@@ -77,10 +81,29 @@ instance Draw Door where
       horizDoor = '␣'
       vertDoor = '['
 
--- deriving via Brainless Door instance Brain Door
 instance Brain Door where step = brainVia Brainless
 
 instance Entity Door where
   blocksVision = not . view open
   description _ = "a door"
   entityChar _ = "d"
+
+--------------------------------------------------------------------------------
+
+newtype GroundMessage = GroundMessage Text
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary GroundMessage
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ 'TagSingleConstructors 'True
+                        , 'SumEnc 'ObjWithSingleField
+                        ]
+           GroundMessage
+  deriving Draw
+       via DrawStyledCharacter ('Just 'Yellow) 'Nothing "≈"
+           GroundMessage
+  deriving Entity
+       via DeriveEntity 'False "a message on the ground. Press r. to read it."
+                        "≈"
+           GroundMessage
+instance Brain GroundMessage where step = brainVia Brainless
-- 
cgit 1.4.1