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

@@ -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
+  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
-  -- traceShowM ("current position", pos)
-  -- traceShowM ("lines", (headMay <=< tailMay) <$> lines)
-  let newPos = fromMaybe pos
-               $ fmap fst
-               . headMay
-               =<< tailMay
-               =<< line
+      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

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

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
+
+--------------------------------------------------------------------------------

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
 

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

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 <|)
 

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)

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

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}}!

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