about summary refs log tree commit diff
path: root/src/Xanthous/Entities
diff options
context:
space:
mode:
Diffstat (limited to 'src/Xanthous/Entities')
-rw-r--r--src/Xanthous/Entities/Arbitrary.hs2
-rw-r--r--src/Xanthous/Entities/Character.hs19
-rw-r--r--src/Xanthous/Entities/Creature.hs25
-rw-r--r--src/Xanthous/Entities/Item.hs35
-rw-r--r--src/Xanthous/Entities/RawTypes.hs24
-rw-r--r--src/Xanthous/Entities/Raws.hs38
-rw-r--r--src/Xanthous/Entities/Raws/noodles.yaml8
7 files changed, 123 insertions, 28 deletions
diff --git a/src/Xanthous/Entities/Arbitrary.hs b/src/Xanthous/Entities/Arbitrary.hs
index 9153722d9b12..480282cff6a2 100644
--- a/src/Xanthous/Entities/Arbitrary.hs
+++ b/src/Xanthous/Entities/Arbitrary.hs
@@ -14,6 +14,6 @@ import           Xanthous.Entities.Environment
 
 instance Arbitrary SomeEntity where
   arbitrary = Gen.oneof
-    [ pure $ SomeEntity Character
+    [ SomeEntity <$> arbitrary @Character
     , pure $ SomeEntity Wall
     ]
diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs
index 246e55071cb8..3b2b320004e2 100644
--- a/src/Xanthous/Entities/Character.hs
+++ b/src/Xanthous/Entities/Character.hs
@@ -1,23 +1,30 @@
+{-# LANGUAGE TemplateHaskell #-}
 module Xanthous.Entities.Character
   ( Character(..)
   , mkCharacter
+  , pickUpItem
   ) where
 --------------------------------------------------------------------------------
 import Xanthous.Prelude
 import Test.QuickCheck
+import Test.QuickCheck.Instances.Vector ()
+import Test.QuickCheck.Arbitrary.Generic
 import Brick
 --------------------------------------------------------------------------------
 import Xanthous.Entities
+import Xanthous.Entities.Item
 --------------------------------------------------------------------------------
 
 data Character = Character
-  deriving stock (Show, Eq, Ord, Generic)
+  { _inventory :: !(Vector Item)
+  }
+  deriving stock (Show, Eq, Generic)
   deriving anyclass (CoArbitrary, Function)
+makeLenses ''Character
 
 scrollOffset :: Int
 scrollOffset = 5
 
--- deriving Draw via (DrawCharacter "@" Character)
 instance Draw Character where
   draw _ = visibleRegion rloc rreg $ str "@"
     where
@@ -28,7 +35,13 @@ instance Entity Character where
   blocksVision _ = False
 
 instance Arbitrary Character where
-  arbitrary = pure Character
+  arbitrary = genericArbitrary
 
 mkCharacter :: Character
 mkCharacter = Character
+  { _inventory = mempty
+  }
+
+pickUpItem :: Item -> Character -> Character
+pickUpItem item = inventory %~ (item <|)
+
diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs
index 5af24a8cd3eb..024859473f21 100644
--- a/src/Xanthous/Entities/Creature.hs
+++ b/src/Xanthous/Entities/Creature.hs
@@ -1,28 +1,33 @@
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TemplateHaskell #-}
--- |
-
-module Xanthous.Entities.Creature where
-
-import Data.Word
-
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Creature
+  ( Creature(..)
+  , creatureType
+  , hitpoints
+  , newWithType
+  , damage
+  ) where
+--------------------------------------------------------------------------------
 import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Data.Word
+--------------------------------------------------------------------------------
 import Xanthous.Entities.RawTypes hiding (Creature)
-import Xanthous.Entities (Draw(..), Entity(..))
+import Xanthous.Entities (Draw(..), Entity(..), DrawRawChar(..))
+--------------------------------------------------------------------------------
 
 data Creature = Creature
   { _creatureType :: CreatureType
   , _hitpoints :: Word16
   }
   deriving stock (Eq, Show, Generic)
+  deriving Draw via DrawRawChar "_creatureType" Creature
 makeLenses ''Creature
 
 instance Entity Creature where
   blocksVision _ = False
 
-instance Draw Creature where
-  draw = draw .view (creatureType . char)
-
 newWithType :: CreatureType -> Creature
 newWithType _creatureType =
   let _hitpoints = _creatureType ^. maxHitpoints
diff --git a/src/Xanthous/Entities/Item.hs b/src/Xanthous/Entities/Item.hs
new file mode 100644
index 000000000000..baf4be2f5426
--- /dev/null
+++ b/src/Xanthous/Entities/Item.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Xanthous.Entities.Item
+  ( Item(..)
+  , itemType
+  , newWithType
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+import Test.QuickCheck
+import Data.Aeson (ToJSON, FromJSON)
+import Data.Aeson.Generic.DerivingVia
+--------------------------------------------------------------------------------
+import Xanthous.Entities.RawTypes hiding (Item)
+import Xanthous.Entities (Draw(..), Entity(..), DrawRawChar(..))
+--------------------------------------------------------------------------------
+
+data Item = Item
+  { _itemType :: ItemType
+  }
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (CoArbitrary, Function)
+  deriving Draw via DrawRawChar "_itemType" Item
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Item
+makeLenses ''Item
+
+instance Arbitrary Item where
+  arbitrary = Item <$> arbitrary
+
+instance Entity Item where
+  blocksVision _ = False
+
+newWithType :: ItemType -> Item
+newWithType = Item
diff --git a/src/Xanthous/Entities/RawTypes.hs b/src/Xanthous/Entities/RawTypes.hs
index 88087a5dab61..1546d85e4562 100644
--- a/src/Xanthous/Entities/RawTypes.hs
+++ b/src/Xanthous/Entities/RawTypes.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-
+--------------------------------------------------------------------------------
 module Xanthous.Entities.RawTypes
   ( CreatureType(..)
   , ItemType(..)
@@ -9,19 +9,20 @@ module Xanthous.Entities.RawTypes
   , HasName(..)
   , HasDescription(..)
   , HasLongDescription(..)
-  , HasChar(..)
   , HasMaxHitpoints(..)
   , HasFriendly(..)
   , _Creature
   ) where
-
+--------------------------------------------------------------------------------
 import Xanthous.Prelude
+import Test.QuickCheck
+import Test.QuickCheck.Arbitrary.Generic
 import Data.Aeson.Generic.DerivingVia
-import Data.Aeson (FromJSON)
+import Data.Aeson (ToJSON, FromJSON)
 import Data.Word
-
-import Xanthous.Entities (EntityChar)
-
+--------------------------------------------------------------------------------
+import Xanthous.Entities (EntityChar, HasChar(..))
+--------------------------------------------------------------------------------
 data CreatureType = CreatureType
   { _name :: Text
   , _description :: Text
@@ -35,7 +36,7 @@ data CreatureType = CreatureType
        via WithOptions '[ FieldLabelModifier '[Drop 1] ]
                        CreatureType
 makeFieldsNoPrefix ''CreatureType
-
+--------------------------------------------------------------------------------
 data ItemType = ItemType
   { _name :: Text
   , _description :: Text
@@ -43,12 +44,15 @@ data ItemType = ItemType
   , _char :: EntityChar
   }
   deriving stock (Show, Eq, Generic)
-  deriving anyclass (NFData)
-  deriving (FromJSON)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
        via WithOptions '[ FieldLabelModifier '[Drop 1] ]
                        ItemType
 makeFieldsNoPrefix ''ItemType
 
+instance Arbitrary ItemType where
+  arbitrary = genericArbitrary
+
 data EntityRaw
   = Creature CreatureType
   | Item ItemType
diff --git a/src/Xanthous/Entities/Raws.hs b/src/Xanthous/Entities/Raws.hs
index 4a4cba8c9a19..e1bb429a0f0d 100644
--- a/src/Xanthous/Entities/Raws.hs
+++ b/src/Xanthous/Entities/Raws.hs
@@ -1,17 +1,23 @@
 {-# LANGUAGE TemplateHaskell #-}
-
+--------------------------------------------------------------------------------
 module Xanthous.Entities.Raws
   ( raws
   , raw
+  , RawType(..)
+  , rawsWithType
+  , entityFromRaw
   ) where
-
+--------------------------------------------------------------------------------
 import           Data.FileEmbed
 import qualified Data.Yaml as Yaml
 import           Xanthous.Prelude
 import           System.FilePath.Posix
-
+--------------------------------------------------------------------------------
 import           Xanthous.Entities.RawTypes
-
+import           Xanthous.Entities
+import qualified Xanthous.Entities.Creature as Creature
+import qualified Xanthous.Entities.Item as Item
+--------------------------------------------------------------------------------
 rawRaws :: [(FilePath, ByteString)]
 rawRaws = $(embedDir "src/Xanthous/Entities/Raws")
 
@@ -26,3 +32,27 @@ raws
 
 raw :: Text -> Maybe EntityRaw
 raw n = raws ^. at n
+
+class RawType (a :: Type) where
+  _RawType :: Prism' EntityRaw a
+
+instance RawType CreatureType where
+  _RawType = prism' Creature $ \case
+    Creature c -> Just c
+    _ -> Nothing
+
+instance RawType ItemType where
+  _RawType = prism' Item $ \case
+    Item i -> Just i
+    _ -> Nothing
+
+rawsWithType :: forall a. RawType a => HashMap Text a
+rawsWithType = mapFromList . itoListOf (ifolded . _RawType) $ raws
+
+--------------------------------------------------------------------------------
+
+entityFromRaw :: EntityRaw -> SomeEntity
+entityFromRaw (Creature creatureType)
+  = SomeEntity $ Creature.newWithType creatureType
+entityFromRaw (Item itemType)
+  = SomeEntity $ Item.newWithType itemType
diff --git a/src/Xanthous/Entities/Raws/noodles.yaml b/src/Xanthous/Entities/Raws/noodles.yaml
new file mode 100644
index 000000000000..120087d48357
--- /dev/null
+++ b/src/Xanthous/Entities/Raws/noodles.yaml
@@ -0,0 +1,8 @@
+Item:
+  name: noodles
+  description: a big bowl o' noodles
+  longDescription: You know exactly what kind of noodles
+  char:
+    char: 'n'
+    style:
+      foreground: yellow
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-11-08T09ยท26+0000