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.
This commit is contained in:
Griffin Smith 2019-11-30 19:55:43 -05:00
parent 4431d453f6
commit 71b628c604
12 changed files with 210 additions and 40 deletions

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

@ -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 {..}

View file

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

View file

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

View file

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

View file

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