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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

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