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:
parent
4431d453f6
commit
71b628c604
12 changed files with 210 additions and 40 deletions
|
@ -73,10 +73,17 @@ data Setting = FieldLabelModifier [StrFun]
|
||||||
|
|
||||||
type FieldLabelModifier = 'FieldLabelModifier
|
type FieldLabelModifier = 'FieldLabelModifier
|
||||||
type ConstructorTagModifier = 'ConstructorTagModifier
|
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 AllNullaryToStringTag = 'AllNullaryToStringTag
|
||||||
type OmitNothingFields = 'OmitNothingFields
|
type OmitNothingFields = 'OmitNothingFields
|
||||||
type SumEnc = 'SumEnc
|
type SumEnc = 'SumEnc
|
||||||
|
-- | Hide the field name when a record constructor has only one field, like a
|
||||||
|
-- newtype.
|
||||||
type UnwrapUnaryRecords = 'UnwrapUnaryRecords
|
type UnwrapUnaryRecords = 'UnwrapUnaryRecords
|
||||||
|
-- | Encode types with a single constructor as sums, so that
|
||||||
|
-- 'AllNullaryToStringTag' and 'SumEncoding' apply.
|
||||||
type TagSingleConstructors = 'TagSingleConstructors
|
type TagSingleConstructors = 'TagSingleConstructors
|
||||||
|
|
||||||
class Demotable (a :: k) where
|
class Demotable (a :: k) where
|
||||||
|
|
|
@ -44,7 +44,8 @@ import Xanthous.Entities.Item (Item)
|
||||||
import qualified Xanthous.Entities.Item as Item
|
import qualified Xanthous.Entities.Item as Item
|
||||||
import Xanthous.Entities.Creature (Creature)
|
import Xanthous.Entities.Creature (Creature)
|
||||||
import qualified Xanthous.Entities.Creature as 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.Entities.RawTypes (edible, eatMessage, hitpointsHealed)
|
||||||
import Xanthous.Generators
|
import Xanthous.Generators
|
||||||
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
|
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
|
||||||
|
@ -84,6 +85,7 @@ initLevel = do
|
||||||
entities <>= (SomeEntity <$> level ^. levelWalls)
|
entities <>= (SomeEntity <$> level ^. levelWalls)
|
||||||
entities <>= (SomeEntity <$> level ^. levelItems)
|
entities <>= (SomeEntity <$> level ^. levelItems)
|
||||||
entities <>= (SomeEntity <$> level ^. levelCreatures)
|
entities <>= (SomeEntity <$> level ^. levelCreatures)
|
||||||
|
entities <>= (SomeEntity <$> level ^. levelTutorialMessage)
|
||||||
|
|
||||||
characterPosition .= level ^. levelCharacterPosition
|
characterPosition .= level ^. levelCharacterPosition
|
||||||
|
|
||||||
|
@ -206,6 +208,29 @@ handleCommand Eat = do
|
||||||
stepGame -- TODO
|
stepGame -- TODO
|
||||||
continue
|
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
|
handleCommand Save = do
|
||||||
-- TODO default save locations / config file?
|
-- TODO default save locations / config file?
|
||||||
prompt_ @'StringPrompt ["save", "location"] Cancellable
|
prompt_ @'StringPrompt ["save", "location"] Cancellable
|
||||||
|
@ -413,3 +438,5 @@ entityMenu_ = mkMenuItems @[_] . map entityMenuItem
|
||||||
|
|
||||||
-- entityMenu :: Entity entity => [entity] -> Map Char (MenuOption entity)
|
-- entityMenu :: Entity entity => [entity] -> Map Char (MenuOption entity)
|
||||||
-- entityMenu = map (map runIdentity) . entityMenu_ . fmap Identity
|
-- entityMenu = map (map runIdentity) . entityMenu_ . fmap Identity
|
||||||
|
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
|
@ -19,6 +19,7 @@ data Command
|
||||||
| Eat
|
| Eat
|
||||||
| Look
|
| Look
|
||||||
| Save
|
| Save
|
||||||
|
| Read
|
||||||
|
|
||||||
-- | TODO replace with `:` commands
|
-- | TODO replace with `:` commands
|
||||||
| ToggleRevealAll
|
| ToggleRevealAll
|
||||||
|
@ -33,6 +34,7 @@ commandFromKey (KChar 'o') [] = Just Open
|
||||||
commandFromKey (KChar ';') [] = Just Look
|
commandFromKey (KChar ';') [] = Just Look
|
||||||
commandFromKey (KChar 'e') [] = Just Eat
|
commandFromKey (KChar 'e') [] = Just Eat
|
||||||
commandFromKey (KChar 'S') [] = Just Save
|
commandFromKey (KChar 'S') [] = Just Save
|
||||||
|
commandFromKey (KChar 'r') [] = Just Read
|
||||||
|
|
||||||
commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll
|
commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll
|
||||||
|
|
||||||
|
|
|
@ -26,6 +26,7 @@ instance Arbitrary SomeEntity where
|
||||||
, SomeEntity <$> arbitrary @Creature
|
, SomeEntity <$> arbitrary @Creature
|
||||||
, SomeEntity <$> arbitrary @Wall
|
, SomeEntity <$> arbitrary @Wall
|
||||||
, SomeEntity <$> arbitrary @Door
|
, SomeEntity <$> arbitrary @Door
|
||||||
|
, SomeEntity <$> arbitrary @GroundMessage
|
||||||
]
|
]
|
||||||
|
|
||||||
instance FromJSON SomeEntity where
|
instance FromJSON SomeEntity where
|
||||||
|
@ -37,6 +38,7 @@ instance FromJSON SomeEntity where
|
||||||
"Creature" -> SomeEntity @Creature <$> obj .: "data"
|
"Creature" -> SomeEntity @Creature <$> obj .: "data"
|
||||||
"Wall" -> SomeEntity @Wall <$> obj .: "data"
|
"Wall" -> SomeEntity @Wall <$> obj .: "data"
|
||||||
"Door" -> SomeEntity @Door <$> obj .: "data"
|
"Door" -> SomeEntity @Door <$> obj .: "data"
|
||||||
|
"GroundMessage" -> SomeEntity @GroundMessage <$> obj .: "data"
|
||||||
_ -> fail . unpack $ "Invalid entity type \"" <> entityType <> "\""
|
_ -> fail . unpack $ "Invalid entity type \"" <> entityType <> "\""
|
||||||
|
|
||||||
deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState
|
deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState
|
||||||
|
|
|
@ -1,22 +1,29 @@
|
||||||
{-# LANGUAGE TemplateHaskell #-}
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
module Xanthous.Entities.Environment
|
module Xanthous.Entities.Environment
|
||||||
( Wall(..)
|
(
|
||||||
|
-- * Walls
|
||||||
|
Wall(..)
|
||||||
|
-- * Doors
|
||||||
, Door(..)
|
, Door(..)
|
||||||
, open
|
, open
|
||||||
, locked
|
, locked
|
||||||
|
-- * Messages
|
||||||
|
, GroundMessage(..)
|
||||||
) where
|
) where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Prelude
|
import Xanthous.Prelude
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
import Test.QuickCheck
|
import Test.QuickCheck
|
||||||
import Test.QuickCheck.Arbitrary.Generic
|
|
||||||
import Brick (str)
|
import Brick (str)
|
||||||
import Brick.Widgets.Border.Style (unicode)
|
import Brick.Widgets.Border.Style (unicode)
|
||||||
import Brick.Types (Edges(..))
|
import Brick.Types (Edges(..))
|
||||||
import Data.Aeson
|
import Data.Aeson
|
||||||
|
import Data.Aeson.Generic.DerivingVia
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Entities.Draw.Util
|
import Xanthous.Entities.Draw.Util
|
||||||
import Xanthous.Data
|
import Xanthous.Data
|
||||||
import Xanthous.Game.State
|
import Xanthous.Game.State
|
||||||
|
import Xanthous.Util.QuickCheck
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
data Wall = Wall
|
data Wall = Wall
|
||||||
|
@ -31,7 +38,6 @@ instance FromJSON Wall where
|
||||||
"Wall" -> pure Wall
|
"Wall" -> pure Wall
|
||||||
_ -> fail "Invalid Wall: expected Wall"
|
_ -> fail "Invalid Wall: expected Wall"
|
||||||
|
|
||||||
-- deriving via Brainless Wall instance Brain Wall
|
|
||||||
instance Brain Wall where step = brainVia Brainless
|
instance Brain Wall where step = brainVia Brainless
|
||||||
|
|
||||||
instance Entity Wall where
|
instance Entity Wall where
|
||||||
|
@ -56,11 +62,9 @@ data Door = Door
|
||||||
}
|
}
|
||||||
deriving stock (Show, Eq, Ord, Generic)
|
deriving stock (Show, Eq, Ord, Generic)
|
||||||
deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON)
|
deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON)
|
||||||
|
deriving Arbitrary via GenericArbitrary Door
|
||||||
makeLenses ''Door
|
makeLenses ''Door
|
||||||
|
|
||||||
instance Arbitrary Door where
|
|
||||||
arbitrary = genericArbitrary
|
|
||||||
|
|
||||||
instance Draw Door where
|
instance Draw Door where
|
||||||
drawWithNeighbors neighs door
|
drawWithNeighbors neighs door
|
||||||
| door ^. open
|
| door ^. open
|
||||||
|
@ -77,10 +81,29 @@ instance Draw Door where
|
||||||
horizDoor = '␣'
|
horizDoor = '␣'
|
||||||
vertDoor = '['
|
vertDoor = '['
|
||||||
|
|
||||||
-- deriving via Brainless Door instance Brain Door
|
|
||||||
instance Brain Door where step = brainVia Brainless
|
instance Brain Door where step = brainVia Brainless
|
||||||
|
|
||||||
instance Entity Door where
|
instance Entity Door where
|
||||||
blocksVision = not . view open
|
blocksVision = not . view open
|
||||||
description _ = "a door"
|
description _ = "a door"
|
||||||
entityChar _ = "d"
|
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
|
||||||
|
|
|
@ -25,7 +25,7 @@ import Xanthous.Data
|
||||||
import qualified Xanthous.Data.EntityMap as EntityMap
|
import qualified Xanthous.Data.EntityMap as EntityMap
|
||||||
import Xanthous.Data.EntityMap.Graphics (visiblePositions)
|
import Xanthous.Data.EntityMap.Graphics (visiblePositions)
|
||||||
import Xanthous.Entities.Character (Character, mkCharacter)
|
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.Item (Item)
|
||||||
import Xanthous.Entities.Creature (Creature)
|
import Xanthous.Entities.Creature (Creature)
|
||||||
import Xanthous.Entities.Entities ()
|
import Xanthous.Entities.Entities ()
|
||||||
|
@ -105,8 +105,12 @@ entityCollision
|
||||||
-> Maybe Collision
|
-> Maybe Collision
|
||||||
entityCollision Empty = Nothing
|
entityCollision Empty = Nothing
|
||||||
entityCollision ents
|
entityCollision ents
|
||||||
|
-- TODO track entity collision in the Entity class
|
||||||
| any (entityIs @Creature) ents = pure Combat
|
| 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
|
| doors@(_ : _) <- ents ^.. folded . _SomeEntity @Door
|
||||||
, all (view open) doors = Nothing
|
, all (view open) doors = Nothing
|
||||||
| otherwise = pure Stop
|
| otherwise = pure Stop
|
||||||
|
|
|
@ -37,10 +37,14 @@ module Xanthous.Game.State
|
||||||
, downcastEntity
|
, downcastEntity
|
||||||
, _SomeEntity
|
, _SomeEntity
|
||||||
, entityIs
|
, entityIs
|
||||||
|
-- ** Vias
|
||||||
|
, Color(..)
|
||||||
|
, DrawNothing(..)
|
||||||
, DrawRawChar(..)
|
, DrawRawChar(..)
|
||||||
, DrawRawCharPriority(..)
|
, DrawRawCharPriority(..)
|
||||||
, DrawCharacter(..)
|
, DrawCharacter(..)
|
||||||
, DrawStyledCharacter(..)
|
, DrawStyledCharacter(..)
|
||||||
|
, DeriveEntity(..)
|
||||||
-- ** Field classes
|
-- ** Field classes
|
||||||
, HasChar(..)
|
, HasChar(..)
|
||||||
, HasStyle(..)
|
, HasStyle(..)
|
||||||
|
@ -63,7 +67,7 @@ import Test.QuickCheck.Arbitrary.Generic
|
||||||
import Control.Monad.State.Class
|
import Control.Monad.State.Class
|
||||||
import Control.Monad.State
|
import Control.Monad.State
|
||||||
import Control.Monad.Random.Class
|
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 Data.Aeson (ToJSON(..), FromJSON(..), Value(Null))
|
||||||
import qualified Data.Aeson as JSON
|
import qualified Data.Aeson as JSON
|
||||||
import Data.Aeson.Generic.DerivingVia
|
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.Attributes as Vty
|
||||||
import qualified Graphics.Vty.Image as Vty
|
import qualified Graphics.Vty.Image as Vty
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
import Xanthous.Util (KnownBool(..))
|
||||||
import Xanthous.Data
|
import Xanthous.Data
|
||||||
import Xanthous.Data.EntityMap (EntityMap, EntityID)
|
import Xanthous.Data.EntityMap (EntityMap, EntityID)
|
||||||
import Xanthous.Data.EntityChar
|
import Xanthous.Data.EntityChar
|
||||||
|
@ -213,20 +218,29 @@ instance KnownColor 'Magenta where colorVal _ = Vty.magenta
|
||||||
instance KnownColor 'Cyan where colorVal _ = Vty.cyan
|
instance KnownColor 'Cyan where colorVal _ = Vty.cyan
|
||||||
instance KnownColor 'White where colorVal _ = Vty.white
|
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
|
DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a
|
||||||
|
|
||||||
instance
|
instance
|
||||||
( KnownColor fg
|
( KnownMaybeColor fg
|
||||||
, KnownColor bg
|
, KnownMaybeColor bg
|
||||||
, KnownSymbol char
|
, KnownSymbol char
|
||||||
)
|
)
|
||||||
=> Draw (DrawStyledCharacter fg bg char a) where
|
=> Draw (DrawStyledCharacter fg bg char a) where
|
||||||
draw _ = raw $ Vty.string attr $ symbolVal @char Proxy
|
draw _ = raw $ Vty.string attr $ symbolVal @char Proxy
|
||||||
where attr = Vty.Attr
|
where attr = Vty.Attr
|
||||||
{ Vty.attrStyle = Vty.Default
|
{ Vty.attrStyle = Vty.Default
|
||||||
, Vty.attrForeColor = Vty.SetTo $ colorVal @fg Proxy
|
, Vty.attrForeColor = maybe Vty.Default Vty.SetTo
|
||||||
, Vty.attrBackColor = Vty.SetTo $ colorVal @bg Proxy
|
$ maybeColorVal @fg Proxy
|
||||||
|
, Vty.attrBackColor = maybe Vty.Default Vty.SetTo
|
||||||
|
$ maybeColorVal @bg Proxy
|
||||||
, Vty.attrURL = Vty.Default
|
, 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
|
newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a
|
||||||
|
|
||||||
instance
|
instance
|
||||||
|
@ -336,6 +356,31 @@ entityIs = isJust . downcastEntity @a
|
||||||
_SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a
|
_SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a
|
||||||
_SomeEntity = prism' SomeEntity downcastEntity
|
_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
|
data DebugState = DebugState
|
||||||
|
|
|
@ -14,6 +14,7 @@ module Xanthous.Generators
|
||||||
, levelItems
|
, levelItems
|
||||||
, levelCreatures
|
, levelCreatures
|
||||||
, levelCharacterPosition
|
, levelCharacterPosition
|
||||||
|
, levelTutorialMessage
|
||||||
, generateLevel
|
, generateLevel
|
||||||
) where
|
) where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
|
@ -91,6 +92,7 @@ data Level = Level
|
||||||
{ _levelWalls :: !(EntityMap Wall)
|
{ _levelWalls :: !(EntityMap Wall)
|
||||||
, _levelItems :: !(EntityMap Item)
|
, _levelItems :: !(EntityMap Item)
|
||||||
, _levelCreatures :: !(EntityMap Creature)
|
, _levelCreatures :: !(EntityMap Creature)
|
||||||
|
, _levelTutorialMessage :: !(EntityMap GroundMessage)
|
||||||
, _levelCharacterPosition :: !Position
|
, _levelCharacterPosition :: !Position
|
||||||
}
|
}
|
||||||
makeLenses ''Level
|
makeLenses ''Level
|
||||||
|
@ -103,4 +105,5 @@ generateLevel gen ps dims = do
|
||||||
_levelItems <- randomItems cells
|
_levelItems <- randomItems cells
|
||||||
_levelCreatures <- randomCreatures cells
|
_levelCreatures <- randomCreatures cells
|
||||||
_levelCharacterPosition <- chooseCharacterPosition cells
|
_levelCharacterPosition <- chooseCharacterPosition cells
|
||||||
|
_levelTutorialMessage <- tutorialMessage cells _levelCharacterPosition
|
||||||
pure Level {..}
|
pure Level {..}
|
||||||
|
|
|
@ -3,22 +3,26 @@ module Xanthous.Generators.LevelContents
|
||||||
( chooseCharacterPosition
|
( chooseCharacterPosition
|
||||||
, randomItems
|
, randomItems
|
||||||
, randomCreatures
|
, randomCreatures
|
||||||
|
, tutorialMessage
|
||||||
) where
|
) where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Prelude
|
import Xanthous.Prelude
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Control.Monad.Random
|
import Control.Monad.Random
|
||||||
import Data.Array.IArray (amap, bounds, rangeSize)
|
import Data.Array.IArray (amap, bounds, rangeSize, (!))
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Generators.Util
|
import Xanthous.Generators.Util
|
||||||
import Xanthous.Random
|
import Xanthous.Random
|
||||||
import Xanthous.Data (Position, positionFromPair)
|
import Xanthous.Data (Position, _Position, positionFromPair)
|
||||||
import Xanthous.Data.EntityMap (EntityMap, _EntityMap)
|
import Xanthous.Data.EntityMap (EntityMap, _EntityMap)
|
||||||
import Xanthous.Entities.Raws (rawsWithType, RawType)
|
import Xanthous.Entities.Raws (rawsWithType, RawType)
|
||||||
import qualified Xanthous.Entities.Item as Item
|
import qualified Xanthous.Entities.Item as Item
|
||||||
import Xanthous.Entities.Item (Item)
|
import Xanthous.Entities.Item (Item)
|
||||||
import qualified Xanthous.Entities.Creature as Creature
|
import qualified Xanthous.Entities.Creature as Creature
|
||||||
import Xanthous.Entities.Creature (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
|
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 :: MonadRandom m => Cells -> m (EntityMap Creature)
|
||||||
randomCreatures = randomEntities Creature.newWithType (0.0007, 0.003)
|
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
|
randomEntities
|
||||||
:: forall entity raw m. (MonadRandom m, RawType raw)
|
:: forall entity raw m. (MonadRandom m, RawType raw)
|
||||||
=> (raw -> entity)
|
=> (raw -> entity)
|
||||||
|
@ -41,7 +63,8 @@ randomEntities newWithType sizeRange cells =
|
||||||
Nothing -> pure mempty
|
Nothing -> pure mempty
|
||||||
Just raws -> do
|
Just raws -> do
|
||||||
let len = rangeSize $ bounds cells
|
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
|
entities <- for [0..numEntities] $ const $ do
|
||||||
pos <- randomPosition cells
|
pos <- randomPosition cells
|
||||||
raw <- choose raws
|
raw <- choose raws
|
||||||
|
|
|
@ -11,12 +11,14 @@ module Xanthous.Messages
|
||||||
, render
|
, render
|
||||||
, lookup
|
, lookup
|
||||||
, message
|
, message
|
||||||
|
, message_
|
||||||
) where
|
) where
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Prelude hiding (lookup)
|
import Xanthous.Prelude hiding (lookup)
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
import Control.Monad.Random.Class (MonadRandom)
|
import Control.Monad.Random.Class (MonadRandom)
|
||||||
import Data.Aeson (FromJSON, ToJSON, toJSON)
|
import Data.Aeson (FromJSON, ToJSON, toJSON)
|
||||||
|
import qualified Data.Aeson as JSON
|
||||||
import Data.Aeson.Generic.DerivingVia
|
import Data.Aeson.Generic.DerivingVia
|
||||||
import Data.FileEmbed
|
import Data.FileEmbed
|
||||||
import Data.List.NonEmpty
|
import Data.List.NonEmpty
|
||||||
|
@ -98,3 +100,8 @@ message :: (MonadRandom m, ToJSON params) => [Text] -> params -> m Text
|
||||||
message path params = maybe notFound (`render` params) $ messages ^? ix path
|
message path params = maybe notFound (`render` params) $ messages ^? ix path
|
||||||
where
|
where
|
||||||
notFound = pure "Message not found"
|
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"
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
{-# LANGUAGE BangPatterns #-}
|
{-# LANGUAGE BangPatterns #-}
|
||||||
{-# LANGUAGE AllowAmbiguousTypes #-}
|
{-# LANGUAGE AllowAmbiguousTypes #-}
|
||||||
{-# LANGUAGE QuantifiedConstraints #-}
|
{-# LANGUAGE QuantifiedConstraints #-}
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
module Xanthous.Util
|
module Xanthous.Util
|
||||||
( EqEqProp(..)
|
( EqEqProp(..)
|
||||||
, EqProp(..)
|
, EqProp(..)
|
||||||
|
@ -25,13 +25,18 @@ module Xanthous.Util
|
||||||
-- ** Bag sequence algorithms
|
-- ** Bag sequence algorithms
|
||||||
, takeWhileInclusive
|
, takeWhileInclusive
|
||||||
, smallestNotIn
|
, smallestNotIn
|
||||||
|
|
||||||
|
-- * Type-level programming utils
|
||||||
|
, KnownBool(..)
|
||||||
) where
|
) where
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
import Xanthous.Prelude hiding (foldr)
|
import Xanthous.Prelude hiding (foldr)
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
import Test.QuickCheck.Checkers
|
import Test.QuickCheck.Checkers
|
||||||
import Data.Foldable (foldr)
|
import Data.Foldable (foldr)
|
||||||
import Data.Monoid
|
import Data.Monoid
|
||||||
|
import Data.Proxy
|
||||||
|
--------------------------------------------------------------------------------
|
||||||
|
|
||||||
newtype EqEqProp a = EqEqProp a
|
newtype EqEqProp a = EqEqProp a
|
||||||
deriving newtype Eq
|
deriving newtype Eq
|
||||||
|
@ -204,3 +209,17 @@ smallestNotIn xs = case uniq $ sort xs of
|
||||||
| x > minBound -> minBound
|
| x > minBound -> minBound
|
||||||
| otherwise
|
| otherwise
|
||||||
-> snd . headEx . filter (uncurry (/=)) $ zip (xs' ++ [minBound]) [minBound..]
|
-> 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
|
||||||
|
|
|
@ -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:
|
dead:
|
||||||
- You have died...
|
- You have died...
|
||||||
- You die...
|
- You die...
|
||||||
|
@ -54,3 +54,11 @@ eat:
|
||||||
- You search your pockets for something edible, and come up short.
|
- You search your pockets for something edible, and come up short.
|
||||||
menuPrompt: What would you like to eat?
|
menuPrompt: What would you like to eat?
|
||||||
eat: You eat the {{item.itemType.name}}.
|
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 ,
|
||||||
|
|
Loading…
Reference in a new issue