From d632a30d057f9a2775c4516570168b195c053879 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sat, 21 Sep 2019 12:43:54 -0400 Subject: Implement combat Put a bunch of gormlaks randomly on the level, and implement combat via damaging those gormlaks by one point. --- src/Xanthous/App.hs | 40 ++++++++++++++++++++++++----- src/Xanthous/Entities/Character.hs | 3 +++ src/Xanthous/Entities/Creature.hs | 14 ++++++++--- src/Xanthous/Entities/RawTypes.hs | 5 ++-- src/Xanthous/Generators.hs | 15 +++++------ src/Xanthous/Generators/LevelContents.hs | 43 +++++++++++++++++++++----------- src/Xanthous/messages.yaml | 9 +++++++ 7 files changed, 95 insertions(+), 34 deletions(-) (limited to 'src') diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index fce2beed13..8353df437b 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -36,6 +36,8 @@ import qualified Xanthous.Entities.Character as Character import Xanthous.Entities.Character (characterName) import Xanthous.Entities import Xanthous.Entities.Item (Item) +import Xanthous.Entities.Creature (Creature) +import qualified Xanthous.Entities.Creature as Creature import Xanthous.Entities.Environment (Door, open, locked) import Xanthous.Entities.Character import Xanthous.Generators @@ -64,17 +66,24 @@ runAppM appm = fmap fst . runAppT appm startEvent :: AppM () startEvent = do + initLevel + modify updateCharacterVision + prompt_ @'StringPrompt ["character", "namePrompt"] Uncancellable + $ \(StringResult s) -> do + character . characterName ?= s + say ["welcome"] =<< use character + +initLevel :: AppM () +initLevel = do level <- generateLevel SCaveAutomata CaveAutomata.defaultParams $ Dimensions 80 80 + entities <>= (SomeEntity <$> level ^. levelWalls) entities <>= (SomeEntity <$> level ^. levelItems) + entities <>= (SomeEntity <$> level ^. levelCreatures) + characterPosition .= level ^. levelCharacterPosition - modify updateCharacterVision - prompt_ @'StringPrompt ["character", "namePrompt"] Uncancellable - $ \(StringResult s) -> do - character . characterName ?= s - say ["welcome"] =<< use character handleEvent :: BrickEvent Name () -> AppM (Next GameState) handleEvent ev = use promptState >>= \case @@ -98,7 +107,7 @@ handleCommand (Move dir) = do characterPosition .= newPos describeEntitiesAt newPos modify updateCharacterVision - Just Combat -> undefined + Just Combat -> attackAt newPos Just Stop -> pure () continue @@ -214,3 +223,22 @@ describeEntitiesAt pos = let descriptions = description <$> ents in say ["entities", "description"] $ object ["entityDescriptions" A..= toSentence descriptions] + +attackAt :: Position -> AppM () +attackAt pos = + uses entities (entitiesAtPositionWithType @Creature pos) >>= \case + Empty -> say_ ["combat", "nothingToAttack"] + (creature :< Empty) -> attackCreature creature + creatures -> undefined + where + attackCreature (creatureID, creature) = do + charDamage <- use $ character . characterDamage + let creature' = Creature.damage charDamage creature + msgParams = object ["creature" A..= creature'] + if Creature.isDead creature' + then do + say ["combat", "killed"] msgParams + entities . at creatureID .= Nothing + else do + say ["combat", "hit"] msgParams + entities . ix creatureID . positioned .= SomeEntity creature' diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs index 924c1857a8..9423f2dc96 100644 --- a/src/Xanthous/Entities/Character.hs +++ b/src/Xanthous/Entities/Character.hs @@ -3,6 +3,7 @@ module Xanthous.Entities.Character ( Character(..) , characterName , inventory + , characterDamage , mkCharacter , pickUpItem ) where @@ -22,6 +23,7 @@ import Xanthous.Entities.Item data Character = Character { _inventory :: !(Vector Item) , _characterName :: !(Maybe Text) + , _characterDamage :: !Word } deriving stock (Show, Eq, Generic) deriving anyclass (CoArbitrary, Function) @@ -50,6 +52,7 @@ mkCharacter :: Character mkCharacter = Character { _inventory = mempty , _characterName = Nothing + , _characterDamage = 1 } pickUpItem :: Item -> Character -> Character diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs index c660a6cdf5..5151f78b30 100644 --- a/src/Xanthous/Entities/Creature.hs +++ b/src/Xanthous/Entities/Creature.hs @@ -7,12 +7,14 @@ module Xanthous.Entities.Creature , hitpoints , newWithType , damage + , isDead ) where -------------------------------------------------------------------------------- import Xanthous.Prelude -------------------------------------------------------------------------------- -import Data.Word import Test.QuickCheck.Arbitrary.Generic +import Data.Aeson.Generic.DerivingVia +import Data.Aeson (ToJSON, FromJSON) -------------------------------------------------------------------------------- import Xanthous.Entities.RawTypes hiding (Creature, description) import qualified Xanthous.Entities.RawTypes as Raw @@ -21,10 +23,13 @@ import Xanthous.Entities (Draw(..), Entity(..), DrawRawChar(..)) data Creature = Creature { _creatureType :: CreatureType - , _hitpoints :: Word16 + , _hitpoints :: Word } deriving stock (Eq, Show, Generic) deriving Draw via DrawRawChar "_creatureType" Creature + deriving (ToJSON, FromJSON) + via WithOptions '[ FieldLabelModifier '[Drop 1] ] + Creature makeLenses ''Creature instance Arbitrary Creature where @@ -39,8 +44,11 @@ newWithType _creatureType = let _hitpoints = _creatureType ^. maxHitpoints in Creature {..} -damage :: Word16 -> Creature -> Creature +damage :: Word -> Creature -> Creature damage amount = hitpoints %~ \hp -> if hp <= amount then 0 else hp - amount + +isDead :: Creature -> Bool +isDead = views hitpoints (== 0) diff --git a/src/Xanthous/Entities/RawTypes.hs b/src/Xanthous/Entities/RawTypes.hs index 94f6505453..3fb89c58ba 100644 --- a/src/Xanthous/Entities/RawTypes.hs +++ b/src/Xanthous/Entities/RawTypes.hs @@ -19,7 +19,6 @@ import Test.QuickCheck import Test.QuickCheck.Arbitrary.Generic import Data.Aeson.Generic.DerivingVia import Data.Aeson (ToJSON, FromJSON) -import Data.Word -------------------------------------------------------------------------------- import Xanthous.Entities (EntityChar, HasChar(..)) -------------------------------------------------------------------------------- @@ -27,12 +26,12 @@ data CreatureType = CreatureType { _name :: Text , _description :: Text , _char :: EntityChar - , _maxHitpoints :: Word16 + , _maxHitpoints :: Word , _friendly :: Bool } deriving stock (Show, Eq, Generic) deriving anyclass (NFData) - deriving (FromJSON) + deriving (ToJSON, FromJSON) via WithOptions '[ FieldLabelModifier '[Drop 1] ] CreatureType makeFieldsNoPrefix ''CreatureType diff --git a/src/Xanthous/Generators.hs b/src/Xanthous/Generators.hs index 832a3d8fdc..7bcf4da051 100644 --- a/src/Xanthous/Generators.hs +++ b/src/Xanthous/Generators.hs @@ -12,6 +12,7 @@ module Xanthous.Generators , Level(..) , levelWalls , levelItems + , levelCreatures , levelCharacterPosition , generateLevel ) where @@ -29,7 +30,8 @@ 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 +import Xanthous.Entities.Item (Item) +import Xanthous.Entities.Creature (Creature) -------------------------------------------------------------------------------- data Generator = CaveAutomata @@ -38,9 +40,6 @@ data Generator = CaveAutomata data SGenerator (gen :: Generator) where SCaveAutomata :: SGenerator 'CaveAutomata -data AGenerator where - AGenerator :: forall gen. SGenerator gen -> AGenerator - type family Params (gen :: Generator) :: Type where Params 'CaveAutomata = CaveAutomata.Params @@ -89,9 +88,10 @@ cellsToWalls cells = foldl' maybeInsertWall mempty . assocs $ cells -------------------------------------------------------------------------------- data Level = Level - { _levelWalls :: EntityMap Wall - , _levelItems :: EntityMap Item - , _levelCharacterPosition :: Position + { _levelWalls :: !(EntityMap Wall) + , _levelItems :: !(EntityMap Item) + , _levelCreatures :: !(EntityMap Creature) + , _levelCharacterPosition :: !Position } makeLenses ''Level @@ -101,5 +101,6 @@ generateLevel gen ps dims = do let cells = generate gen ps dims rand _levelWalls = cellsToWalls cells _levelItems <- randomItems cells + _levelCreatures <- randomCreatures cells _levelCharacterPosition <- chooseCharacterPosition cells pure Level {..} diff --git a/src/Xanthous/Generators/LevelContents.hs b/src/Xanthous/Generators/LevelContents.hs index 87b2a28974..583bdcbd67 100644 --- a/src/Xanthous/Generators/LevelContents.hs +++ b/src/Xanthous/Generators/LevelContents.hs @@ -2,6 +2,7 @@ module Xanthous.Generators.LevelContents ( chooseCharacterPosition , randomItems + , randomCreatures ) where -------------------------------------------------------------------------------- import Xanthous.Prelude @@ -13,28 +14,40 @@ 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 Xanthous.Entities.Raws (rawsWithType, RawType) import qualified Xanthous.Entities.Item as Item +import Xanthous.Entities.Item (Item) +import qualified Xanthous.Entities.Creature as Creature +import Xanthous.Entities.Creature (Creature) -------------------------------------------------------------------------------- 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 +randomItems = randomEntities Item.newWithType (0.0004, 0.001) + +randomCreatures :: MonadRandom m => Cells -> m (EntityMap Creature) +randomCreatures = randomEntities Creature.newWithType (0.0007, 0.003) + +randomEntities + :: forall entity raw m. (MonadRandom m, RawType raw) + => (raw -> entity) + -> (Float, Float) + -> Cells + -> m (EntityMap entity) +randomEntities newWithType sizeRange cells = + case fromNullable $ rawsWithType @raw of + Nothing -> pure mempty + Just raws -> do + let len = rangeSize $ bounds cells + (numEntities :: Int) <- floor . (* fromIntegral len) <$> getRandomR sizeRange + entities <- for [0..numEntities] $ const $ do + pos <- randomPosition cells + raw <- choose raws + let entity = newWithType raw + pure (pos, entity) + pure $ _EntityMap # entities randomPosition :: MonadRandom m => Cells -> m Position randomPosition cells = fmap positionFromPair . choose $ impureNonNull candidates diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml index 4d7b0003fa..7590db2e20 100644 --- a/src/Xanthous/messages.yaml +++ b/src/Xanthous/messages.yaml @@ -15,3 +15,12 @@ open: character: namePrompt: "What's your name? " + +combat: + nothingToAttack: There's nothing to attack there + hit: + - You hit the {{creature.creatureType.name}} + - You attack the {{creature.creatureType.name}} + killed: + - You kill the {{creature.creatureType.name}}! + - You've killed the {{creature.creatureType.name}}! -- cgit 1.4.1