about summary refs log tree commit diff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Xanthous/App.hs40
-rw-r--r--src/Xanthous/Entities/Character.hs3
-rw-r--r--src/Xanthous/Entities/Creature.hs14
-rw-r--r--src/Xanthous/Entities/RawTypes.hs5
-rw-r--r--src/Xanthous/Generators.hs15
-rw-r--r--src/Xanthous/Generators/LevelContents.hs43
-rw-r--r--src/Xanthous/messages.yaml9
7 files changed, 95 insertions, 34 deletions
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index fce2beed13c1..8353df437b41 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 924c1857a8ae..9423f2dc96b0 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 c660a6cdf5d4..5151f78b3061 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 94f650545325..3fb89c58ba3b 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 832a3d8fdc1d..7bcf4da0515e 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 87b2a28974f4..583bdcbd6729 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 4d7b0003fac7..7590db2e2050 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}}!
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-11-06T12ยท23+0000