From 05da490185e970b2cfdf6c61f69932fa373993f6 Mon Sep 17 00:00:00 2001 From: Griffin Smith Date: Sun, 29 Sep 2019 10:54:52 -0400 Subject: Gormlaks attack back When gormlaks see the character, they step towards them and attack dealing 1 damage when adjacent. Characters have hitpoints now, displayed at the bottom of the game screen, and when the game is over they die. --- src/Xanthous/AI/Gormlak.hs | 45 ++++++++++++++--------- src/Xanthous/App.hs | 11 ++++-- src/Xanthous/Data.hs | 63 ++++++++++++++++++++++++++++++++- src/Xanthous/Data/EntityMap.hs | 3 ++ src/Xanthous/Data/EntityMap/Graphics.hs | 5 +++ src/Xanthous/Entities/Character.hs | 10 ++++++ src/Xanthous/Game/Draw.hs | 18 ++++++++-- src/Xanthous/Game/Prompt.hs | 10 ++++++ src/Xanthous/Util/Graphics.hs | 2 +- src/Xanthous/messages.yaml | 4 +++ test/Xanthous/DataSpec.hs | 14 ++++++++ 11 files changed, 163 insertions(+), 22 deletions(-) diff --git a/src/Xanthous/AI/Gormlak.hs b/src/Xanthous/AI/Gormlak.hs index 6ea9254ba2..c9af688426 100644 --- a/src/Xanthous/AI/Gormlak.hs +++ b/src/Xanthous/AI/Gormlak.hs @@ -7,18 +7,22 @@ import Xanthous.Prelude hiding (lines) import Data.Coerce import Control.Monad.State import Control.Monad.Random +import Data.Aeson (object) +import qualified Data.Aeson as A -------------------------------------------------------------------------------- -import Xanthous.Data (Positioned(..), positioned) +import Xanthous.Data (Positioned(..), diffPositions, stepTowards, isUnit) import Xanthous.Data.EntityMap import qualified Xanthous.Entities.Creature as Creature import Xanthous.Entities.Creature (Creature) -import Xanthous.Entities.Character (Character) +import Xanthous.Entities.Character (Character, characterHitpoints) import qualified Xanthous.Entities.RawTypes as Raw import Xanthous.Entities (Entity(..), Brain(..), brainVia) import Xanthous.Game.State (entities, GameState, entityIs) -import Xanthous.Game.Lenses (Collision(..), collisionAt) -import Xanthous.Data.EntityMap.Graphics (linesOfSight) +import Xanthous.Game.Lenses + ( Collision(..), collisionAt, character, characterPosition ) +import Xanthous.Data.EntityMap.Graphics (linesOfSight, canSee) import Xanthous.Random +import Xanthous.Monad (say) -------------------------------------------------------------------------------- stepGormlak @@ -26,28 +30,37 @@ stepGormlak => Positioned Creature -> m (Positioned Creature) stepGormlak pe@(Positioned pos creature) = do - lines <- uses entities $ linesOfSight pos (Creature.visionRadius creature) - line <- choose $ weightedBy length lines - -- traceShowM ("current position", pos) - -- traceShowM ("lines", (headMay <=< tailMay) <$> lines) - let newPos = fromMaybe pos - $ fmap fst - . headMay - =<< tailMay - =<< line + newPos <- do + canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos vision + if canSeeCharacter + then do + charPos <- use characterPosition + if isUnit (pos `diffPositions` charPos) + then attackCharacter $> charPos + else pure $ pos `stepTowards` charPos + else do + lines <- uses entities $ linesOfSight pos (Creature.visionRadius creature) + line <- choose $ weightedBy length lines + pure $ fromMaybe pos $ fmap fst . headMay =<< tailMay =<< line collisionAt newPos >>= \case Nothing -> pure $ Positioned newPos creature Just Stop -> pure pe Just Combat -> do ents <- use $ entities . atPosition newPos - if | any (entityIs @Creature) ents -> pure pe - | any (entityIs @Character) ents -> undefined - | otherwise -> pure pe + when (any (entityIs @Character) ents) attackCharacter + pure pe + + where + vision = Creature.visionRadius creature + attackCharacter = do + say ["combat", "creatureAttack"] $ object [ "creature" A..= creature ] + character . characterHitpoints -= 1 newtype GormlakBrain = GormlakBrain Creature instance Brain GormlakBrain where step = fmap coerce . stepGormlak . coerce + -------------------------------------------------------------------------------- instance Brain Creature where step = brainVia GormlakBrain diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs index 1632c39e58..02f6f0987d 100644 --- a/src/Xanthous/App.hs +++ b/src/Xanthous/App.hs @@ -13,6 +13,7 @@ import Control.Monad.Random (MonadRandom) import Control.Monad.State.Class (modify) import Data.Aeson (object, ToJSON) import qualified Data.Aeson as A +import System.Exit -------------------------------------------------------------------------------- import Xanthous.Command import Xanthous.Data @@ -32,13 +33,12 @@ import Xanthous.Messages (message) import Xanthous.Util.Inflection (toSentence) -------------------------------------------------------------------------------- import qualified Xanthous.Entities.Character as Character -import Xanthous.Entities.Character (characterName) +import Xanthous.Entities.Character 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 import qualified Xanthous.Generators.CaveAutomata as CaveAutomata -------------------------------------------------------------------------------- @@ -87,6 +87,11 @@ stepGame = do pEntity' <- step pEntity entities . ix eid .= pEntity' + whenM (uses (character . characterHitpoints) (== 0)) + . prompt_ @'Continue ["dead"] Uncancellable + . const . lift . liftIO + $ exitSuccess + -------------------------------------------------------------------------------- handleEvent :: BrickEvent Name () -> AppM (Next GameState) @@ -189,6 +194,8 @@ handlePromptEvent _ (Prompt _ SDirectionPrompt _ cb) continue handlePromptEvent _ (Prompt _ SDirectionPrompt _ _) _ = continue +handlePromptEvent _ (Prompt _ SContinue _ _) _ = continue + handlePromptEvent _ _ _ = undefined prompt diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs index ff9da6280b..ff11a8da7f 100644 --- a/src/Xanthous/Data.hs +++ b/src/Xanthous/Data.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RoleAnnotations #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveTraversable #-} @@ -8,7 +9,8 @@ -- | Common data types for Xanthous -------------------------------------------------------------------------------- module Xanthous.Data - ( Position(..) + ( -- * + Position(..) , x , y @@ -19,6 +21,10 @@ module Xanthous.Data , loc , _Position , positionFromPair + , addPositions + , diffPositions + , stepTowards + , isUnit -- * , Dimensions'(..) @@ -31,6 +37,7 @@ module Xanthous.Data , opposite , move , asPosition + , directionOf -- * , Neighbors(..) @@ -47,6 +54,7 @@ import Brick (Location(Location), Edges(..)) -------------------------------------------------------------------------------- import Xanthous.Util (EqEqProp(..), EqProp) import Xanthous.Orphans () +import Xanthous.Util.Graphics -------------------------------------------------------------------------------- data Position where @@ -111,6 +119,25 @@ _Position = iso hither yon positionFromPair :: (Integral i, Integral j) => (i, j) -> Position positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j) +-- | Add two positions +-- +-- Operation for the additive group on positions +addPositions :: Position -> Position -> Position +addPositions = (<>) + +-- | Subtract two positions. +-- +-- diffPositions pos₁ pos₂ = pos₁ `addPositions` (invert pos₂) +diffPositions :: Position -> Position -> Position +diffPositions (Position x₁ y₁) (Position x₂ y₂) = Position (x₁ - x₂) (y₁ - y₂) + +-- | Is this position a unit position? or: When taken as a difference, does this +-- position represent a step of one tile? +-- +-- ∀ dir :: Direction. isUnit ('asPosition' dir) +isUnit :: Position -> Bool +isUnit (Position px py) = abs px == 1 || abs py == 1 + -------------------------------------------------------------------------------- data Dimensions' a = Dimensions @@ -169,6 +196,38 @@ move Here = id asPosition :: Direction -> Position asPosition dir = move dir mempty +-- | Returns the direction that a given position is from a given source position +directionOf + :: Position -- ^ Source + -> Position -- ^ Target + -> Direction +directionOf (Position x₁ y₁) (Position x₂ y₂) = + case (x₁ `compare` x₂, y₁ `compare` y₂) of + (EQ, EQ) -> Here + (EQ, LT) -> Down + (EQ, GT) -> Up + (LT, EQ) -> Right + (GT, EQ) -> Left + + (LT, LT) -> DownRight + (GT, LT) -> DownLeft + + (LT, GT) -> UpRight + (GT, GT) -> UpLeft + +-- | Take one (potentially diagonal) step towards the given position +-- +-- ∀ src tgt. isUnit (src `diffPositions` (src `stepTowards tgt`)) +stepTowards + :: Position -- ^ Source + -> Position -- ^ Target + -> Position +stepTowards (view _Position -> p₁) (view _Position -> p₂) + | p₁ == p₂ = _Position # p₁ + | otherwise = + let (_:p:_) = line p₁ p₂ + in _Position # p + -------------------------------------------------------------------------------- data Neighbors a = Neighbors @@ -229,3 +288,5 @@ neighborDirections = Neighbors neighborPositions :: Position -> Neighbors Position neighborPositions pos = (`move` pos) <$> neighborDirections + +-------------------------------------------------------------------------------- diff --git a/src/Xanthous/Data/EntityMap.hs b/src/Xanthous/Data/EntityMap.hs index 5b5e8a063f..a068828a15 100644 --- a/src/Xanthous/Data/EntityMap.hs +++ b/src/Xanthous/Data/EntityMap.hs @@ -110,6 +110,9 @@ instance TraversableWithIndex EntityID EntityMap where itraversed = byID . itraversed . rmap sequenceA . distrib itraverse = itraverseOf itraversed +type instance Element (EntityMap a) = a +instance MonoFoldable (EntityMap a) + emptyEntityMap :: EntityMap a emptyEntityMap = EntityMap mempty mempty 0 diff --git a/src/Xanthous/Data/EntityMap/Graphics.hs b/src/Xanthous/Data/EntityMap/Graphics.hs index 3124c6a334..ace5ae49e8 100644 --- a/src/Xanthous/Data/EntityMap/Graphics.hs +++ b/src/Xanthous/Data/EntityMap/Graphics.hs @@ -4,6 +4,7 @@ module Xanthous.Data.EntityMap.Graphics ( visiblePositions , visibleEntities , linesOfSight + , canSee ) where -------------------------------------------------------------------------------- import Xanthous.Prelude hiding (lines) @@ -49,3 +50,7 @@ visibleEntities pos visionRadius . map (\(p, es) -> over _2 (Positioned p) <$> es) . fold . linesOfSight pos visionRadius + +canSee :: Entity e => (e -> Bool) -> Position -> Word -> EntityMap e -> Bool +canSee match pos radius = any match . visibleEntities pos radius +-- ^ this might be optimizable diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs index 1c7d1bbe82..0bb5867ee5 100644 --- a/src/Xanthous/Entities/Character.hs +++ b/src/Xanthous/Entities/Character.hs @@ -4,8 +4,10 @@ module Xanthous.Entities.Character , characterName , inventory , characterDamage + , characterHitpoints , mkCharacter , pickUpItem + , isDead ) where -------------------------------------------------------------------------------- import Xanthous.Prelude @@ -24,6 +26,7 @@ data Character = Character { _inventory :: !(Vector Item) , _characterName :: !(Maybe Text) , _characterDamage :: !Word + , _characterHitpoints :: !Word } deriving stock (Show, Eq, Generic) deriving anyclass (CoArbitrary, Function) @@ -51,13 +54,20 @@ instance Entity Character where instance Arbitrary Character where arbitrary = genericArbitrary +initialHitpoints :: Word +initialHitpoints = 10 + mkCharacter :: Character mkCharacter = Character { _inventory = mempty , _characterName = Nothing , _characterDamage = 1 + , _characterHitpoints = initialHitpoints } +isDead :: Character -> Bool +isDead = (== 0) . view characterHitpoints + pickUpItem :: Item -> Character -> Character pickUpItem item = inventory %~ (item <|) diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs index b3e27f86a6..e1242f2b7a 100644 --- a/src/Xanthous/Game/Draw.hs +++ b/src/Xanthous/Game/Draw.hs @@ -14,11 +14,13 @@ import Xanthous.Data (Position(Position), x, y, loc) import Xanthous.Data.EntityMap (EntityMap, atPosition) import qualified Xanthous.Data.EntityMap as EntityMap import Xanthous.Entities +import Xanthous.Entities.Character import Xanthous.Game ( GameState(..) , entities , revealedPositions , characterPosition + , character , MessageHistory(..) , messageHistory , GamePromptState(..) @@ -42,8 +44,8 @@ drawPromptState (WaitingPrompt msg (Prompt _ pt ps _)) = case (pt, ps) of (SStringPrompt, StringPromptState edit) -> txt msg <+> renderEditor (txt . fold) True edit - (SDirectionPrompt, DirectionPromptState) -> - txt msg + (SDirectionPrompt, DirectionPromptState) -> txt msg + (SContinue, _) -> txt msg _ -> undefined drawEntities @@ -79,6 +81,17 @@ drawMap game -- character can't see them (game ^. entities) +drawCharacterInfo :: Character -> Widget Name +drawCharacterInfo ch = txt " " <+> charName <+> charHitpoints + where + charName | Just n <- ch ^. characterName + = txt n <+> txt " " + | otherwise + = emptyWidget + charHitpoints + = txt "Hitpoints: " + <+> txt (tshow $ ch ^. characterHitpoints) + drawGame :: GameState -> [Widget Name] drawGame game = pure @@ -86,3 +99,4 @@ drawGame game $ drawMessages (game ^. messageHistory) <=> drawPromptState (game ^. promptState) <=> border (drawMap game) + <=> drawCharacterInfo (game ^. character) diff --git a/src/Xanthous/Game/Prompt.hs b/src/Xanthous/Game/Prompt.hs index f0df1385f7..cb34793c6d 100644 --- a/src/Xanthous/Game/Prompt.hs +++ b/src/Xanthous/Game/Prompt.hs @@ -31,6 +31,7 @@ data PromptType where Menu :: Type -> PromptType DirectionPrompt :: PromptType PointOnMap :: PromptType + Continue :: PromptType deriving stock (Generic) instance Show PromptType where @@ -39,6 +40,7 @@ instance Show PromptType where show (Menu _) = "Menu" show DirectionPrompt = "DirectionPrompt" show PointOnMap = "PointOnMap" + show Continue = "Continue" data SPromptType :: PromptType -> Type where SStringPrompt :: SPromptType 'StringPrompt @@ -46,10 +48,12 @@ data SPromptType :: PromptType -> Type where SMenu :: forall a. SPromptType ('Menu a) SDirectionPrompt :: SPromptType 'DirectionPrompt SPointOnMap :: SPromptType 'PointOnMap + SContinue :: SPromptType 'Continue class SingPromptType pt where singPromptType :: SPromptType pt instance SingPromptType 'StringPrompt where singPromptType = SStringPrompt instance SingPromptType 'DirectionPrompt where singPromptType = SDirectionPrompt +instance SingPromptType 'Continue where singPromptType = SContinue instance Show (SPromptType pt) where show SStringPrompt = "SStringPrompt" @@ -57,6 +61,7 @@ instance Show (SPromptType pt) where show SMenu = "SMenu" show SDirectionPrompt = "SDirectionPrompt" show SPointOnMap = "SPointOnMap" + show SContinue = "SContinue" data PromptCancellable = Cancellable @@ -73,10 +78,12 @@ data PromptResult (pt :: PromptType) where MenuResult :: forall a. a -> PromptResult ('Menu a) DirectionResult :: Direction -> PromptResult 'DirectionPrompt PointOnMapResult :: Position -> PromptResult 'PointOnMap + ContinueResult :: PromptResult 'Continue data PromptState pt where StringPromptState :: Editor Text Name -> PromptState 'StringPrompt DirectionPromptState :: PromptState 'DirectionPrompt + ContinuePromptState :: PromptState 'Continue deriving stock instance Show (PromptState pt) @@ -103,6 +110,7 @@ mkPrompt c pt@SStringPrompt cb = let ps = StringPromptState $ editorText Resource.Prompt (Just 1) "" in Prompt c pt ps cb mkPrompt c pt@SDirectionPrompt cb = Prompt c pt DirectionPromptState cb +mkPrompt c pt@SContinue cb = Prompt c pt ContinuePromptState cb mkPrompt _ _ _ = undefined isCancellable :: Prompt m -> Bool @@ -116,6 +124,8 @@ submitPrompt (Prompt _ pt ps cb) = cb . StringResult . mconcat . getEditContents $ edit (SDirectionPrompt, DirectionPromptState) -> pure () -- Don't use submit with a direction prompt + (SContinue, ContinuePromptState) -> + cb ContinueResult -- Don't use submit with a direction prompt _ -> undefined -- data PromptInput :: PromptType -> Type where diff --git a/src/Xanthous/Util/Graphics.hs b/src/Xanthous/Util/Graphics.hs index 5a174d4f41..3dc2f6f14c 100644 --- a/src/Xanthous/Util/Graphics.hs +++ b/src/Xanthous/Util/Graphics.hs @@ -3,7 +3,7 @@ module Xanthous.Util.Graphics where -------------------------------------------------------------------------------- import Xanthous.Prelude -import Data.List ( unfoldr ) +import Data.List (unfoldr) -------------------------------------------------------------------------------- -- | Generate a circle centered at the given point and with the given radius diff --git a/src/Xanthous/messages.yaml b/src/Xanthous/messages.yaml index ba6d49150a..8f761ba6e7 100644 --- a/src/Xanthous/messages.yaml +++ b/src/Xanthous/messages.yaml @@ -1,4 +1,5 @@ welcome: Welcome to Xanthous, {{characterName}}! It's dangerous out there, why not stay inside? +dead: You have died... Press Enter to continue. entities: description: You see here {{entityDescriptions}} @@ -21,6 +22,9 @@ combat: hit: - You hit the {{creature.creatureType.name}} - You attack the {{creature.creatureType.name}} + creatureAttack: + - The {{creature.creatureType.name}} hits you! + - The {{creature.creatureType.name}} attacks you! killed: - You kill the {{creature.creatureType.name}}! - You've killed the {{creature.creatureType.name}}! diff --git a/test/Xanthous/DataSpec.hs b/test/Xanthous/DataSpec.hs index 2c9f9dd3f9..6b94e6a058 100644 --- a/test/Xanthous/DataSpec.hs +++ b/test/Xanthous/DataSpec.hs @@ -15,12 +15,26 @@ test = testGroup "Xanthous.Data" [ testBatch $ monoid @Position mempty , testProperty "group laws" $ \(pos :: Position) -> pos <> invert pos == mempty && invert pos <> pos == mempty + , testGroup "stepTowards laws" + [ testProperty "takes only one step" $ \src tgt -> + src /= tgt ==> + isUnit (src `diffPositions` (src `stepTowards` tgt)) + -- , testProperty "moves in the right direction" $ \src tgt -> + -- stepTowards src tgt == move (directionOf src tgt) src + ] + , testProperty "directionOf laws" $ \pos dir -> + directionOf pos (move dir pos) == dir + , testProperty "diffPositions is add inverse" $ \pos₁ pos₂ -> + diffPositions pos₁ pos₂ == addPositions pos₁ (invert pos₂) + ] , testGroup "Direction" [ testProperty "opposite is involutive" $ \(dir :: Direction) -> opposite (opposite dir) == dir , testProperty "opposite provides inverse" $ \dir -> invert (asPosition dir) == asPosition (opposite dir) + , testProperty "asPosition isUnit" $ \dir -> + dir /= Here ==> isUnit (asPosition dir) , testGroup "Move" [ testCase "Up" $ move Up mempty @?= Position 0 (-1) , testCase "Down" $ move Down mempty @?= Position 0 1 -- cgit 1.4.1