diff options
| -rw-r--r-- | src/Data/Aeson/Generic/DerivingVia.hs | 7 | ||||
| -rw-r--r-- | src/Xanthous/App.hs | 29 | ||||
| -rw-r--r-- | src/Xanthous/Command.hs | 2 | ||||
| -rw-r--r-- | src/Xanthous/Entities/Entities.hs | 2 | ||||
| -rw-r--r-- | src/Xanthous/Entities/Environment.hs | 37 | ||||
| -rw-r--r-- | src/Xanthous/Game/Lenses.hs | 8 | ||||
| -rw-r--r-- | src/Xanthous/Game/State.hs | 65 | ||||
| -rw-r--r-- | src/Xanthous/Generators.hs | 3 | ||||
| -rw-r--r-- | src/Xanthous/Generators/LevelContents.hs | 29 | ||||
| -rw-r--r-- | src/Xanthous/Messages.hs | 29 | ||||
| -rw-r--r-- | src/Xanthous/Util.hs | 29 | ||||
| -rw-r--r-- | src/Xanthous/messages.yaml | 10 |
12 files changed, 210 insertions, 40 deletions
diff --git a/src/Data/Aeson/Generic/DerivingVia.hs b/src/Data/Aeson/Generic/DerivingVia.hs index f387f1deccb1..34f2a9403892 100644 --- a/src/Data/Aeson/Generic/DerivingVia.hs +++ b/src/Data/Aeson/Generic/DerivingVia.hs @@ -73,10 +73,17 @@ data Setting = FieldLabelModifier [StrFun] type FieldLabelModifier = 'FieldLabelModifier type ConstructorTagModifier = 'ConstructorTagModifier +-- | If 'True' the constructors of a datatype, with all nullary constructors, +-- will be encoded to just a string with the constructor tag. If 'False' the +-- encoding will always follow the 'SumEncoding'. type AllNullaryToStringTag = 'AllNullaryToStringTag type OmitNothingFields = 'OmitNothingFields type SumEnc = 'SumEnc +-- | Hide the field name when a record constructor has only one field, like a +-- newtype. type UnwrapUnaryRecords = 'UnwrapUnaryRecords +-- | Encode types with a single constructor as sums, so that +-- 'AllNullaryToStringTag' and 'SumEncoding' apply. type TagSingleConstructors = 'TagSingleConstructors class Demotable (a :: k) where diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index b8cda3b77721..df76eadc3bbc 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -44,7 +44,8 @@ import Xanthous.Entities.Item (Item) import qualified Xanthous.Entities.Item as Item import Xanthous.Entities.Creature (Creature) import qualified Xanthous.Entities.Creature as Creature -import Xanthous.Entities.Environment (Door, open, locked) +import Xanthous.Entities.Environment + (Door, open, locked, GroundMessage(..)) import Xanthous.Entities.RawTypes (edible, eatMessage, hitpointsHealed) import Xanthous.Generators import qualified Xanthous.Generators.CaveAutomata as CaveAutomata @@ -84,6 +85,7 @@ initLevel = do entities <>= (SomeEntity <$> level ^. levelWalls) entities <>= (SomeEntity <$> level ^. levelItems) entities <>= (SomeEntity <$> level ^. levelCreatures) + entities <>= (SomeEntity <$> level ^. levelTutorialMessage) characterPosition .= level ^. levelCharacterPosition @@ -206,6 +208,29 @@ handleCommand Eat = do stepGame -- TODO continue +handleCommand Read = do + -- TODO allow reading things in the inventory (combo direction+menu prompt?) + prompt_ @'DirectionPrompt ["read", "prompt"] Cancellable + $ \(DirectionResult dir) -> do + pos <- uses characterPosition $ move dir + uses entities + (fmap snd . entitiesAtPositionWithType @GroundMessage pos) >>= \case + Empty -> say_ ["read", "nothing"] + GroundMessage msg :< Empty -> + say ["read", "result"] $ object ["message" A..= msg] + msgs -> + let readAndContinue Empty = pure () + readAndContinue (msg :< msgs') = + prompt @'Continue + ["read", "result"] + (object ["message" A..= msg]) + Cancellable + . const + $ readAndContinue msgs' + readAndContinue _ = error "this is total" + in readAndContinue msgs + continue + handleCommand Save = do -- TODO default save locations / config file? prompt_ @'StringPrompt ["save", "location"] Cancellable @@ -413,3 +438,5 @@ entityMenu_ = mkMenuItems @[_] . map entityMenuItem -- entityMenu :: Entity entity => [entity] -> Map Char (MenuOption entity) -- entityMenu = map (map runIdentity) . entityMenu_ . fmap Identity + +-------------------------------------------------------------------------------- diff --git a/src/Xanthous/Command.hs b/src/Xanthous/Command.hs index 35a8ce367269..61fb11b22e77 100644 --- a/src/Xanthous/Command.hs +++ b/src/Xanthous/Command.hs @@ -19,6 +19,7 @@ data Command | Eat | Look | Save + | Read -- | TODO replace with `:` commands | ToggleRevealAll @@ -33,6 +34,7 @@ commandFromKey (KChar 'o') [] = Just Open commandFromKey (KChar ';') [] = Just Look commandFromKey (KChar 'e') [] = Just Eat commandFromKey (KChar 'S') [] = Just Save +commandFromKey (KChar 'r') [] = Just Read commandFromKey (KChar 'r') [MMeta] = Just ToggleRevealAll diff --git a/src/Xanthous/Entities/Entities.hs b/src/Xanthous/Entities/Entities.hs index 7e41fc8b7b3a..802aecddebdf 100644 --- a/src/Xanthous/Entities/Entities.hs +++ b/src/Xanthous/Entities/Entities.hs @@ -26,6 +26,7 @@ instance Arbitrary SomeEntity where , SomeEntity <$> arbitrary @Creature , SomeEntity <$> arbitrary @Wall , SomeEntity <$> arbitrary @Door + , SomeEntity <$> arbitrary @GroundMessage ] instance FromJSON SomeEntity where @@ -37,6 +38,7 @@ instance FromJSON SomeEntity where "Creature" -> SomeEntity @Creature <$> obj .: "data" "Wall" -> SomeEntity @Wall <$> obj .: "data" "Door" -> SomeEntity @Door <$> obj .: "data" + "GroundMessage" -> SomeEntity @GroundMessage <$> obj .: "data" _ -> fail . unpack $ "Invalid entity type \"" <> entityType <> "\"" deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState diff --git a/src/Xanthous/Entities/Environment.hs b/src/Xanthous/Entities/Environment.hs index 8baa07650f7c..0690e47e5441 100644 --- a/src/Xanthous/Entities/Environment.hs +++ b/src/Xanthous/Entities/Environment.hs @@ -1,22 +1,29 @@ {-# LANGUAGE TemplateHaskell #-} module Xanthous.Entities.Environment - ( Wall(..) + ( + -- * Walls + Wall(..) + -- * Doors , Door(..) , open , locked + -- * Messages + , GroundMessage(..) ) where -------------------------------------------------------------------------------- import Xanthous.Prelude +-------------------------------------------------------------------------------- import Test.QuickCheck -import Test.QuickCheck.Arbitrary.Generic import Brick (str) import Brick.Widgets.Border.Style (unicode) import Brick.Types (Edges(..)) import Data.Aeson +import Data.Aeson.Generic.DerivingVia -------------------------------------------------------------------------------- import Xanthous.Entities.Draw.Util import Xanthous.Data import Xanthous.Game.State +import Xanthous.Util.QuickCheck -------------------------------------------------------------------------------- data Wall = Wall @@ -31,7 +38,6 @@ instance FromJSON Wall where "Wall" -> pure Wall _ -> fail "Invalid Wall: expected Wall" --- deriving via Brainless Wall instance Brain Wall instance Brain Wall where step = brainVia Brainless instance Entity Wall where @@ -56,11 +62,9 @@ data Door = Door } deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON) + deriving Arbitrary via GenericArbitrary Door makeLenses ''Door -instance Arbitrary Door where - arbitrary = genericArbitrary - instance Draw Door where drawWithNeighbors neighs door | door ^. open @@ -77,10 +81,29 @@ instance Draw Door where horizDoor = '␣' vertDoor = '[' --- deriving via Brainless Door instance Brain Door instance Brain Door where step = brainVia Brainless instance Entity Door where blocksVision = not . view open description _ = "a door" entityChar _ = "d" + +-------------------------------------------------------------------------------- + +newtype GroundMessage = GroundMessage Text + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving Arbitrary via GenericArbitrary GroundMessage + deriving (ToJSON, FromJSON) + via WithOptions '[ 'TagSingleConstructors 'True + , 'SumEnc 'ObjWithSingleField + ] + GroundMessage + deriving Draw + via DrawStyledCharacter ('Just 'Yellow) 'Nothing "≈" + GroundMessage + deriving Entity + via DeriveEntity 'False "a message on the ground. Press r. to read it." + "≈" + GroundMessage +instance Brain GroundMessage where step = brainVia Brainless diff --git a/src/Xanthous/Game/Lenses.hs b/src/Xanthous/Game/Lenses.hs index 7dbd60290144..13f4b89314f7 100644 --- a/src/Xanthous/Game/Lenses.hs +++ b/src/Xanthous/Game/Lenses.hs @@ -25,7 +25,7 @@ import Xanthous.Data import qualified Xanthous.Data.EntityMap as EntityMap import Xanthous.Data.EntityMap.Graphics (visiblePositions) import Xanthous.Entities.Character (Character, mkCharacter) -import Xanthous.Entities.Environment (Door, open) +import Xanthous.Entities.Environment (Door, open, GroundMessage) import Xanthous.Entities.Item (Item) import Xanthous.Entities.Creature (Creature) import Xanthous.Entities.Entities () @@ -105,8 +105,12 @@ entityCollision -> Maybe Collision entityCollision Empty = Nothing entityCollision ents + -- TODO track entity collision in the Entity class | any (entityIs @Creature) ents = pure Combat - | all (entityIs @Item) ents = Nothing + | all (\e -> + entityIs @Item e + || entityIs @GroundMessage e + ) ents = Nothing | doors@(_ : _) <- ents ^.. folded . _SomeEntity @Door , all (view open) doors = Nothing | otherwise = pure Stop diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs index 028688542a25..5ddb7de7e9b8 100644 --- a/src/Xanthous/Game/State.hs +++ b/src/Xanthous/Game/State.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE AllowAmbiguousTypes #-} -------------------------------------------------------------------------------- module Xanthous.Game.State ( GameState(..) @@ -37,10 +37,14 @@ module Xanthous.Game.State , downcastEntity , _SomeEntity , entityIs + -- ** Vias + , Color(..) + , DrawNothing(..) , DrawRawChar(..) , DrawRawCharPriority(..) , DrawCharacter(..) , DrawStyledCharacter(..) + , DeriveEntity(..) -- ** Field classes , HasChar(..) , HasStyle(..) @@ -63,7 +67,7 @@ import Test.QuickCheck.Arbitrary.Generic import Control.Monad.State.Class import Control.Monad.State import Control.Monad.Random.Class -import Brick (EventM, Widget, raw, str) +import Brick (EventM, Widget, raw, str, emptyWidget) import Data.Aeson (ToJSON(..), FromJSON(..), Value(Null)) import qualified Data.Aeson as JSON import Data.Aeson.Generic.DerivingVia @@ -71,6 +75,7 @@ import Data.Generics.Product.Fields import qualified Graphics.Vty.Attributes as Vty import qualified Graphics.Vty.Image as Vty -------------------------------------------------------------------------------- +import Xanthous.Util (KnownBool(..)) import Xanthous.Data import Xanthous.Data.EntityMap (EntityMap, EntityID) import Xanthous.Data.EntityChar @@ -213,20 +218,29 @@ instance KnownColor 'Magenta where colorVal _ = Vty.magenta instance KnownColor 'Cyan where colorVal _ = Vty.cyan instance KnownColor 'White where colorVal _ = Vty.white -newtype DrawStyledCharacter (fg :: Color) (bg :: Color) (char :: Symbol) (a :: Type) where +class KnownMaybeColor (maybeColor :: Maybe Color) where + maybeColorVal :: forall proxy. proxy maybeColor -> Maybe Vty.Color + +instance KnownMaybeColor 'Nothing where maybeColorVal _ = Nothing +instance KnownColor color => KnownMaybeColor ('Just color) where + maybeColorVal _ = Just $ colorVal @color Proxy + +newtype DrawStyledCharacter (fg :: Maybe Color) (bg :: Maybe Color) (char :: Symbol) (a :: Type) where DrawStyledCharacter :: a -> DrawStyledCharacter fg bg char a instance - ( KnownColor fg - , KnownColor bg + ( KnownMaybeColor fg + , KnownMaybeColor bg , KnownSymbol char ) => Draw (DrawStyledCharacter fg bg char a) where draw _ = raw $ Vty.string attr $ symbolVal @char Proxy where attr = Vty.Attr { Vty.attrStyle = Vty.Default - , Vty.attrForeColor = Vty.SetTo $ colorVal @fg Proxy - , Vty.attrBackColor = Vty.SetTo $ colorVal @bg Proxy + , Vty.attrForeColor = maybe Vty.Default Vty.SetTo + $ maybeColorVal @fg Proxy + , Vty.attrBackColor = maybe Vty.Default Vty.SetTo + $ maybeColorVal @bg Proxy , Vty.attrURL = Vty.Default } @@ -235,6 +249,12 @@ instance Draw EntityChar where -------------------------------------------------------------------------------- +newtype DrawNothing (a :: Type) = DrawNothing a + +instance Draw (DrawNothing a) where + draw = const emptyWidget + drawPriority = const 0 + newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a instance @@ -336,6 +356,31 @@ entityIs = isJust . downcastEntity @a _SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a _SomeEntity = prism' SomeEntity downcastEntity +newtype DeriveEntity + (blocksVision :: Bool) + (description :: Symbol) + (entityChar :: Symbol) + (entity :: Type) + = DeriveEntity entity + deriving newtype (Show, Eq, Ord, NFData, ToJSON, FromJSON, Draw) + +instance Brain entity => Brain (DeriveEntity b d c entity) where + step = brainVia $ \(DeriveEntity e) -> e + +instance + ( KnownBool blocksVision + , KnownSymbol description + , KnownSymbol entityChar + , Show entity, Eq entity, Ord entity, NFData entity + , ToJSON entity, FromJSON entity + , Draw entity, Brain entity + ) + => Entity (DeriveEntity blocksVision description entityChar entity) where + + blocksVision _ = boolVal @blocksVision + description _ = pack . symbolVal $ Proxy @description + entityChar _ = fromString . symbolVal $ Proxy @entityChar + -------------------------------------------------------------------------------- data DebugState = DebugState diff --git a/src/Xanthous/Generators.hs b/src/Xanthous/Generators.hs index 6b1a57299ea1..490e50ea60a8 100644 --- a/src/Xanthous/Generators.hs +++ b/src/Xanthous/Generators.hs @@ -14,6 +14,7 @@ module Xanthous.Generators , levelItems , levelCreatures , levelCharacterPosition + , levelTutorialMessage , generateLevel ) where -------------------------------------------------------------------------------- @@ -91,6 +92,7 @@ data Level = Level { _levelWalls :: !(EntityMap Wall) , _levelItems :: !(EntityMap Item) , _levelCreatures :: !(EntityMap Creature) + , _levelTutorialMessage :: !(EntityMap GroundMessage) , _levelCharacterPosition :: !Position } makeLenses ''Level @@ -103,4 +105,5 @@ generateLevel gen ps dims = do _levelItems <- randomItems cells _levelCreatures <- randomCreatures cells _levelCharacterPosition <- chooseCharacterPosition cells + _levelTutorialMessage <- tutorialMessage cells _levelCharacterPosition pure Level {..} diff --git a/src/Xanthous/Generators/LevelContents.hs b/src/Xanthous/Generators/LevelContents.hs index 583bdcbd6729..91a7d38019c8 100644 --- a/src/Xanthous/Generators/LevelContents.hs +++ b/src/Xanthous/Generators/LevelContents.hs @@ -3,22 +3,26 @@ module Xanthous.Generators.LevelContents ( chooseCharacterPosition , randomItems , randomCreatures + , tutorialMessage ) where -------------------------------------------------------------------------------- import Xanthous.Prelude -------------------------------------------------------------------------------- import Control.Monad.Random -import Data.Array.IArray (amap, bounds, rangeSize) +import Data.Array.IArray (amap, bounds, rangeSize, (!)) -------------------------------------------------------------------------------- import Xanthous.Generators.Util import Xanthous.Random -import Xanthous.Data (Position, positionFromPair) +import Xanthous.Data (Position, _Position, positionFromPair) import Xanthous.Data.EntityMap (EntityMap, _EntityMap) import Xanthous.Entities.Raws (rawsWithType, RawType) import qualified Xanthous.Entities.Item as Item import Xanthous.Entities.Item (Item) import qualified Xanthous.Entities.Creature as Creature import Xanthous.Entities.Creature (Creature) +import Xanthous.Entities.Environment (GroundMessage(..)) +import Xanthous.Messages (message_) +import Xanthous.Util.Graphics (circle) -------------------------------------------------------------------------------- chooseCharacterPosition :: MonadRandom m => Cells -> m Position @@ -30,6 +34,24 @@ randomItems = randomEntities Item.newWithType (0.0004, 0.001) randomCreatures :: MonadRandom m => Cells -> m (EntityMap Creature) randomCreatures = randomEntities Creature.newWithType (0.0007, 0.003) +tutorialMessage :: MonadRandom m + => Cells + -> Position -- ^ CharacterPosition + -> m (EntityMap GroundMessage) +tutorialMessage cells characterPosition = do + let distance = 2 + pos <- fmap (fromMaybe (error "No valid positions for tutorial message?")) + . choose . ChooseElement + $ accessiblePositionsWithin distance cells characterPosition + msg <- message_ ["tutorial", "message1"] + pure $ _EntityMap # [(pos, GroundMessage msg)] + where + accessiblePositionsWithin :: Int -> Cells -> Position -> [Position] + accessiblePositionsWithin dist valid pos = + review _Position + <$> filter (\(px, py) -> not $ valid ! (fromIntegral px, fromIntegral py)) + (circle (pos ^. _Position) dist) + randomEntities :: forall entity raw m. (MonadRandom m, RawType raw) => (raw -> entity) @@ -41,7 +63,8 @@ randomEntities newWithType sizeRange cells = Nothing -> pure mempty Just raws -> do let len = rangeSize $ bounds cells - (numEntities :: Int) <- floor . (* fromIntegral len) <$> getRandomR sizeRange + (numEntities :: Int) <- + floor . (* fromIntegral len) <$> getRandomR sizeRange entities <- for [0..numEntities] $ const $ do pos <- randomPosition cells raw <- choose raws diff --git a/src/Xanthous/Messages.hs b/src/Xanthous/Messages.hs index b0dc0e4ae9d2..2b1b3da1e8c1 100644 --- a/src/Xanthous/Messages.hs +++ b/src/Xanthous/Messages.hs @@ -11,23 +11,25 @@ module Xanthous.Messages , render , lookup , message + , message_ ) where -------------------------------------------------------------------------------- import Xanthous.Prelude hiding (lookup) -------------------------------------------------------------------------------- -import Control.Monad.Random.Class (MonadRandom) -import Data.Aeson (FromJSON, ToJSON, toJSON) -import Data.Aeson.Generic.DerivingVia -import Data.FileEmbed -import Data.List.NonEmpty -import Test.QuickCheck hiding (choose) -import Test.QuickCheck.Arbitrary.Generic -import Test.QuickCheck.Instances.UnorderedContainers () -import Text.Mustache +import Control.Monad.Random.Class (MonadRandom) +import Data.Aeson (FromJSON, ToJSON, toJSON) +import qualified Data.Aeson as JSON +import Data.Aeson.Generic.DerivingVia +import Data.FileEmbed +import Data.List.NonEmpty +import Test.QuickCheck hiding (choose) +import Test.QuickCheck.Arbitrary.Generic +import Test.QuickCheck.Instances.UnorderedContainers () +import Text.Mustache import qualified Data.Yaml as Yaml -------------------------------------------------------------------------------- -import Xanthous.Random -import Xanthous.Orphans () +import Xanthous.Random +import Xanthous.Orphans () -------------------------------------------------------------------------------- data Message = Single Template | Choice (NonEmpty Template) @@ -98,3 +100,8 @@ message :: (MonadRandom m, ToJSON params) => [Text] -> params -> m Text message path params = maybe notFound (`render` params) $ messages ^? ix path where notFound = pure "Message not found" + +message_ :: (MonadRandom m) => [Text] -> m Text +message_ path = maybe notFound (`render` JSON.object []) $ messages ^? ix path + where + notFound = pure "Message not found" diff --git a/src/Xanthous/Util.hs b/src/Xanthous/Util.hs index 3a7c10ace18e..814f9371150f 100644 --- a/src/Xanthous/Util.hs +++ b/src/Xanthous/Util.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE QuantifiedConstraints #-} - +-------------------------------------------------------------------------------- module Xanthous.Util ( EqEqProp(..) , EqProp(..) @@ -25,13 +25,18 @@ module Xanthous.Util -- ** Bag sequence algorithms , takeWhileInclusive , smallestNotIn - ) where + -- * 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 diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml index ae9ca060bfef..1c5692ddfec0 100644 --- a/src/Xanthous/messages.yaml +++ b/src/Xanthous/messages.yaml @@ -1,4 +1,4 @@ -welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside? +welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside? Use hjklybnu to move. dead: - You have died... - You die... @@ -54,3 +54,11 @@ eat: - You search your pockets for something edible, and come up short. menuPrompt: What would you like to eat? eat: You eat the {{item.itemType.name}}. + +read: + prompt: Direction to read (hjklybnu.)? + nothing: "There's nothing there to read" + result: "\"{{message}}\"" + +tutorial: + message1: The caves are dark and full of nightmarish creatures - and you are likely to perish without food. Seek out sustenance, and pick it up with , |