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/Data/Aeson/Generic/DerivingVia.hs

@@ -73,10 +73,17 @@ data Setting = FieldLabelModifier     [StrFun]
 
 type FieldLabelModifier     = 'FieldLabelModifier
 type ConstructorTagModifier = 'ConstructorTagModifier
+-- | If 'True' the constructors of a datatype, with all nullary constructors,
+-- will be encoded to just a string with the constructor tag. If 'False' the
+-- encoding will always follow the 'SumEncoding'.
 type AllNullaryToStringTag  = 'AllNullaryToStringTag
 type OmitNothingFields      = 'OmitNothingFields
 type SumEnc                 = 'SumEnc
+-- | Hide the field name when a record constructor has only one field, like a
+-- newtype.
 type UnwrapUnaryRecords     = 'UnwrapUnaryRecords
+-- | Encode types with a single constructor as sums, so that
+-- 'AllNullaryToStringTag' and 'SumEncoding' apply.
 type TagSingleConstructors  = 'TagSingleConstructors
 
 class Demotable (a :: k) where

src/Xanthous/App.hs

@@ -44,7 +44,8 @@ import           Xanthous.Entities.Item (Item)
 import qualified Xanthous.Entities.Item as Item
 import           Xanthous.Entities.Creature (Creature)
 import qualified Xanthous.Entities.Creature as Creature
-import           Xanthous.Entities.Environment (Door, open, locked)
+import           Xanthous.Entities.Environment
+                 (Door, open, locked, GroundMessage(..))
 import           Xanthous.Entities.RawTypes (edible, eatMessage, hitpointsHealed)
 import           Xanthous.Generators
 import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
@@ -84,6 +85,7 @@ initLevel = do
   entities <>= (SomeEntity <$> level ^. levelWalls)
   entities <>= (SomeEntity <$> level ^. levelItems)
   entities <>= (SomeEntity <$> level ^. levelCreatures)
+  entities <>= (SomeEntity <$> level ^. levelTutorialMessage)
 
   characterPosition .= level ^. levelCharacterPosition
 
@@ -206,6 +208,29 @@ handleCommand Eat = do
   stepGame -- TODO
   continue
 
+handleCommand Read = do
+  -- TODO allow reading things in the inventory (combo direction+menu prompt?)
+  prompt_ @'DirectionPrompt ["read", "prompt"] Cancellable
+    $ \(DirectionResult dir) -> do
+      pos <- uses characterPosition $ move dir
+      uses entities
+        (fmap snd . entitiesAtPositionWithType @GroundMessage pos) >>= \case
+          Empty -> say_ ["read", "nothing"]
+          GroundMessage msg :< Empty ->
+            say ["read", "result"] $ object ["message" A..= msg]
+          msgs ->
+            let readAndContinue Empty = pure ()
+                readAndContinue (msg :< msgs') =
+                  prompt @'Continue
+                    ["read", "result"]
+                    (object ["message" A..= msg])
+                    Cancellable
+                  . const
+                  $ readAndContinue msgs'
+                readAndContinue _ = error "this is total"
+            in readAndContinue msgs
+  continue
+
 handleCommand Save = do
   -- TODO default save locations / config file?
   prompt_ @'StringPrompt ["save", "location"] Cancellable
@@ -413,3 +438,5 @@ entityMenu_ = mkMenuItems @[_] . map entityMenuItem
 
 -- entityMenu :: Entity entity => [entity] -> Map Char (MenuOption entity)
 -- entityMenu = map (map runIdentity) . entityMenu_ . fmap Identity
+
+--------------------------------------------------------------------------------

src/Xanthous/Command.hs

@@ -19,6 +19,7 @@ data Command
   | Eat
   | Look
   | Save
+  | Read
 
     -- | TODO replace with `:` commands
   | ToggleRevealAll
@@ -33,6 +34,7 @@ commandFromKey (KChar 'o') [] = Just Open
 commandFromKey (KChar ';') [] = Just Look
 commandFromKey (KChar 'e') [] = Just Eat
 commandFromKey (KChar 'S') [] = Just Save
+commandFromKey (KChar 'r') [] = Just Read
 
 commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll
 

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

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

src/Xanthous/Game/Lenses.hs

@@ -25,7 +25,7 @@ import           Xanthous.Data
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Data.EntityMap.Graphics (visiblePositions)
 import           Xanthous.Entities.Character (Character, mkCharacter)
-import           Xanthous.Entities.Environment (Door, open)
+import           Xanthous.Entities.Environment (Door, open, GroundMessage)
 import           Xanthous.Entities.Item (Item)
 import           Xanthous.Entities.Creature (Creature)
 import           Xanthous.Entities.Entities ()
@@ -105,8 +105,12 @@ entityCollision
   -> Maybe Collision
 entityCollision Empty = Nothing
 entityCollision ents
+  -- TODO track entity collision in the Entity class
   | any (entityIs @Creature) ents = pure Combat
-  | all (entityIs @Item) ents = Nothing
+  | all (\e ->
+          entityIs @Item e
+        || entityIs @GroundMessage e
+        ) ents = Nothing
   | doors@(_ : _) <- ents ^.. folded . _SomeEntity @Door
   , all (view open) doors = Nothing
   | otherwise = pure Stop

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

src/Xanthous/Generators.hs

@@ -14,6 +14,7 @@ module Xanthous.Generators
   , levelItems
   , levelCreatures
   , levelCharacterPosition
+  , levelTutorialMessage
   , generateLevel
   ) where
 --------------------------------------------------------------------------------
