From 62a2e05ef222dd69263b819a400a83f8910816f9 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Thu, 19 Sep 2019 13:56:14 -0400 Subject: 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. --- package.yaml | 1 + src/Main.hs | 2 +- src/Xanthous/App.hs | 50 ++++++++++++++------------ src/Xanthous/Command.hs | 5 ++- src/Xanthous/Data/EntityMap/Graphics.hs | 9 ++++- src/Xanthous/Entities.hs | 48 ++++++++++++++++++++++--- src/Xanthous/Entities/Arbitrary.hs | 2 +- src/Xanthous/Entities/Character.hs | 19 ++++++++-- src/Xanthous/Entities/Creature.hs | 25 +++++++------ src/Xanthous/Entities/Item.hs | 35 +++++++++++++++++++ src/Xanthous/Entities/RawTypes.hs | 24 +++++++------ src/Xanthous/Entities/Raws.hs | 38 +++++++++++++++++--- src/Xanthous/Entities/Raws/noodles.yaml | 8 +++++ src/Xanthous/Game.hs | 30 +++++++--------- src/Xanthous/Game/Draw.hs | 24 ++++++++----- src/Xanthous/Generators.hs | 41 ++++++++++++++++++++-- src/Xanthous/Generators/LevelContents.hs | 40 ++++++++++++++++----- src/Xanthous/Orphans.hs | 60 ++++++++++++++++++++++++++------ src/Xanthous/messages.yaml | 3 ++ xanthous.cabal | 7 +++- 20 files changed, 365 insertions(+), 106 deletions(-) create mode 100644 src/Xanthous/Entities/Item.hs create mode 100644 src/Xanthous/Entities/Raws/noodles.yaml diff --git a/package.yaml b/package.yaml index 7df7234c160d..953fb0947b8a 100644 --- a/package.yaml +++ b/package.yaml @@ -33,6 +33,7 @@ dependencies: - filepath - generic-arbitrary - generic-monoid +- generic-lens - groups - lens - megaparsec diff --git a/src/Main.hs b/src/Main.hs index 2da277b64071..547dc92f4023 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -8,7 +8,7 @@ import System.Random import Xanthous.Game (getInitialState) import Xanthous.App (makeApp) import Xanthous.Generators - ( GeneratorInput(..) + ( GeneratorInput , parseGeneratorInput , generateFromInput , showCells diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index d4cc8d2b4fda..0f49b4d8007c 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -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) diff --git a/src/Xanthous/Command.hs b/src/Xanthous/Command.hs index ee9a7ad50dd2..94c8075b34ee 100644 --- a/src/Xanthous/Command.hs +++ b/src/Xanthous/Command.hs @@ -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 diff --git a/src/Xanthous/Data/EntityMap/Graphics.hs b/src/Xanthous/Data/EntityMap/Graphics.hs index 21a380a72c0a..9dcc02b8e88f 100644 --- a/src/Xanthous/Data/EntityMap/Graphics.hs +++ b/src/Xanthous/Data/EntityMap/Graphics.hs @@ -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 diff --git a/src/Xanthous/Entities.hs b/src/Xanthous/Entities.hs index 223c8d769ba4..e47e820f27ab 100644 --- a/src/Xanthous/Entities.hs +++ b/src/Xanthous/Entities.hs @@ -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] - --------------------------------------------------------------------------------- diff --git a/src/Xanthous/Entities/Arbitrary.hs b/src/Xanthous/Entities/Arbitrary.hs index 9153722d9b12..480282cff6a2 100644 --- a/src/Xanthous/Entities/Arbitrary.hs +++ b/src/Xanthous/Entities/Arbitrary.hs @@ -14,6 +14,6 @@ import Xanthous.Entities.Environment instance Arbitrary SomeEntity where arbitrary = Gen.oneof - [ pure $ SomeEntity Character + [ SomeEntity <$> arbitrary @Character , pure $ SomeEntity Wall ] diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs index 246e55071cb8..3b2b320004e2 100644 --- a/src/Xanthous/Entities/Character.hs +++ b/src/Xanthous/Entities/Character.hs @@ -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 <|) + diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs index 5af24a8cd3eb..024859473f21 100644 --- a/src/Xanthous/Entities/Creature.hs +++ b/src/Xanthous/Entities/Creature.hs @@ -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 diff --git a/src/Xanthous/Entities/Item.hs b/src/Xanthous/Entities/Item.hs new file mode 100644 index 000000000000..baf4be2f5426 --- /dev/null +++ b/src/Xanthous/Entities/Item.hs @@ -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 diff --git a/src/Xanthous/Entities/RawTypes.hs b/src/Xanthous/Entities/RawTypes.hs index 88087a5dab61..1546d85e4562 100644 --- a/src/Xanthous/Entities/RawTypes.hs +++ b/src/Xanthous/Entities/RawTypes.hs @@ -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 diff --git a/src/Xanthous/Entities/Raws.hs b/src/Xanthous/Entities/Raws.hs index 4a4cba8c9a19..e1bb429a0f0d 100644 --- a/src/Xanthous/Entities/Raws.hs +++ b/src/Xanthous/Entities/Raws.hs @@ -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 diff --git a/src/Xanthous/Entities/Raws/noodles.yaml b/src/Xanthous/Entities/Raws/noodles.yaml new file mode 100644 index 000000000000..120087d48357 --- /dev/null +++ b/src/Xanthous/Entities/Raws/noodles.yaml @@ -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 diff --git a/src/Xanthous/Game.hs b/src/Xanthous/Game.hs index ed65217e627b..777e05ee4149 100644 --- a/src/Xanthous/Game.hs +++ b/src/Xanthous/Game.hs @@ -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 diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs index bb6508acdff7..8deb20ff84cb 100644 --- a/src/Xanthous/Game/Draw.hs +++ b/src/Xanthous/Game/Draw.hs @@ -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] diff --git a/src/Xanthous/Generators.hs b/src/Xanthous/Generators.hs index 6e2e89d14a14..832a3d8fdc1d 100644 --- a/src/Xanthous/Generators.hs +++ b/src/Xanthous/Generators.hs @@ -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 {..} diff --git a/src/Xanthous/Generators/LevelContents.hs b/src/Xanthous/Generators/LevelContents.hs index f8d9b8a2045a..9192674ba7a9 100644 --- a/src/Xanthous/Generators/LevelContents.hs +++ b/src/Xanthous/Generators/LevelContents.hs @@ -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. diff --git a/src/Xanthous/Orphans.hs b/src/Xanthous/Orphans.hs index c84756eb1e67..22325f636637 100644 --- a/src/Xanthous/Orphans.hs +++ b/src/Xanthous/Orphans.hs @@ -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 diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml index d383cf619603..5bb11ab05945 100644 --- a/src/Xanthous/messages.yaml +++ b/src/Xanthous/messages.yaml @@ -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 diff --git a/xanthous.cabal b/xanthous.cabal index b625105b1b03..ef3498af060c 100644 --- a/xanthous.cabal +++ b/xanthous.cabal @@ -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 -- cgit 1.4.1