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…
	
	Add table
		Add a link
		
	
		Reference in a new issue