@@ -91,6 +92,7 @@ data Level = Level
   { _levelWalls             :: !(EntityMap Wall)
   , _levelItems             :: !(EntityMap Item)
   , _levelCreatures         :: !(EntityMap Creature)
+  , _levelTutorialMessage   :: !(EntityMap GroundMessage)
   , _levelCharacterPosition :: !Position
   }
 makeLenses ''Level
@@ -103,4 +105,5 @@ generateLevel gen ps dims = do
   _levelItems <- randomItems cells
   _levelCreatures <- randomCreatures cells
   _levelCharacterPosition <- chooseCharacterPosition cells
+  _levelTutorialMessage <- tutorialMessage cells _levelCharacterPosition
   pure Level {..}

src/Xanthous/Generators/LevelContents.hs

@@ -3,22 +3,26 @@ module Xanthous.Generators.LevelContents
   ( chooseCharacterPosition
   , randomItems
   , randomCreatures
+  , tutorialMessage
   ) where
 --------------------------------------------------------------------------------
 import           Xanthous.Prelude
 --------------------------------------------------------------------------------
 import           Control.Monad.Random
-import           Data.Array.IArray (amap, bounds, rangeSize)
+import           Data.Array.IArray (amap, bounds, rangeSize, (!))
 --------------------------------------------------------------------------------
 import           Xanthous.Generators.Util
 import           Xanthous.Random
-import           Xanthous.Data (Position, positionFromPair)
+import           Xanthous.Data (Position, _Position, positionFromPair)
 import           Xanthous.Data.EntityMap (EntityMap, _EntityMap)
 import           Xanthous.Entities.Raws (rawsWithType, RawType)
 import qualified Xanthous.Entities.Item as Item
 import           Xanthous.Entities.Item (Item)
 import qualified Xanthous.Entities.Creature as Creature
 import           Xanthous.Entities.Creature (Creature)
+import           Xanthous.Entities.Environment (GroundMessage(..))
+import           Xanthous.Messages (message_)
+import           Xanthous.Util.Graphics (circle)
 --------------------------------------------------------------------------------
 
 chooseCharacterPosition :: MonadRandom m => Cells -> m Position
@@ -30,6 +34,24 @@ randomItems = randomEntities Item.newWithType (0.0004, 0.001)
 randomCreatures :: MonadRandom m => Cells -> m (EntityMap Creature)
 randomCreatures = randomEntities Creature.newWithType (0.0007, 0.003)
 
+tutorialMessage :: MonadRandom m
+  => Cells
+  -> Position -- ^ CharacterPosition
+  -> m (EntityMap GroundMessage)
+tutorialMessage cells characterPosition = do
+  let distance = 2
+  pos <- fmap (fromMaybe (error "No valid positions for tutorial message?"))
+        . choose . ChooseElement
+        $ accessiblePositionsWithin distance cells characterPosition
+  msg <- message_ ["tutorial", "message1"]
+  pure $ _EntityMap # [(pos, GroundMessage msg)]
+  where
+    accessiblePositionsWithin :: Int -> Cells -> Position -> [Position]
+    accessiblePositionsWithin dist valid pos =
+      review _Position
+      <$> filter (\(px, py) -> not $ valid ! (fromIntegral px, fromIntegral py))
+          (circle (pos ^. _Position) dist)
+
 randomEntities
   :: forall entity raw m. (MonadRandom m, RawType raw)
   => (raw -> entity)
@@ -41,7 +63,8 @@ randomEntities newWithType sizeRange cells =
     Nothing -> pure mempty
     Just raws -> do
       let len = rangeSize $ bounds cells
-      (numEntities :: Int) <- floor . (* fromIntegral len) <$> getRandomR sizeRange
+      (numEntities :: Int) <-
+        floor . (* fromIntegral len) <$> getRandomR sizeRange
       entities <- for [0..numEntities] $ const $ do
         pos <- randomPosition cells
         raw <- choose raws

