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.

10 files changed, 149 insertions, 22 deletions

diff --git a/src/Xanthous/AI/Gormlak.hs b/src/Xanthous/AI/Gormlak.hs
index 6ea9254ba200..c9af68842635 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 1632c39e586d..02f6f0987d7c 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 ff9da6280bfb..ff11a8da7f80 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 5b5e8a063f2c..a068828a157c 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 3124c6a334cc..ace5ae49e804 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 1c7d1bbe82a6..0bb5867ee5e1 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 b3e27f86a693..e1242f2b7a2d 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 f0df1385f79d..cb34793c6d60 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 5a174d4f415b..3dc2f6f14cac 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 ba6d49150aee..8f761ba6e76d 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}}!