Add items and inventory

Add a new "Item" entity, which pulls from the previously-existent
ItemType raw, and add a "PickUp" command which takes the (currently
*only*) item off the ground and puts it into the inventory.
This commit is contained in:
Griffin Smith 2019-09-19 13:56:14 -04:00
parent 15895c69fe
commit 62a2e05ef2
20 changed files with 365 additions and 106 deletions

View file

@ -33,6 +33,7 @@ dependencies:
- filepath - filepath
- generic-arbitrary - generic-arbitrary
- generic-monoid - generic-monoid
- generic-lens
- groups - groups
- lens - lens
- megaparsec - megaparsec

View file

@ -8,7 +8,7 @@ import System.Random
import Xanthous.Game (getInitialState) import Xanthous.Game (getInitialState)
import Xanthous.App (makeApp) import Xanthous.App (makeApp)
import Xanthous.Generators import Xanthous.Generators
( GeneratorInput(..) ( GeneratorInput
, parseGeneratorInput , parseGeneratorInput
, generateFromInput , generateFromInput
, showCells , showCells

View file

@ -1,3 +1,4 @@
{-# LANGUAGE ViewPatterns #-}
module Xanthous.App (makeApp) where module Xanthous.App (makeApp) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Prelude import Xanthous.Prelude
@ -7,17 +8,16 @@ import Graphics.Vty.Attributes (defAttr)
import Graphics.Vty.Input.Events (Event(EvKey)) import Graphics.Vty.Input.Events (Event(EvKey))
import Control.Monad.State (get) import Control.Monad.State (get)
import Control.Monad.State.Class (modify) import Control.Monad.State.Class (modify)
import Control.Monad.Random (getRandom) import Data.Aeson (object)
import qualified Data.Aeson as A
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Command import Xanthous.Command
import Xanthous.Data import Xanthous.Data
( move ( move
, Position(..)
, Dimensions'(Dimensions) , Dimensions'(Dimensions)
, Dimensions , positioned
, positionFromPair
) )
import Xanthous.Data.EntityMap (EntityMap) import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Game import Xanthous.Game
import Xanthous.Game.Draw (drawGame) import Xanthous.Game.Draw (drawGame)
import Xanthous.Monad import Xanthous.Monad
@ -25,12 +25,13 @@ import Xanthous.Resource (Name)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
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 qualified Xanthous.Entities.Character as Character
import Xanthous.Entities.RawTypes (EntityRaw(..)) import Xanthous.Entities.RawTypes (EntityRaw(..))
import Xanthous.Entities.Raws (raw) import Xanthous.Entities.Raws (raw)
import Xanthous.Entities import Xanthous.Entities
import Xanthous.Entities.Item (Item)
import Xanthous.Generators import Xanthous.Generators
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
import Xanthous.Generators.LevelContents
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
type App = Brick.App GameState () Name type App = Brick.App GameState () Name
@ -56,11 +57,12 @@ testGormlak =
startEvent :: AppM () startEvent :: AppM ()
startEvent = do startEvent = do
say_ ["welcome"] say_ ["welcome"]
(level, charPos) <- level <-
generateLevel SCaveAutomata CaveAutomata.defaultParams generateLevel SCaveAutomata CaveAutomata.defaultParams
$ Dimensions 80 80 $ Dimensions 80 80
entities <>= level entities <>= (SomeEntity <$> level ^. levelWalls)
characterPosition .= charPos entities <>= (SomeEntity <$> level ^. levelItems)
characterPosition .= level ^. levelCharacterPosition
modify updateCharacterVision modify updateCharacterVision
-- entities %= EntityMap.insertAt (Position 10 10) (SomeEntity testGormlak) -- entities %= EntityMap.insertAt (Position 10 10) (SomeEntity testGormlak)
@ -84,21 +86,23 @@ handleCommand (Move dir) = do
Just Stop -> pure () Just Stop -> pure ()
continue continue
handleCommand PickUp = do
pos <- use characterPosition
ents <- uses entities $ EntityMap.atPositionWithIDs pos
let items = flip foldMap ents $ \(eid, view positioned -> se) ->
case downcastEntity @Item se of
Just item -> [(eid, item)]
Nothing -> []
case items of
[] -> say_ ["items", "nothingToPickUp"]
[(itemID, item)] -> do
character %= Character.pickUpItem item
entities . at itemID .= Nothing
say ["items", "pickUp"] $ object [ "item" A..= item ]
_ -> undefined
continue
handleCommand PreviousMessage = do handleCommand PreviousMessage = do
messageHistory %= popMessage messageHistory %= popMessage
continue continue
--------------------------------------------------------------------------------
generateLevel
:: SGenerator gen
-> Params gen
-> Dimensions
-> AppM (EntityMap SomeEntity, Position)
generateLevel g ps dims = do
gen <- use randomGen
let cells = generate g ps dims gen
_ <- getRandom @_ @Int -- perturb the generator, so we don't get the same level twice
charPos <- positionFromPair <$> chooseCharacterPosition cells
let level = SomeEntity <$> cellsToWalls cells
pure (level, charPos)

View file

@ -9,10 +9,11 @@ data Command
= Quit = Quit
| Move Direction | Move Direction
| PreviousMessage | PreviousMessage
-- | PickUp | PickUp
commandFromKey :: Key -> [Modifier] -> Maybe Command commandFromKey :: Key -> [Modifier] -> Maybe Command
commandFromKey (KChar 'q') [] = Just Quit commandFromKey (KChar 'q') [] = Just Quit
commandFromKey (KChar 'h') [] = Just $ Move Left commandFromKey (KChar 'h') [] = Just $ Move Left
commandFromKey (KChar 'j') [] = Just $ Move Down commandFromKey (KChar 'j') [] = Just $ Move Down
commandFromKey (KChar 'k') [] = Just $ Move Up commandFromKey (KChar 'k') [] = Just $ Move Up
@ -24,4 +25,6 @@ commandFromKey (KChar 'n') [] = Just $ Move DownRight
commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage
commandFromKey (KChar ',') [] = Just PickUp
commandFromKey _ _ = Nothing commandFromKey _ _ = Nothing

View file

@ -1,6 +1,9 @@
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
module Xanthous.Data.EntityMap.Graphics where module Xanthous.Data.EntityMap.Graphics
( visiblePositions
, visibleEntities
) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Prelude import Xanthous.Prelude
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -11,6 +14,10 @@ import Xanthous.Entities
import Xanthous.Util.Graphics (circle, line) import Xanthous.Util.Graphics (circle, line)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
visiblePositions :: Position -> Word -> EntityMap SomeEntity -> Set Position
visiblePositions pos radius = setFromList . positions . visibleEntities pos radius
-- | Given a point and a radius of vision, returns a list of all entities that -- | Given a point and a radius of vision, returns a list of all entities that
-- are *visible* (eg, not blocked by an entity that obscures vision) from that -- are *visible* (eg, not blocked by an entity that obscures vision) from that
-- point -- point

View file

@ -7,26 +7,33 @@ module Xanthous.Entities
( Draw(..) ( Draw(..)
, DrawCharacter(..) , DrawCharacter(..)
, DrawStyledCharacter(..) , DrawStyledCharacter(..)
, DrawRawChar(..)
, Entity(..) , Entity(..)
, SomeEntity(..) , SomeEntity(..)
, downcastEntity , downcastEntity
, entityIs , entityIs
, _SomeEntity
, Color(..) , Color(..)
, KnownColor(..) , KnownColor(..)
, EntityChar(..) , EntityChar(..)
, HasChar(..)
) where ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Prelude import Xanthous.Prelude hiding ((.=))
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Brick import Brick
import Data.Typeable import Data.Typeable
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 Data.Aeson import Data.Aeson
import Data.Generics.Product.Fields
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Data import Xanthous.Data
import Xanthous.Orphans ()
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
class (Show a, Eq a, Draw a) => Entity a where class (Show a, Eq a, Draw a) => Entity a where
@ -58,6 +65,10 @@ downcastEntity (SomeEntity e) = cast e
entityIs :: forall a. (Entity a, Typeable a) => SomeEntity -> Bool entityIs :: forall a. (Entity a, Typeable a) => SomeEntity -> Bool
entityIs = isJust . downcastEntity @a entityIs = isJust . downcastEntity @a
_SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a
_SomeEntity = prism' SomeEntity downcastEntity
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
class Draw a where class Draw a where
@ -109,13 +120,33 @@ instance
, Vty.attrBackColor = Vty.SetTo $ colorVal @bg Proxy , Vty.attrBackColor = Vty.SetTo $ colorVal @bg Proxy
, Vty.attrURL = Vty.Default , Vty.attrURL = Vty.Default
} }
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
class HasChar s a | s -> a where
char :: Lens' s a
{-# MINIMAL char #-}
newtype DrawRawChar (rawField :: Symbol) (a :: Type) = DrawRawChar a
instance
forall rawField a raw.
( HasField rawField a a raw raw
, HasChar raw EntityChar
) => Draw (DrawRawChar rawField a) where
draw (DrawRawChar e) = draw $ e ^. field @rawField . char
--------------------------------------------------------------------------------
data EntityChar = EntityChar data EntityChar = EntityChar
{ _char :: Char { _char :: Char
, _style :: Vty.Attr , _style :: Vty.Attr
} }
deriving stock (Show, Eq, Generic) deriving stock (Show, Eq, Generic)
deriving anyclass (NFData) deriving anyclass (NFData, CoArbitrary, Function)
instance Arbitrary EntityChar where
arbitrary = genericArbitrary
instance FromJSON EntityChar where instance FromJSON EntityChar where
parseJSON (String (chr :< Empty)) = pure $ EntityChar chr Vty.defAttr parseJSON (String (chr :< Empty)) = pure $ EntityChar chr Vty.defAttr
@ -132,7 +163,16 @@ instance FromJSON EntityChar where
pure EntityChar {..} pure EntityChar {..}
parseJSON _ = fail "Invalid type, expected string or object" parseJSON _ = fail "Invalid type, expected string or object"
instance ToJSON EntityChar where
toJSON (EntityChar chr styl)
| styl == Vty.defAttr = String $ chr <| Empty
| otherwise = object
[ "char" .= chr
, "style" .= object
[ "foreground" .= Vty.attrForeColor styl
, "background" .= Vty.attrBackColor styl
]
]
instance Draw EntityChar where instance Draw EntityChar where
draw EntityChar{..} = raw $ Vty.string _style [_char] draw EntityChar{..} = raw $ Vty.string _style [_char]
--------------------------------------------------------------------------------

View file

@ -14,6 +14,6 @@ import Xanthous.Entities.Environment
instance Arbitrary SomeEntity where instance Arbitrary SomeEntity where
arbitrary = Gen.oneof arbitrary = Gen.oneof
[ pure $ SomeEntity Character [ SomeEntity <$> arbitrary @Character
, pure $ SomeEntity Wall , pure $ SomeEntity Wall
] ]

View file

@ -1,23 +1,30 @@
{-# LANGUAGE TemplateHaskell #-}
module Xanthous.Entities.Character module Xanthous.Entities.Character
( Character(..) ( Character(..)
, mkCharacter , mkCharacter
, pickUpItem
) where ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Prelude import Xanthous.Prelude
import Test.QuickCheck import Test.QuickCheck
import Test.QuickCheck.Instances.Vector ()
import Test.QuickCheck.Arbitrary.Generic
import Brick import Brick
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Entities import Xanthous.Entities
import Xanthous.Entities.Item
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data Character = Character data Character = Character
deriving stock (Show, Eq, Ord, Generic) { _inventory :: !(Vector Item)
}
deriving stock (Show, Eq, Generic)
deriving anyclass (CoArbitrary, Function) deriving anyclass (CoArbitrary, Function)
makeLenses ''Character
scrollOffset :: Int scrollOffset :: Int
scrollOffset = 5 scrollOffset = 5
-- deriving Draw via (DrawCharacter "@" Character)
instance Draw Character where instance Draw Character where
draw _ = visibleRegion rloc rreg $ str "@" draw _ = visibleRegion rloc rreg $ str "@"
where where
@ -28,7 +35,13 @@ instance Entity Character where
blocksVision _ = False blocksVision _ = False
instance Arbitrary Character where instance Arbitrary Character where
arbitrary = pure Character arbitrary = genericArbitrary
mkCharacter :: Character mkCharacter :: Character
mkCharacter = Character mkCharacter = Character
{ _inventory = mempty
}
pickUpItem :: Item -> Character -> Character
pickUpItem item = inventory %~ (item <|)

View file

@ -1,28 +1,33 @@
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
-- | --------------------------------------------------------------------------------
module Xanthous.Entities.Creature
module Xanthous.Entities.Creature where ( Creature(..)
, creatureType
import Data.Word , hitpoints
, newWithType
, damage
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude import Xanthous.Prelude
--------------------------------------------------------------------------------
import Data.Word
--------------------------------------------------------------------------------
import Xanthous.Entities.RawTypes hiding (Creature) import Xanthous.Entities.RawTypes hiding (Creature)
import Xanthous.Entities (Draw(..), Entity(..)) import Xanthous.Entities (Draw(..), Entity(..), DrawRawChar(..))
--------------------------------------------------------------------------------
data Creature = Creature data Creature = Creature
{ _creatureType :: CreatureType { _creatureType :: CreatureType
, _hitpoints :: Word16 , _hitpoints :: Word16
} }
deriving stock (Eq, Show, Generic) deriving stock (Eq, Show, Generic)
deriving Draw via DrawRawChar "_creatureType" Creature
makeLenses ''Creature makeLenses ''Creature
instance Entity Creature where instance Entity Creature where
blocksVision _ = False blocksVision _ = False
instance Draw Creature where
draw = draw .view (creatureType . char)
newWithType :: CreatureType -> Creature newWithType :: CreatureType -> Creature
newWithType _creatureType = newWithType _creatureType =
let _hitpoints = _creatureType ^. maxHitpoints let _hitpoints = _creatureType ^. maxHitpoints

View file

@ -0,0 +1,35 @@
{-# LANGUAGE TemplateHaskell #-}
module Xanthous.Entities.Item
( Item(..)
, itemType
, newWithType
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Test.QuickCheck
import Data.Aeson (ToJSON, FromJSON)
import Data.Aeson.Generic.DerivingVia
--------------------------------------------------------------------------------
import Xanthous.Entities.RawTypes hiding (Item)
import Xanthous.Entities (Draw(..), Entity(..), DrawRawChar(..))
--------------------------------------------------------------------------------
data Item = Item
{ _itemType :: ItemType
}
deriving stock (Eq, Show, Generic)
deriving anyclass (CoArbitrary, Function)
deriving Draw via DrawRawChar "_itemType" Item
deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
Item
makeLenses ''Item
instance Arbitrary Item where
arbitrary = Item <$> arbitrary
instance Entity Item where
blocksVision _ = False
newWithType :: ItemType -> Item
newWithType = Item

View file

@ -1,6 +1,6 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
--------------------------------------------------------------------------------
module Xanthous.Entities.RawTypes module Xanthous.Entities.RawTypes
( CreatureType(..) ( CreatureType(..)
, ItemType(..) , ItemType(..)
@ -9,19 +9,20 @@ module Xanthous.Entities.RawTypes
, HasName(..) , HasName(..)
, HasDescription(..) , HasDescription(..)
, HasLongDescription(..) , HasLongDescription(..)
, HasChar(..)
, HasMaxHitpoints(..) , HasMaxHitpoints(..)
, HasFriendly(..) , HasFriendly(..)
, _Creature , _Creature
) where ) where
--------------------------------------------------------------------------------
import Xanthous.Prelude import Xanthous.Prelude
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic
import Data.Aeson.Generic.DerivingVia import Data.Aeson.Generic.DerivingVia
import Data.Aeson (FromJSON) import Data.Aeson (ToJSON, FromJSON)
import Data.Word import Data.Word
--------------------------------------------------------------------------------
import Xanthous.Entities (EntityChar) import Xanthous.Entities (EntityChar, HasChar(..))
--------------------------------------------------------------------------------
data CreatureType = CreatureType data CreatureType = CreatureType
{ _name :: Text { _name :: Text
, _description :: Text , _description :: Text
@ -35,7 +36,7 @@ data CreatureType = CreatureType
via WithOptions '[ FieldLabelModifier '[Drop 1] ] via WithOptions '[ FieldLabelModifier '[Drop 1] ]
CreatureType CreatureType
makeFieldsNoPrefix ''CreatureType makeFieldsNoPrefix ''CreatureType
--------------------------------------------------------------------------------
data ItemType = ItemType data ItemType = ItemType
{ _name :: Text { _name :: Text
, _description :: Text , _description :: Text
@ -43,12 +44,15 @@ data ItemType = ItemType
, _char :: EntityChar , _char :: EntityChar
} }
deriving stock (Show, Eq, Generic) deriving stock (Show, Eq, Generic)
deriving anyclass (NFData) deriving anyclass (NFData, CoArbitrary, Function)
deriving (FromJSON) deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ] via WithOptions '[ FieldLabelModifier '[Drop 1] ]
ItemType ItemType
makeFieldsNoPrefix ''ItemType makeFieldsNoPrefix ''ItemType
instance Arbitrary ItemType where
arbitrary = genericArbitrary
data EntityRaw data EntityRaw
= Creature CreatureType = Creature CreatureType
| Item ItemType | Item ItemType

View file

@ -1,17 +1,23 @@
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
module Xanthous.Entities.Raws module Xanthous.Entities.Raws
( raws ( raws
, raw , raw
, RawType(..)
, rawsWithType
, entityFromRaw
) where ) where
--------------------------------------------------------------------------------
import Data.FileEmbed import Data.FileEmbed
import qualified Data.Yaml as Yaml import qualified Data.Yaml as Yaml
import Xanthous.Prelude import Xanthous.Prelude
import System.FilePath.Posix import System.FilePath.Posix
--------------------------------------------------------------------------------
import Xanthous.Entities.RawTypes import Xanthous.Entities.RawTypes
import Xanthous.Entities
import qualified Xanthous.Entities.Creature as Creature
import qualified Xanthous.Entities.Item as Item
--------------------------------------------------------------------------------
rawRaws :: [(FilePath, ByteString)] rawRaws :: [(FilePath, ByteString)]
rawRaws = $(embedDir "src/Xanthous/Entities/Raws") rawRaws = $(embedDir "src/Xanthous/Entities/Raws")
@ -26,3 +32,27 @@ raws
raw :: Text -> Maybe EntityRaw raw :: Text -> Maybe EntityRaw
raw n = raws ^. at n raw n = raws ^. at n
class RawType (a :: Type) where
_RawType :: Prism' EntityRaw a
instance RawType CreatureType where
_RawType = prism' Creature $ \case
Creature c -> Just c
_ -> Nothing
instance RawType ItemType where
_RawType = prism' Item $ \case
Item i -> Just i
_ -> Nothing
rawsWithType :: forall a. RawType a => HashMap Text a
rawsWithType = mapFromList . itoListOf (ifolded . _RawType) $ raws
--------------------------------------------------------------------------------
entityFromRaw :: EntityRaw -> SomeEntity
entityFromRaw (Creature creatureType)
= SomeEntity $ Creature.newWithType creatureType
entityFromRaw (Item itemType)
= SomeEntity $ Item.newWithType itemType

View file

@ -0,0 +1,8 @@
Item:
name: noodles
description: a big bowl o' noodles
longDescription: You know exactly what kind of noodles
char:
char: 'n'
style:
foreground: yellow

View file

@ -5,7 +5,7 @@
module Xanthous.Game module Xanthous.Game
( GameState(..) ( GameState(..)
, entities , entities
, revealedEntities , revealedPositions
, messageHistory , messageHistory
, randomGen , randomGen
@ -35,7 +35,6 @@ import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic import Test.QuickCheck.Arbitrary.Generic
import Control.Monad.State.Class import Control.Monad.State.Class
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Util (appendVia)
import Xanthous.Data.EntityMap (EntityMap, EntityID) import Xanthous.Data.EntityMap (EntityMap, EntityID)
import qualified Xanthous.Data.EntityMap as EntityMap import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Data.EntityMap.Graphics import Xanthous.Data.EntityMap.Graphics
@ -43,6 +42,7 @@ import Xanthous.Data (Positioned, Position(..), positioned, position)
import Xanthous.Entities (SomeEntity(..), downcastEntity, entityIs) import Xanthous.Entities (SomeEntity(..), downcastEntity, entityIs)
import Xanthous.Entities.Character import Xanthous.Entities.Character
import Xanthous.Entities.Creature import Xanthous.Entities.Creature
import Xanthous.Entities.Item
import Xanthous.Entities.Arbitrary () import Xanthous.Entities.Arbitrary ()
import Xanthous.Orphans () import Xanthous.Orphans ()
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -71,12 +71,11 @@ hideMessage NoMessageHistory = NoMessageHistory
hideMessage (MessageHistory msgs _) = MessageHistory msgs False hideMessage (MessageHistory msgs _) = MessageHistory msgs False
data GameState = GameState data GameState = GameState
{ _entities :: EntityMap SomeEntity { _entities :: !(EntityMap SomeEntity)
-- | A subset of the overall set of entities , _revealedPositions :: !(Set Position)
, _revealedEntities :: EntityMap SomeEntity , _characterEntityID :: !EntityID
, _characterEntityID :: EntityID , _messageHistory :: !MessageHistory
, _messageHistory :: MessageHistory , _randomGen :: !StdGen
, _randomGen :: StdGen
} }
deriving stock (Show) deriving stock (Show)
makeLenses ''GameState makeLenses ''GameState
@ -84,7 +83,7 @@ makeLenses ''GameState
instance Eq GameState where instance Eq GameState where
(==) = (==) `on` \gs -> (==) = (==) `on` \gs ->
( gs ^. entities ( gs ^. entities
, gs ^. revealedEntities , gs ^. revealedPositions
, gs ^. characterEntityID , gs ^. characterEntityID
, gs ^. messageHistory , gs ^. messageHistory
) )
@ -96,11 +95,7 @@ instance Arbitrary GameState where
_messageHistory <- arbitrary _messageHistory <- arbitrary
(_characterEntityID, _entities) <- arbitrary <&> (_characterEntityID, _entities) <- arbitrary <&>
EntityMap.insertAtReturningID charPos (SomeEntity char) EntityMap.insertAtReturningID charPos (SomeEntity char)
revealedPositions <- sublistOf $ EntityMap.positions _entities _revealedPositions <- fmap setFromList . sublistOf $ EntityMap.positions _entities
let _revealedEntities = mempty &~ do
for_ revealedPositions $ \pos -> do
let ents = _entities ^. EntityMap.atPosition pos
EntityMap.atPosition pos <>= ents
_randomGen <- mkStdGen <$> arbitrary _randomGen <- mkStdGen <$> arbitrary
pure $ GameState {..} pure $ GameState {..}
@ -114,7 +109,7 @@ getInitialState = do
(SomeEntity char) (SomeEntity char)
mempty mempty
_messageHistory = NoMessageHistory _messageHistory = NoMessageHistory
_revealedEntities = _entities _revealedPositions = mempty
pure GameState {..} pure GameState {..}
positionedCharacter :: Lens' GameState (Positioned Character) positionedCharacter :: Lens' GameState (Positioned Character)
@ -151,8 +146,8 @@ visionRadius = 12 -- TODO make this dynamic
updateCharacterVision :: GameState -> GameState updateCharacterVision :: GameState -> GameState
updateCharacterVision game = updateCharacterVision game =
let charPos = game ^. characterPosition let charPos = game ^. characterPosition
visible = visibleEntities charPos visionRadius $ game ^. entities visible = visiblePositions charPos visionRadius $ game ^. entities
in game & revealedEntities %~ appendVia EntityMap.Deduplicate visible in game & revealedPositions <>~ visible
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
@ -169,4 +164,5 @@ collisionAt pos = do
pure $ pure $
if | null ents -> Nothing if | null ents -> Nothing
| any (entityIs @Creature) ents -> pure Combat | any (entityIs @Creature) ents -> pure Combat
| all (entityIs @Item) ents -> Nothing
| otherwise -> pure Stop | otherwise -> pure Stop

View file

@ -17,7 +17,7 @@ import Xanthous.Entities
import Xanthous.Game import Xanthous.Game
( GameState(..) ( GameState(..)
, entities , entities
, revealedEntities , revealedPositions
, characterPosition , characterPosition
, MessageHistory(..) , MessageHistory(..)
, messageHistory , messageHistory
@ -37,28 +37,34 @@ drawMessages (MessageHistory (lastMessage :| _) True) = txt lastMessage
-- (MessageHistory (lastMessage :| _) True) -> txt lastMessage -- (MessageHistory (lastMessage :| _) True) -> txt lastMessage
drawEntities drawEntities
:: EntityMap SomeEntity -- ^ visible entities :: Set Position
-- ^ Positions the character has seen
-- FIXME: this will break down as soon as creatures can walk around on their
-- own, since we don't want to render things walking around when the
-- character can't see them
-> EntityMap SomeEntity -- ^ all entities -> EntityMap SomeEntity -- ^ all entities
-> Widget Name -> Widget Name
drawEntities em allEnts drawEntities visiblePositions allEnts
= vBox rows = vBox rows
where where
entityPositions = EntityMap.positions em entityPositions = EntityMap.positions allEnts
maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions
maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions
rows = mkRow <$> [0..maxY] rows = mkRow <$> [0..maxY]
mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX] mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX]
renderEntityAt pos = renderEntityAt pos
let neighbors = EntityMap.neighbors pos allEnts | pos `member` visiblePositions
= let neighbors = EntityMap.neighbors pos allEnts
in maybe (str " ") (drawWithNeighbors neighbors) in maybe (str " ") (drawWithNeighbors neighbors)
$ em ^? atPosition pos . folded $ allEnts ^? atPosition pos . folded
| otherwise = str " "
drawMap :: GameState -> Widget Name drawMap :: GameState -> Widget Name
drawMap game drawMap game
= viewport MapViewport Both = viewport MapViewport Both
. showCursor Character (game ^. characterPosition . loc) . showCursor Character (game ^. characterPosition . loc)
$ drawEntities $ drawEntities
(game ^. revealedEntities) (game ^. revealedPositions)
(game ^. entities) (game ^. entities)
drawGame :: GameState -> [Widget Name] drawGame :: GameState -> [Widget Name]

View file

@ -1,18 +1,35 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE TemplateHaskell #-}
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
module Xanthous.Generators where module Xanthous.Generators
( generate
, SGenerator(..)
, GeneratorInput
, generateFromInput
, parseGeneratorInput
, showCells
, Level(..)
, levelWalls
, levelItems
, levelCharacterPosition
, generateLevel
) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Prelude import Xanthous.Prelude hiding (Level)
import Data.Array.Unboxed import Data.Array.Unboxed
import System.Random (RandomGen) import System.Random (RandomGen)
import qualified Options.Applicative as Opt import qualified Options.Applicative as Opt
import Control.Monad.Random
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
import Xanthous.Generators.Util import Xanthous.Generators.Util
import Xanthous.Generators.LevelContents
import Xanthous.Data (Dimensions, Position(Position)) import Xanthous.Data (Dimensions, Position(Position))
import Xanthous.Data.EntityMap (EntityMap) import Xanthous.Data.EntityMap (EntityMap)
import qualified Xanthous.Data.EntityMap as EntityMap import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Entities.Environment import Xanthous.Entities.Environment
import Xanthous.Entities.Item
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
data Generator = CaveAutomata data Generator = CaveAutomata
@ -68,3 +85,21 @@ cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells
in EntityMap.insertAt (Position x' y') Wall em in EntityMap.insertAt (Position x' y') Wall em
maybeInsertWall em _ = em maybeInsertWall em _ = em
surroundedOnAllSides pos = numAliveNeighbors cells pos == 8 surroundedOnAllSides pos = numAliveNeighbors cells pos == 8
--------------------------------------------------------------------------------
data Level = Level
{ _levelWalls :: EntityMap Wall
, _levelItems :: EntityMap Item
, _levelCharacterPosition :: Position
}
makeLenses ''Level
generateLevel :: MonadRandom m => SGenerator gen -> Params gen -> Dimensions -> m Level
generateLevel gen ps dims = do
rand <- mkStdGen <$> getRandom
let cells = generate gen ps dims rand
_levelWalls = cellsToWalls cells
_levelItems <- randomItems cells
_levelCharacterPosition <- chooseCharacterPosition cells
pure Level {..}

View file

@ -1,21 +1,45 @@
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
module Xanthous.Generators.LevelContents module Xanthous.Generators.LevelContents
( chooseCharacterPosition ( chooseCharacterPosition
, randomItems
) where ) where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Xanthous.Prelude import Xanthous.Prelude
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import Control.Monad.Random import Control.Monad.Random
import Data.Array.IArray (amap) 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.EntityMap (EntityMap, _EntityMap)
import Xanthous.Entities.Item (Item(..))
import Xanthous.Entities.Raws
import Xanthous.Entities.RawTypes
import qualified Xanthous.Entities.Item as Item
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
chooseCharacterPosition :: MonadRandom m => Cells -> m (Word, Word) chooseCharacterPosition :: MonadRandom m => Cells -> m Position
chooseCharacterPosition cells = choose $ impureNonNull candidates chooseCharacterPosition = randomPosition
randomItems :: MonadRandom m => Cells -> m (EntityMap Item)
randomItems cells = do
let len = rangeSize $ bounds cells
(numItems :: Int) <- floor . (* fromIntegral len)
<$> getRandomR @_ @Float (0.0004, 0.001)
items <- for [0..numItems] $ const do
pos <- randomPosition cells
itemType <- fmap (fromMaybe (error "no item raws!"))
. choose . ChooseElement
$ rawsWithType @ItemType
let item = Item.newWithType itemType
pure (pos, item)
pure $ _EntityMap # items
randomPosition :: MonadRandom m => Cells -> m Position
randomPosition cells = fmap positionFromPair . choose $ impureNonNull candidates
where where
-- cells ends up with true = wall, we want true = can put a character here -- cells ends up with true = wall, we want true = can put an item here
placeableCells = amap not cells placeableCells = amap not cells
-- find the largest contiguous region of cells in the cave. -- find the largest contiguous region of cells in the cave.

View file

@ -1,3 +1,4 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE UndecidableInstances, PatternSynonyms #-} {-# LANGUAGE UndecidableInstances, PatternSynonyms #-}
@ -15,6 +16,7 @@ import qualified Data.List.NonEmpty as NonEmpty
import Data.Text.Arbitrary () import Data.Text.Arbitrary ()
import Graphics.Vty.Attributes import Graphics.Vty.Attributes
import Test.QuickCheck import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic
import Text.Megaparsec (errorBundlePretty) import Text.Megaparsec (errorBundlePretty)
import Text.Megaparsec.Pos import Text.Megaparsec.Pos
import Text.Mustache import Text.Mustache
@ -181,5 +183,43 @@ instance ToJSON Color where
instance (Eq a, Show a, Read a, FromJSON a) => FromJSON (MaybeDefault a) where instance (Eq a, Show a, Read a, FromJSON a) => FromJSON (MaybeDefault a) where
parseJSON Null = pure Default parseJSON Null = pure Default
parseJSON (String "keepCurrent") = pure KeepCurrent
parseJSON x = SetTo <$> parseJSON x parseJSON x = SetTo <$> parseJSON x
instance ToJSON a => ToJSON (MaybeDefault a) where
toJSON Default = Null
toJSON KeepCurrent = String "keepCurrent"
toJSON (SetTo x) = toJSON x
--------------------------------------------------------------------------------
instance Arbitrary Color where
arbitrary = genericArbitrary
deriving anyclass instance CoArbitrary Color
deriving anyclass instance Function Color
instance (Eq a, Show a, Read a, Arbitrary a) => Arbitrary (MaybeDefault a) where
arbitrary = oneof [ pure Default
, pure KeepCurrent
, SetTo <$> arbitrary
]
instance CoArbitrary a => CoArbitrary (MaybeDefault a) where
coarbitrary Default = variant @Int 1
coarbitrary KeepCurrent = variant @Int 2
coarbitrary (SetTo x) = variant @Int 3 . coarbitrary x
instance (Eq a, Show a, Read a, Function a) => Function (MaybeDefault a) where
function = functionShow
instance Arbitrary Attr where
arbitrary = do
attrStyle <- arbitrary
attrForeColor <- arbitrary
attrBackColor <- arbitrary
attrURL <- arbitrary
pure Attr {..}
deriving anyclass instance CoArbitrary Attr
deriving anyclass instance Function Attr

View file

@ -1 +1,4 @@
welcome: Welcome to Xanthous! It's dangerous out there, why not stay inside? welcome: Welcome to Xanthous! It's dangerous out there, why not stay inside?
items:
pickUp: You pick up the {{item.itemType.name}}
nothingToPickUp: There's nothing here to pick up

View file

@ -4,7 +4,7 @@ cabal-version: 1.12
-- --
-- see: https://github.com/sol/hpack -- see: https://github.com/sol/hpack
-- --
-- hash: 86b7d3047b95fc65f4c6489a21e8c89883981c8c5bd552b5ea83aaf70de8a7cf -- hash: 78a45f3d5eb8c2993c219fd4214f61e9842177fa4d97667aeaedbfe3d0842165
name: xanthous name: xanthous
version: 0.1.0.0 version: 0.1.0.0
@ -41,6 +41,7 @@ library
Xanthous.Entities.Creature Xanthous.Entities.Creature
Xanthous.Entities.Draw.Util Xanthous.Entities.Draw.Util
Xanthous.Entities.Environment Xanthous.Entities.Environment
Xanthous.Entities.Item
Xanthous.Entities.Raws Xanthous.Entities.Raws
Xanthous.Entities.RawTypes Xanthous.Entities.RawTypes
Xanthous.Game Xanthous.Game
@ -79,6 +80,7 @@ library
, file-embed , file-embed
, filepath , filepath
, generic-arbitrary , generic-arbitrary
, generic-lens
, generic-monoid , generic-monoid
, groups , groups
, lens , lens
@ -111,6 +113,7 @@ executable xanthous
Xanthous.Entities.Creature Xanthous.Entities.Creature
Xanthous.Entities.Draw.Util Xanthous.Entities.Draw.Util
Xanthous.Entities.Environment Xanthous.Entities.Environment
Xanthous.Entities.Item
Xanthous.Entities.Raws Xanthous.Entities.Raws
Xanthous.Entities.RawTypes Xanthous.Entities.RawTypes
Xanthous.Game Xanthous.Game
@ -148,6 +151,7 @@ executable xanthous
, file-embed , file-embed
, filepath , filepath
, generic-arbitrary , generic-arbitrary
, generic-lens
, generic-monoid , generic-monoid
, groups , groups
, lens , lens
@ -200,6 +204,7 @@ test-suite test
, file-embed , file-embed
, filepath , filepath
, generic-arbitrary , generic-arbitrary
, generic-lens
, generic-monoid , generic-monoid
, groups , groups
, lens , lens