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
- generic-arbitrary
- generic-monoid
- generic-lens
- groups
- lens
- megaparsec

View file

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

View file

@ -1,3 +1,4 @@
{-# LANGUAGE ViewPatterns #-}
module Xanthous.App (makeApp) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
@ -7,17 +8,16 @@ import Graphics.Vty.Attributes (defAttr)
import Graphics.Vty.Input.Events (Event(EvKey))
import Control.Monad.State (get)
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.Data
( move
, Position(..)
, Dimensions'(Dimensions)
, Dimensions
, positionFromPair
, positioned
)
import Xanthous.Data.EntityMap (EntityMap)
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Game
import Xanthous.Game.Draw (drawGame)
import Xanthous.Monad
@ -25,12 +25,13 @@ import Xanthous.Resource (Name)
--------------------------------------------------------------------------------
import Xanthous.Entities.Creature (Creature)
import qualified Xanthous.Entities.Creature as Creature
import qualified Xanthous.Entities.Character as Character
import Xanthous.Entities.RawTypes (EntityRaw(..))
import Xanthous.Entities.Raws (raw)
import Xanthous.Entities
import Xanthous.Entities.Item (Item)
import Xanthous.Generators
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
import Xanthous.Generators.LevelContents
--------------------------------------------------------------------------------
type App = Brick.App GameState () Name
@ -56,11 +57,12 @@ testGormlak =
startEvent :: AppM ()
startEvent = do
say_ ["welcome"]
(level, charPos) <-
level <-
generateLevel SCaveAutomata CaveAutomata.defaultParams
$ Dimensions 80 80
entities <>= level
characterPosition .= charPos
entities <>= (SomeEntity <$> level ^. levelWalls)
entities <>= (SomeEntity <$> level ^. levelItems)
characterPosition .= level ^. levelCharacterPosition
modify updateCharacterVision
-- entities %= EntityMap.insertAt (Position 10 10) (SomeEntity testGormlak)
@ -84,21 +86,23 @@ handleCommand (Move dir) = do
Just Stop -> pure ()
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
messageHistory %= popMessage
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
| Move Direction
| PreviousMessage
-- | PickUp
| PickUp
commandFromKey :: Key -> [Modifier] -> Maybe Command
commandFromKey (KChar 'q') [] = Just Quit
commandFromKey (KChar 'h') [] = Just $ Move Left
commandFromKey (KChar 'j') [] = Just $ Move Down
commandFromKey (KChar 'k') [] = Just $ Move Up
@ -24,4 +25,6 @@ commandFromKey (KChar 'n') [] = Just $ Move DownRight
commandFromKey (KChar 'p') [MCtrl] = Just PreviousMessage
commandFromKey (KChar ',') [] = Just PickUp
commandFromKey _ _ = Nothing

View file

@ -1,6 +1,9 @@
{-# LANGUAGE ViewPatterns #-}
--------------------------------------------------------------------------------
module Xanthous.Data.EntityMap.Graphics where
module Xanthous.Data.EntityMap.Graphics
( visiblePositions
, visibleEntities
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
@ -11,6 +14,10 @@ import Xanthous.Entities
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
-- are *visible* (eg, not blocked by an entity that obscures vision) from that
-- point

View file

@ -7,26 +7,33 @@ module Xanthous.Entities
( Draw(..)
, DrawCharacter(..)
, DrawStyledCharacter(..)
, DrawRawChar(..)
, Entity(..)
, SomeEntity(..)
, downcastEntity
, entityIs
, _SomeEntity
, Color(..)
, KnownColor(..)
, EntityChar(..)
, HasChar(..)
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Xanthous.Prelude hiding ((.=))
--------------------------------------------------------------------------------
import Brick
import Data.Typeable
import qualified Graphics.Vty.Attributes as Vty
import qualified Graphics.Vty.Image as Vty
import Data.Aeson
import Data.Generics.Product.Fields
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic
--------------------------------------------------------------------------------
import Xanthous.Data
import Xanthous.Orphans ()
--------------------------------------------------------------------------------
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 = isJust . downcastEntity @a
_SomeEntity :: forall a. (Entity a, Typeable a) => Prism' SomeEntity a
_SomeEntity = prism' SomeEntity downcastEntity
--------------------------------------------------------------------------------
class Draw a where
@ -109,13 +120,33 @@ instance
, Vty.attrBackColor = Vty.SetTo $ colorVal @bg Proxy
, 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
{ _char :: Char
, _style :: Vty.Attr
}
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData)
deriving anyclass (NFData, CoArbitrary, Function)
instance Arbitrary EntityChar where
arbitrary = genericArbitrary
instance FromJSON EntityChar where
parseJSON (String (chr :< Empty)) = pure $ EntityChar chr Vty.defAttr
@ -132,7 +163,16 @@ instance FromJSON EntityChar where
pure EntityChar {..}
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
draw EntityChar{..} = raw $ Vty.string _style [_char]
--------------------------------------------------------------------------------

View file

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

View file

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

View file

@ -1,28 +1,33 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
-- |
module Xanthous.Entities.Creature where
import Data.Word
--------------------------------------------------------------------------------
module Xanthous.Entities.Creature
( Creature(..)
, creatureType
, hitpoints
, newWithType
, damage
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Data.Word
--------------------------------------------------------------------------------
import Xanthous.Entities.RawTypes hiding (Creature)
import Xanthous.Entities (Draw(..), Entity(..))
import Xanthous.Entities (Draw(..), Entity(..), DrawRawChar(..))
--------------------------------------------------------------------------------
data Creature = Creature
{ _creatureType :: CreatureType
, _hitpoints :: Word16
}
deriving stock (Eq, Show, Generic)
deriving Draw via DrawRawChar "_creatureType" Creature
makeLenses ''Creature
instance Entity Creature where
blocksVision _ = False
instance Draw Creature where
draw = draw .view (creatureType . char)
newWithType :: CreatureType -> Creature
newWithType _creatureType =
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 DuplicateRecordFields #-}
--------------------------------------------------------------------------------
module Xanthous.Entities.RawTypes
( CreatureType(..)
, ItemType(..)
@ -9,19 +9,20 @@ module Xanthous.Entities.RawTypes
, HasName(..)
, HasDescription(..)
, HasLongDescription(..)
, HasChar(..)
, HasMaxHitpoints(..)
, HasFriendly(..)
, _Creature
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic
import Data.Aeson.Generic.DerivingVia
import Data.Aeson (FromJSON)
import Data.Aeson (ToJSON, FromJSON)
import Data.Word
import Xanthous.Entities (EntityChar)
--------------------------------------------------------------------------------
import Xanthous.Entities (EntityChar, HasChar(..))
--------------------------------------------------------------------------------
data CreatureType = CreatureType
{ _name :: Text
, _description :: Text
@ -35,7 +36,7 @@ data CreatureType = CreatureType
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
CreatureType
makeFieldsNoPrefix ''CreatureType
--------------------------------------------------------------------------------
data ItemType = ItemType
{ _name :: Text
, _description :: Text
@ -43,12 +44,15 @@ data ItemType = ItemType
, _char :: EntityChar
}
deriving stock (Show, Eq, Generic)
deriving anyclass (NFData)
deriving (FromJSON)
deriving anyclass (NFData, CoArbitrary, Function)
deriving (ToJSON, FromJSON)
via WithOptions '[ FieldLabelModifier '[Drop 1] ]
ItemType
makeFieldsNoPrefix ''ItemType
instance Arbitrary ItemType where
arbitrary = genericArbitrary
data EntityRaw
= Creature CreatureType
| Item ItemType

View file

@ -1,17 +1,23 @@
{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
module Xanthous.Entities.Raws
( raws
, raw
, RawType(..)
, rawsWithType
, entityFromRaw
) where
--------------------------------------------------------------------------------
import Data.FileEmbed
import qualified Data.Yaml as Yaml
import Xanthous.Prelude
import System.FilePath.Posix
--------------------------------------------------------------------------------
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 = $(embedDir "src/Xanthous/Entities/Raws")
@ -26,3 +32,27 @@ raws
raw :: Text -> Maybe EntityRaw
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
( GameState(..)
, entities
, revealedEntities
, revealedPositions
, messageHistory
, randomGen
@ -35,7 +35,6 @@ import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic
import Control.Monad.State.Class
--------------------------------------------------------------------------------
import Xanthous.Util (appendVia)
import Xanthous.Data.EntityMap (EntityMap, EntityID)
import qualified Xanthous.Data.EntityMap as EntityMap
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.Character
import Xanthous.Entities.Creature
import Xanthous.Entities.Item
import Xanthous.Entities.Arbitrary ()
import Xanthous.Orphans ()
--------------------------------------------------------------------------------
@ -71,12 +71,11 @@ hideMessage NoMessageHistory = NoMessageHistory
hideMessage (MessageHistory msgs _) = MessageHistory msgs False
data GameState = GameState
{ _entities :: EntityMap SomeEntity
-- | A subset of the overall set of entities
, _revealedEntities :: EntityMap SomeEntity
, _characterEntityID :: EntityID
, _messageHistory :: MessageHistory
, _randomGen :: StdGen
{ _entities :: !(EntityMap SomeEntity)
, _revealedPositions :: !(Set Position)
, _characterEntityID :: !EntityID
, _messageHistory :: !MessageHistory
, _randomGen :: !StdGen
}
deriving stock (Show)
makeLenses ''GameState
@ -84,7 +83,7 @@ makeLenses ''GameState
instance Eq GameState where
(==) = (==) `on` \gs ->
( gs ^. entities
, gs ^. revealedEntities
, gs ^. revealedPositions
, gs ^. characterEntityID
, gs ^. messageHistory
)
@ -96,11 +95,7 @@ instance Arbitrary GameState where
_messageHistory <- arbitrary
(_characterEntityID, _entities) <- arbitrary <&>
EntityMap.insertAtReturningID charPos (SomeEntity char)
revealedPositions <- sublistOf $ EntityMap.positions _entities
let _revealedEntities = mempty &~ do
for_ revealedPositions $ \pos -> do
let ents = _entities ^. EntityMap.atPosition pos
EntityMap.atPosition pos <>= ents
_revealedPositions <- fmap setFromList . sublistOf $ EntityMap.positions _entities
_randomGen <- mkStdGen <$> arbitrary
pure $ GameState {..}
@ -114,7 +109,7 @@ getInitialState = do
(SomeEntity char)
mempty
_messageHistory = NoMessageHistory
_revealedEntities = _entities
_revealedPositions = mempty
pure GameState {..}
positionedCharacter :: Lens' GameState (Positioned Character)
@ -151,8 +146,8 @@ visionRadius = 12 -- TODO make this dynamic
updateCharacterVision :: GameState -> GameState
updateCharacterVision game =
let charPos = game ^. characterPosition
visible = visibleEntities charPos visionRadius $ game ^. entities
in game & revealedEntities %~ appendVia EntityMap.Deduplicate visible
visible = visiblePositions charPos visionRadius $ game ^. entities
in game & revealedPositions <>~ visible
--------------------------------------------------------------------------------
@ -169,4 +164,5 @@ collisionAt pos = do
pure $
if | null ents -> Nothing
| any (entityIs @Creature) ents -> pure Combat
| all (entityIs @Item) ents -> Nothing
| otherwise -> pure Stop

View file

@ -17,7 +17,7 @@ import Xanthous.Entities
import Xanthous.Game
( GameState(..)
, entities
, revealedEntities
, revealedPositions
, characterPosition
, MessageHistory(..)
, messageHistory
@ -37,28 +37,34 @@ drawMessages (MessageHistory (lastMessage :| _) True) = txt lastMessage
-- (MessageHistory (lastMessage :| _) True) -> txt lastMessage
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
-> Widget Name
drawEntities em allEnts
drawEntities visiblePositions allEnts
= vBox rows
where
entityPositions = EntityMap.positions em
entityPositions = EntityMap.positions allEnts
maxY = fromMaybe 0 $ maximumOf (folded . y) entityPositions
maxX = fromMaybe 0 $ maximumOf (folded . x) entityPositions
rows = mkRow <$> [0..maxY]
mkRow rowY = hBox $ renderEntityAt . flip Position rowY <$> [0..maxX]
renderEntityAt pos =
let neighbors = EntityMap.neighbors pos allEnts
in maybe (str " ") (drawWithNeighbors neighbors)
$ em ^? atPosition pos . folded
renderEntityAt pos
| pos `member` visiblePositions
= let neighbors = EntityMap.neighbors pos allEnts
in maybe (str " ") (drawWithNeighbors neighbors)
$ allEnts ^? atPosition pos . folded
| otherwise = str " "
drawMap :: GameState -> Widget Name
drawMap game
= viewport MapViewport Both
. showCursor Character (game ^. characterPosition . loc)
$ drawEntities
(game ^. revealedEntities)
(game ^. revealedPositions)
(game ^. entities)
drawGame :: GameState -> [Widget Name]

View file

@ -1,18 +1,35 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RecordWildCards #-}
{-# 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 System.Random (RandomGen)
import qualified Options.Applicative as Opt
import Control.Monad.Random
--------------------------------------------------------------------------------
import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
import Xanthous.Generators.Util
import Xanthous.Generators.LevelContents
import Xanthous.Data (Dimensions, Position(Position))
import Xanthous.Data.EntityMap (EntityMap)
import qualified Xanthous.Data.EntityMap as EntityMap
import Xanthous.Entities.Environment
import Xanthous.Entities.Item
--------------------------------------------------------------------------------
data Generator = CaveAutomata
@ -68,3 +85,21 @@ cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells
in EntityMap.insertAt (Position x' y') Wall em
maybeInsertWall em _ = em
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
( chooseCharacterPosition
, randomItems
) where
--------------------------------------------------------------------------------
import Xanthous.Prelude
import Xanthous.Prelude
--------------------------------------------------------------------------------
import Control.Monad.Random
import Data.Array.IArray (amap)
import Control.Monad.Random
import Data.Array.IArray (amap, bounds, rangeSize)
--------------------------------------------------------------------------------
import Xanthous.Generators.Util
import Xanthous.Random
import Xanthous.Generators.Util
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 cells = choose $ impureNonNull candidates
chooseCharacterPosition :: MonadRandom m => Cells -> m Position
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
-- 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
-- find the largest contiguous region of cells in the cave.

View file

@ -1,3 +1,4 @@
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE UndecidableInstances, PatternSynonyms #-}
@ -15,6 +16,7 @@ import qualified Data.List.NonEmpty as NonEmpty
import Data.Text.Arbitrary ()
import Graphics.Vty.Attributes
import Test.QuickCheck
import Test.QuickCheck.Arbitrary.Generic
import Text.Megaparsec (errorBundlePretty)
import Text.Megaparsec.Pos
import Text.Mustache
@ -157,15 +159,15 @@ deriving anyclass instance NFData Template
instance FromJSON Color where
parseJSON = withText "Color" $ \case
"black" -> pure black
"red" -> pure red
"green" -> pure green
"yellow" -> pure yellow
"blue" -> pure blue
"black" -> pure black
"red" -> pure red
"green" -> pure green
"yellow" -> pure yellow
"blue" -> pure blue
"magenta" -> pure magenta
"cyan" -> pure cyan
"white" -> pure white
_ -> fail "Invalid color"
"cyan" -> pure cyan
"white" -> pure white
_ -> fail "Invalid color"
instance ToJSON Color where
toJSON color
@ -180,6 +182,44 @@ instance ToJSON Color where
| otherwise = error "unimplemented"
instance (Eq a, Show a, Read a, FromJSON a) => FromJSON (MaybeDefault a) where
parseJSON Null = pure Default
parseJSON x = SetTo <$> parseJSON x
parseJSON Null = pure Default
parseJSON (String "keepCurrent") = pure KeepCurrent
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?
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
--
-- hash: 86b7d3047b95fc65f4c6489a21e8c89883981c8c5bd552b5ea83aaf70de8a7cf
-- hash: 78a45f3d5eb8c2993c219fd4214f61e9842177fa4d97667aeaedbfe3d0842165
name: xanthous
version: 0.1.0.0
@ -41,6 +41,7 @@ library
Xanthous.Entities.Creature
Xanthous.Entities.Draw.Util
Xanthous.Entities.Environment
Xanthous.Entities.Item
Xanthous.Entities.Raws
Xanthous.Entities.RawTypes
Xanthous.Game
@ -79,6 +80,7 @@ library
, file-embed
, filepath
, generic-arbitrary
, generic-lens
, generic-monoid
, groups
, lens
@ -111,6 +113,7 @@ executable xanthous
Xanthous.Entities.Creature
Xanthous.Entities.Draw.Util
Xanthous.Entities.Environment
Xanthous.Entities.Item
Xanthous.Entities.Raws
Xanthous.Entities.RawTypes
Xanthous.Game
@ -148,6 +151,7 @@ executable xanthous
, file-embed
, filepath
, generic-arbitrary
, generic-lens
, generic-monoid
, groups
, lens
@ -200,6 +204,7 @@ test-suite test
, file-embed
, filepath
, generic-arbitrary
, generic-lens
, generic-monoid
, groups
, lens