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 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
|
||||
|
|
|
@ -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
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
|
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 {..}
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ,
|
||||
|
|
Loading…
Reference in a new issue