src/Xanthous/Messages.hs

@@ -11,23 +11,25 @@ module Xanthous.Messages
   , render
   , lookup
   , message
+  , message_
   ) where
 --------------------------------------------------------------------------------
 import Xanthous.Prelude hiding (lookup)
 --------------------------------------------------------------------------------
-import Control.Monad.Random.Class (MonadRandom)
-import Data.Aeson (FromJSON, ToJSON, toJSON)
-import Data.Aeson.Generic.DerivingVia
-import Data.FileEmbed
-import Data.List.NonEmpty
-import Test.QuickCheck hiding (choose)
-import Test.QuickCheck.Arbitrary.Generic
-import Test.QuickCheck.Instances.UnorderedContainers ()
-import Text.Mustache
+import           Control.Monad.Random.Class (MonadRandom)
+import           Data.Aeson (FromJSON, ToJSON, toJSON)
+import qualified Data.Aeson as JSON
+import           Data.Aeson.Generic.DerivingVia
+import           Data.FileEmbed
+import           Data.List.NonEmpty
+import           Test.QuickCheck hiding (choose)
+import           Test.QuickCheck.Arbitrary.Generic
+import           Test.QuickCheck.Instances.UnorderedContainers ()
+import           Text.Mustache
 import qualified Data.Yaml as Yaml
 --------------------------------------------------------------------------------
-import Xanthous.Random
-import Xanthous.Orphans ()
+import           Xanthous.Random
+import           Xanthous.Orphans ()
 --------------------------------------------------------------------------------
 
 data Message = Single Template | Choice (NonEmpty Template)
@@ -98,3 +100,8 @@ message :: (MonadRandom m, ToJSON params) => [Text] -> params -> m Text
 message path params = maybe notFound (`render` params) $ messages ^? ix path
   where
     notFound = pure "Message not found"
+
+message_ :: (MonadRandom m) => [Text] -> m Text
+message_ path = maybe notFound (`render` JSON.object []) $ messages ^? ix path
+  where
+    notFound = pure "Message not found"

src/Xanthous/Util.hs

@@ -1,7 +1,7 @@
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE BangPatterns          #-}
+{-# LANGUAGE AllowAmbiguousTypes   #-}
 {-# LANGUAGE QuantifiedConstraints #-}
-
+--------------------------------------------------------------------------------
 module Xanthous.Util
   ( EqEqProp(..)
   , EqProp(..)
@@ -25,13 +25,18 @@ module Xanthous.Util
     -- ** Bag sequence algorithms
   , takeWhileInclusive
   , smallestNotIn
+
+    -- * Type-level programming utils
+  , KnownBool(..)
   ) where
-
+--------------------------------------------------------------------------------
 import Xanthous.Prelude hiding (foldr)
-
+--------------------------------------------------------------------------------
 import Test.QuickCheck.Checkers
 import Data.Foldable (foldr)
 import Data.Monoid
+import Data.Proxy
+--------------------------------------------------------------------------------
 
 newtype EqEqProp a = EqEqProp a
   deriving newtype Eq
@@ -204,3 +209,17 @@ smallestNotIn xs = case uniq $ sort xs of
     | x > minBound -> minBound
     | otherwise
     -> snd . headEx . filter (uncurry (/=)) $ zip (xs' ++ [minBound]) [minBound..]
+
+--------------------------------------------------------------------------------
+
+-- | This class gives a boolean associated with a type-level bool, a'la
+-- 'KnownSymbol', 'KnownNat' etc.
+class KnownBool (bool :: Bool) where
+  boolVal' :: forall proxy. proxy bool -> Bool
+  boolVal' _ = boolVal @bool
+
+  boolVal :: Bool
+  boolVal = boolVal' $ Proxy @bool
+
+instance KnownBool 'True where boolVal = True
+instance KnownBool 'False where boolVal = False

src/Xanthous/messages.yaml

@@ -1,4 +1,4 @@
-welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside?
+welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside? Use hjklybnu to move.
 dead:
   - You have died...
   - You die...
@@ -54,3 +54,11 @@ eat:
     - You search your pockets for something edible, and come up short.
   menuPrompt: What would you like to eat?
   eat: You eat the {{item.itemType.name}}.
+
+read:
+  prompt: Direction to read (hjklybnu.)?
+  nothing: "There's nothing there to read"
+  result: "\"{{message}}\""
+
+tutorial:
+  message1: The caves are dark and full of nightmarish creatures - and you are likely to perish without food. Seek out sustenance, and pick it up with ,