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.

1 files changed, 55 insertions, 10 deletions

diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs
index 028688542a25..5ddb7de7e9b8 100644
--- a/src/Xanthous/Game/State.hs
+++ b/src/Xanthous/Game/State.hs
@@ -1,8 +1,8 @@
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE RecordWildCards      #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE TemplateHaskell     #-}
-{-# LANGUAGE GADTs               #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TemplateHaskell      #-}
+{-# LANGUAGE GADTs                #-}
+{-# LANGUAGE AllowAmbiguousTypes  #-}
 --------------------------------------------------------------------------------
 module Xanthous.Game.State
   ( GameState(..)
@@ -37,10 +37,14 @@ module Xanthous.Game.State
   , downcastEntity
   , _SomeEntity
   , entityIs
+    -- ** Vias
+  , Color(..)
+  , DrawNothing(..)
   , DrawRawChar(..)
   , DrawRawCharPriority(..)
   , DrawCharacter(..)
   , DrawStyledCharacter(..)
+  , DeriveEntity(..)
     -- ** Field classes
   , HasChar(..)
   , HasStyle(..)
@@ -63,7 +67,7 @@ import           Test.QuickCheck.Arbitrary.Generic
 import           Control.Monad.State.Class
 import           Control.Monad.State
 import           Control.Monad.Random.Class
-import           Brick (EventM, Widget, raw, str)
+import           Brick (EventM, Widget, raw, str, emptyWidget)
 import           Data.Aeson (ToJSON(..), FromJSON(..), Value(Null))
 import qualified Data.Aeson as JSON
 import           Data.Aeson.Generic.DerivingVia
@@ -71,6 +75,7 @@ import           Data.Generics.Product.Fields
 import qualified Graphics.Vty.Attributes as Vty
 import qualified Graphics.Vty.Image as Vty
 --------------------------------------------------------------------------------
+import           Xanthous.Util (KnownBool(..))
 import           Xanthous.Data
 import           Xanthous.Data.EntityMap (EntityMap, EntityID)
 import           Xanthous.Data.EntityChar
@@ -213,20 +218,29 @@ instance KnownColor 'Magenta where colorVal _ = Vty.magenta
 instance KnownColor 'Cyan where colorVal _ = Vty.cyan
 instance KnownColor 'White where colorVal _ = Vty.white
 
-newtype DrawStyledCharacter (fg :: Color) (bg :: Color) (char :: Symbol) (a :: Type) where
+class KnownMaybeColor (maybeColor :: Maybe Color) where
+  maybeColorVal :: forall proxy. proxy maybeColor -> Maybe Vty.Color
+
+instance KnownMaybeColor 'Nothing where maybeColorVal _ = Nothing
+instance KnownColor color => KnownMaybeColor ('Just color) where
+  maybeColorVal _ = Just $ colorVal @color Proxy
+
+newtype DrawStyledCharacter (fg :: Maybe Color) (bg :: Maybe Color) (char :: Symbol) (a :: Type) where
   DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a
 
 instance
-  ( KnownColor fg
-  , KnownColor bg
+  ( KnownMaybeColor fg
+  , KnownMaybeColor bg
   , KnownSymbol char
   )
   => Draw (DrawStyledCharacter fg bg char a) where
   draw _ = raw $ Vty.string attr $ symbolVal @char Proxy
     where attr = Vty.Attr
             { Vty.attrStyle = Vty.Default
-            , Vty.attrForeColor = Vty.SetTo $ colorVal @fg Proxy
-            , Vty.attrBackColor = Vty.SetTo $ colorVal @bg Proxy
+            , Vty.attrForeColor = maybe Vty.Default Vty.SetTo
+                                  $ maybeColorVal @fg Proxy
+            , Vty.attrBackColor = maybe Vty.Default Vty.SetTo
+                                  $ maybeColorVal @bg Proxy
             , Vty.attrURL = Vty.Default
             }
 
@@ -235,6 +249,12 @@ instance Draw EntityChar where
 
 --------------------------------------------------------------------------------
 
+newtype DrawNothing (a :: Type) = DrawNothing a
+
+instance Draw (DrawNothing a) where
+  draw = const emptyWidget
+  drawPriority = const 0
+
 newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a
 
 instance
@@ -336,6 +356,31 @@ entityIs = isJust . downcastEntity @a
 _SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a
 _SomeEntity = prism' SomeEntity downcastEntity
 
+newtype DeriveEntity
+  (blocksVision :: Bool)
+  (description :: Symbol)
+  (entityChar :: Symbol)
+  (entity :: Type)
+  = DeriveEntity entity
+  deriving newtype (Show, Eq, Ord, NFData, ToJSON, FromJSON, Draw)
+
+instance Brain entity => Brain (DeriveEntity b d c entity) where
+  step = brainVia $ \(DeriveEntity e) -> e
+
+instance
+  ( KnownBool blocksVision
+  , KnownSymbol description
+  , KnownSymbol entityChar
+  , Show entity, Eq entity, Ord entity, NFData entity
+  , ToJSON entity, FromJSON entity
+  , Draw entity, Brain entity
+  )
+  => Entity (DeriveEntity blocksVision description entityChar entity) where
+
+  blocksVision _ = boolVal @blocksVision
+  description _ = pack . symbolVal $ Proxy @description
+  entityChar _ = fromString . symbolVal $ Proxy @entityChar
+
 --------------------------------------------------------------------------------
 
 data DebugState = DebugState