chore(users): grfn -> aspen

Change-Id: I6c6847fac56f0a9a1a2209792e00a3aec5e672b9
Reviewed-on: https://cl.tvl.fyi/c/depot/+/10809
Autosubmit: aspen <root@gws.fyi>
Reviewed-by: sterni <sternenseemann@systemli.org>
Tested-by: BuildkiteCI
Reviewed-by: lukegb <lukegb@tvl.fyi>

users/aspen/xanthous/src/Xanthous/Entities/Character.hs

@@ -0,0 +1,241 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE RecordWildCards #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Character
+
+  ( -- * Character datatype
+    Character(..)
+  , characterName
+  , HasInventory(..)
+  , characterDamage
+  , characterHitpoints'
+  , characterHitpoints
+  , hitpointRecoveryRate
+  , speed
+  , body
+
+    -- *** Body
+  , Body(..)
+  , initialBody
+  , knuckles
+  , Knuckles(..)
+  , fistDamageChance
+  , damageKnuckles
+  , fistfightingDamage
+
+    -- * Character functions
+  , mkCharacter
+  , pickUpItem
+  , isDead
+  , isFullyHealed
+  , damage
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Brick
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Aeson (ToJSON, FromJSON)
+import           Data.Coerce (coerce)
+import           Test.QuickCheck
+import           Test.QuickCheck.Instances.Vector ()
+import           Test.QuickCheck.Arbitrary.Generic
+import           Test.QuickCheck.Gen (chooseUpTo)
+import           Test.QuickCheck.Checkers (EqProp)
+import           Control.Monad.State.Lazy (execState)
+import           Control.Monad.Trans.State.Lazy (execStateT)
+--------------------------------------------------------------------------------
+import           Xanthous.Game.State
+import           Xanthous.Entities.Item
+import           Xanthous.Entities.Common
+import           Xanthous.Data
+                 ( TicksPerTile, Hitpoints, Per, Ticks, (|*|), positioned )
+import qualified Xanthous.Entities.RawTypes as Raw
+import           Xanthous.Util (EqEqProp(EqEqProp), modifyKL)
+import           Xanthous.Monad (say_)
+--------------------------------------------------------------------------------
+
+-- | The status of the character's knuckles
+--
+-- This struct is used to track the damage and then eventual build-up of
+-- calluses when the character is fighting with their fists
+data Knuckles = Knuckles
+  { -- | How damaged are the knuckles currently, from 0 to 5?
+    --
+    -- At 0, no calluses will form
+    -- At 1 and up, the character will form calluses after a while
+    -- At 5, continuing to fistfight will deal the character even more damage
+    _knuckleDamage   :: !Word
+    -- | How built-up are the character's calluses, from 0 to 5?
+    --
+    -- Each level of calluses decreases the likelihood of being damaged when
+    -- fistfighting by 1%, up to 5 where the character will never be damaged
+    -- fistfighting
+  , _knuckleCalluses :: !Word
+
+    -- | Number of turns that have passed since the last time the knuckles were
+    -- damaged
+  , _ticksSinceDamaged :: Ticks
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving EqProp via EqEqProp Knuckles
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           Knuckles
+makeLenses ''Knuckles
+
+instance Semigroup Knuckles where
+  (Knuckles d₁ c₁ t₁) <> (Knuckles d₂ c₂ t₂) = Knuckles
+    (min (d₁ + d₂) 5)
+    (min (c₁ + c₂) 5)
+    (max t₁ t₂)
+
+instance Monoid Knuckles where
+  mempty = Knuckles 0 0 0
+
+instance Arbitrary Knuckles where
+  arbitrary = do
+    _knuckleDamage <- fromIntegral <$> chooseUpTo 5
+    _knuckleCalluses <- fromIntegral <$> chooseUpTo 5
+    _ticksSinceDamaged <- arbitrary
+    pure Knuckles{..}
+
+-- | Likelihood that the character fighting with their fists will damage
+-- themselves
+fistDamageChance :: Knuckles -> Float
+fistDamageChance knuckles
+  | calluses == 5 = 0
+  | otherwise = baseChance - (0.01 * fromIntegral calluses)
+  where
+    baseChance = 0.08
+    calluses = knuckles ^. knuckleCalluses
+
+-- | Damage the knuckles by a level (capping at the max knuckle damage)
+damageKnuckles :: Knuckles -> Knuckles
+damageKnuckles = execState $ do
+  knuckleDamage %= min 5 . succ
+  ticksSinceDamaged .= 0
+
+-- | Damage taken when fistfighting and 'fistDamageChance' has occurred
+fistfightingDamage :: Knuckles -> Hitpoints
+fistfightingDamage knuckles
+  | knuckles ^. knuckleDamage == 5 = 2
+  | otherwise = 1
+
+stepKnuckles :: Ticks -> Knuckles -> AppM Knuckles
+stepKnuckles ticks = execStateT . whenM (uses knuckleDamage (> 0)) $ do
+  ticksSinceDamaged += ticks
+  whenM (uses ticksSinceDamaged (>= 2000)) $ do
+    dam <- knuckleDamage <<.= 0
+    knuckleCalluses %= min 5 . (+ dam)
+    ticksSinceDamaged .= 0
+    lift $ say_ ["character", "body", "knuckles", "calluses"]
+
+
+-- | Status of the character's body
+data Body = Body
+  { _knuckles :: !Knuckles
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Body
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           Body
+makeLenses ''Body
+
+initialBody :: Body
+initialBody = Body { _knuckles = mempty }
+
+--------------------------------------------------------------------------------
+
+data Character = Character
+  { _inventory           :: !Inventory
+  , _characterName       :: !(Maybe Text)
+  , _characterHitpoints' :: !Double
+  , _speed               :: !TicksPerTile
+  , _body                :: !Body
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           Character
+makeFieldsNoPrefix ''Character
+
+characterHitpoints :: Character -> Hitpoints
+characterHitpoints = views characterHitpoints' floor
+
+scrollOffset :: Int
+scrollOffset = 5
+
+instance Draw Character where
+  draw _ = visibleRegion rloc rreg $ str "@"
+    where
+      rloc = Location (negate scrollOffset, negate scrollOffset)
+      rreg = (2 * scrollOffset, 2 * scrollOffset)
+  drawPriority = const maxBound -- Character should always be on top, for now
+
+instance Brain Character where
+  step ticks = execStateT $ do
+    positioned . characterHitpoints' %= \hp ->
+      if hp > fromIntegral initialHitpoints
+      then hp
+      else hp + hitpointRecoveryRate |*| ticks
+    modifyKL (positioned . body . knuckles) $ lift . stepKnuckles ticks
+
+instance Entity Character where
+  description _ = "yourself"
+  entityChar _ = "@"
+
+instance Arbitrary Character where
+  arbitrary = genericArbitrary
+
+initialHitpoints :: Hitpoints
+initialHitpoints = 10
+
+hitpointRecoveryRate :: Double `Per` Ticks
+hitpointRecoveryRate = 1.0 / (15 * coerce defaultSpeed)
+
+defaultSpeed :: TicksPerTile
+defaultSpeed = 100
+
+mkCharacter :: Character
+mkCharacter = Character
+  { _inventory           = mempty
+  , _characterName       = Nothing
+  , _characterHitpoints' = fromIntegral initialHitpoints
+  , _speed               = defaultSpeed
+  , _body                = initialBody
+  }
+
+defaultCharacterDamage :: Hitpoints
+defaultCharacterDamage = 1
+
+-- | Returns the damage that the character currently does with an attack
+-- TODO use double-handed/left-hand/right-hand here
+characterDamage :: Character -> Hitpoints
+characterDamage
+  = fromMaybe defaultCharacterDamage
+  . filter (/= 0)
+  . Just
+  . sumOf (inventory . wielded . wieldedItems . wieldableItem . Raw.damage)
+
+-- | Is the character fully healed up to or past their initial hitpoints?
+isFullyHealed :: Character -> Bool
+isFullyHealed = (>= initialHitpoints) . characterHitpoints
+
+-- | Is the character dead?
+isDead :: Character -> Bool
+isDead = (== 0) . characterHitpoints
+
+pickUpItem :: Item -> Character -> Character
+pickUpItem it = inventory . backpack %~ (it <|)
+
+damage :: Hitpoints -> Character -> Character
+damage (fromIntegral -> amount) = characterHitpoints' %~ \case
+  n | n <= amount -> 0
+    | otherwise  -> n - amount
+
+{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}

users/aspen/xanthous/src/Xanthous/Entities/Common.hs

@@ -0,0 +1,290 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+-- |
+-- Module      : Xanthous.Entities.Common
+-- Description : Common data type definitions and utilities for entities
+--
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Common
+  ( -- * Inventory
+    Inventory(..)
+  , HasInventory(..)
+  , backpack
+  , wielded
+  , items
+  , InventoryPosition(..)
+  , describeInventoryPosition
+  , inventoryPosition
+  , itemsWithPosition
+  , removeItemFromPosition
+
+    -- ** Wielded items
+  , Wielded(..)
+  , nothingWielded
+  , hands
+  , leftHand
+  , rightHand
+  , inLeftHand
+  , inRightHand
+  , doubleHanded
+  , Hand(..)
+  , itemsInHand
+  , inHand
+  , wieldInHand
+  , describeHand
+  , wieldedItems
+  , WieldedItem(..)
+  , wieldedItem
+  , wieldableItem
+  , asWieldedItem
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.Aeson (ToJSON, FromJSON)
+import           Data.Aeson.Generic.DerivingVia
+import           Test.QuickCheck
+import           Test.QuickCheck.Checkers (EqProp)
+--------------------------------------------------------------------------------
+import           Xanthous.Data (Positioned(..), positioned)
+import           Xanthous.Util.QuickCheck
+import           Xanthous.Game.State
+import           Xanthous.Entities.Item
+import           Xanthous.Entities.RawTypes (WieldableItem, wieldable)
+import           Xanthous.Util (removeFirst, EqEqProp(..))
+--------------------------------------------------------------------------------
+
+data WieldedItem = WieldedItem
+  { _wieldedItem :: Item
+  , _wieldableItem :: WieldableItem
+    -- ^ Invariant: item ^. itemType . wieldable ≡ Just wieldableItem
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           WieldedItem
+makeFieldsNoPrefix ''WieldedItem
+
+asWieldedItem :: Prism' Item WieldedItem
+asWieldedItem = prism' hither yon
+ where
+   yon item = WieldedItem item <$> item ^. itemType . wieldable
+   hither (WieldedItem item _) = item
+
+instance Brain WieldedItem where
+  step ticks (Positioned p wi) =
+    over positioned (\i -> WieldedItem i $ wi ^. wieldableItem)
+    <$> step ticks (Positioned p $ wi ^. wieldedItem)
+
+instance Draw WieldedItem where
+  draw = draw . view wieldedItem
+
+instance Entity WieldedItem where
+  entityAttributes = entityAttributes . view wieldedItem
+  description = description . view wieldedItem
+  entityChar = entityChar . view wieldedItem
+
+instance Arbitrary WieldedItem where
+  arbitrary = genericArbitrary <&> \wi ->
+    wi & wieldedItem . itemType . wieldable ?~ wi ^. wieldableItem
+
+data Wielded
+  = DoubleHanded WieldedItem
+  | Hands { _leftHand :: !(Maybe WieldedItem)
+          , _rightHand :: !(Maybe WieldedItem)
+          }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Wielded
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ 'SumEnc 'ObjWithSingleField ]
+           Wielded
+
+
+nothingWielded :: Wielded
+nothingWielded = Hands Nothing Nothing
+
+hands :: Prism' Wielded (Maybe WieldedItem, Maybe WieldedItem)
+hands = prism' (uncurry Hands) $ \case
+  Hands l r -> Just (l, r)
+  _ -> Nothing
+
+leftHand :: Traversal' Wielded (Maybe WieldedItem)
+leftHand = hands . _1
+
+inLeftHand :: WieldedItem -> Wielded
+inLeftHand wi = Hands (Just wi) Nothing
+
+rightHand :: Traversal' Wielded (Maybe WieldedItem)
+rightHand = hands . _2
+
+inRightHand :: WieldedItem -> Wielded
+inRightHand wi = Hands Nothing (Just wi)
+
+doubleHanded :: Prism' Wielded WieldedItem
+doubleHanded = prism' DoubleHanded $ \case
+  DoubleHanded i -> Just i
+  _ -> Nothing
+
+wieldedItems :: Traversal' Wielded WieldedItem
+wieldedItems k (DoubleHanded wielded) = DoubleHanded <$> k wielded
+wieldedItems k (Hands l r) = Hands <$> _Just k l <*> _Just k r
+
+
+data Hand
+  = LeftHand
+  | RightHand
+  | BothHands
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Hand
+
+itemsInHand :: Hand -> Wielded -> [WieldedItem]
+itemsInHand LeftHand (DoubleHanded wi) = [wi]
+itemsInHand LeftHand (Hands lh _) = toList lh
+itemsInHand RightHand (DoubleHanded wi) = [wi]
+itemsInHand RightHand (Hands _ rh) = toList rh
+itemsInHand BothHands (DoubleHanded wi) = [wi]
+itemsInHand BothHands (Hands lh rh) = toList lh <> toList rh
+
+inHand :: Hand -> WieldedItem -> Wielded
+inHand LeftHand = inLeftHand
+inHand RightHand = inRightHand
+inHand BothHands = review doubleHanded
+
+wieldInHand :: Hand -> WieldedItem -> Wielded -> ([WieldedItem], Wielded)
+wieldInHand hand item w = (itemsInHand hand w, doWield)
+  where
+    doWield = case (hand, w) of
+      (LeftHand, Hands _ r) -> Hands (Just item) r
+      (LeftHand, DoubleHanded _) -> inLeftHand item
+      (RightHand, Hands l _) -> Hands l (Just item)
+      (RightHand, DoubleHanded _) -> inRightHand item
+      (BothHands, _) -> DoubleHanded item
+
+describeHand :: Hand -> Text
+describeHand LeftHand = "your left hand"
+describeHand RightHand = "your right hand"
+describeHand BothHands = "both hands"
+
+data Inventory = Inventory
+  { _backpack :: Vector Item
+  , _wielded :: Wielded
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Inventory
+  deriving EqProp via EqEqProp Inventory
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+           Inventory
+makeFieldsNoPrefix ''Inventory
+
+items :: Traversal' Inventory Item
+items k (Inventory bp w) = Inventory
+  <$> traversed k bp
+  <*> (wieldedItems . wieldedItem) k w
+
+type instance Element Inventory = Item
+
+instance MonoFunctor Inventory where
+  omap = over items
+
+instance MonoFoldable Inventory where
+  ofoldMap = foldMapOf items
+  ofoldr = foldrOf items
+  ofoldl' = foldlOf' items
+  otoList = toListOf items
+  oall = allOf items
+  oany = anyOf items
+  onull = nullOf items
+  ofoldr1Ex = foldr1Of items
+  ofoldl1Ex' = foldl1Of' items
+  headEx = headEx . toListOf items
+  lastEx = lastEx . toListOf items
+
+instance MonoTraversable Inventory where
+  otraverse = traverseOf items
+
+instance Semigroup Inventory where
+  inv₁ <> inv₂ =
+    let backpack' = inv₁ ^. backpack <> inv₂ ^. backpack
+        (wielded', backpack'') = case (inv₁ ^. wielded, inv₂ ^. wielded) of
+          (wielded₁, wielded₂@(DoubleHanded _)) ->
+            (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem))
+          (wielded₁, wielded₂@(Hands (Just _) (Just _))) ->
+            (wielded₂, backpack' <> fromList (wielded₁ ^.. wieldedItems . wieldedItem))
+          (wielded₁, Hands Nothing Nothing) -> (wielded₁, backpack')
+          (Hands Nothing Nothing, wielded₂) -> (wielded₂, backpack')
+          (Hands (Just l₁) Nothing, Hands Nothing (Just r₂)) ->
+            (Hands (Just l₁) (Just r₂), backpack')
+          (wielded₁@(DoubleHanded _), wielded₂) ->
+            (wielded₁, backpack' <> fromList (wielded₂ ^.. wieldedItems . wieldedItem))
+          (Hands Nothing (Just r₁), Hands Nothing (Just r₂)) ->
+            (Hands Nothing (Just r₂), r₁ ^. wieldedItem <| backpack')
+          (Hands Nothing r₁, Hands (Just l₂) Nothing) ->
+            (Hands (Just l₂) r₁, backpack')
+          (Hands (Just l₁) Nothing, Hands (Just l₂) Nothing) ->
+            (Hands (Just l₂) Nothing, l₁ ^. wieldedItem <| backpack')
+          (Hands (Just l₁) (Just r₁), Hands Nothing (Just r₂)) ->
+            (Hands (Just l₁) (Just r₂), r₁ ^. wieldedItem <| backpack')
+          (Hands (Just l₁) (Just r₁), Hands (Just l₂) Nothing) ->
+            (Hands (Just l₂) (Just r₁), l₁ ^. wieldedItem <| backpack')
+    in Inventory backpack'' wielded'
+
+instance Monoid Inventory where
+  mempty = Inventory mempty $ Hands Nothing Nothing
+
+class HasInventory s a | s -> a where
+  inventory :: Lens' s a
+  {-# MINIMAL inventory #-}
+
+-- | Representation for where in the inventory an item might be
+data InventoryPosition
+  = Backpack
+  | InHand Hand
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary InventoryPosition
+
+-- | Return a human-readable description of the given 'InventoryPosition'
+describeInventoryPosition :: InventoryPosition -> Text
+describeInventoryPosition Backpack       = "In backpack"
+describeInventoryPosition (InHand hand)  = "Wielded, in " <> describeHand hand
+
+-- | Given a position in the inventory, return a traversal on the inventory over
+-- all the items in that position
+inventoryPosition :: InventoryPosition -> Traversal' Inventory Item
+inventoryPosition Backpack = backpack . traversed
+inventoryPosition (InHand LeftHand) = wielded . leftHand . _Just . wieldedItem
+inventoryPosition (InHand RightHand) = wielded . leftHand . _Just . wieldedItem
+inventoryPosition (InHand BothHands) = wielded . doubleHanded . wieldedItem
+
+-- | A fold over all the items in the inventory accompanied by their position in
+-- the inventory
+--
+-- Invariant: This will return items in the same order as 'items'
+itemsWithPosition :: Fold Inventory (InventoryPosition, Item)
+itemsWithPosition = folding $ (<>) <$> backpackItems <*> handItems
+  where
+    backpackItems = toListOf $ backpack . folded . to (Backpack ,)
+    handItems inv = case inv ^. wielded of
+       DoubleHanded i -> pure (InHand BothHands, i ^. wieldedItem)
+       Hands l r -> (l ^.. folded . wieldedItem . to (InHand LeftHand ,))
+                 <> (r ^.. folded . wieldedItem . to (InHand RightHand ,))
+
+-- | Remove the first item equal to 'Item' from the given position in the
+-- inventory
+removeItemFromPosition :: InventoryPosition -> Item -> Inventory -> Inventory
+removeItemFromPosition Backpack item inv
+  = inv & backpack %~ removeFirst (== item)
+removeItemFromPosition (InHand LeftHand) item inv
+  = inv & wielded . leftHand %~ filter ((/= item) . view wieldedItem)
+removeItemFromPosition (InHand RightHand) item inv
+  = inv & wielded . rightHand %~ filter ((/= item) . view wieldedItem)
+removeItemFromPosition (InHand BothHands) item inv
+  | has (wielded . doubleHanded . wieldedItem . filtered (== item)) inv
+  = inv & wielded .~ nothingWielded
+  | otherwise
+  = inv

users/aspen/xanthous/src/Xanthous/Entities/Creature.hs

@@ -0,0 +1,88 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Creature
+  ( -- * Creature
+    Creature(..)
+    -- ** Lenses
+  , creatureType
+  , hitpoints
+  , hippocampus
+  , inventory
+
+    -- ** Creature functions
+  , damage
+  , isDead
+  , visionRadius
+
+    -- * Hippocampus
+  , Hippocampus(..)
+    -- ** Lenses
+  , destination
+    -- ** Destination
+  , Destination(..)
+  , destinationFromPos
+    -- *** Lenses
+  , destinationPosition
+  , destinationProgress
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Test.QuickCheck
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Aeson (ToJSON, FromJSON)
+--------------------------------------------------------------------------------
+import           Xanthous.AI.Gormlak
+import           Xanthous.Entities.RawTypes hiding
+                 (Creature, description, damage)
+import qualified Xanthous.Entities.RawTypes as Raw
+import           Xanthous.Game.State
+import           Xanthous.Data
+import           Xanthous.Data.Entities
+import           Xanthous.Entities.Creature.Hippocampus
+import           Xanthous.Util.QuickCheck (GenericArbitrary(..))
+import           Xanthous.Entities.Common (Inventory, HasInventory(..))
+--------------------------------------------------------------------------------
+
+data Creature = Creature
+  { _creatureType   :: !CreatureType
+  , _hitpoints      :: !Hitpoints
+  , _hippocampus    :: !Hippocampus
+  , _inventory      :: !Inventory
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature
+  deriving Arbitrary via GenericArbitrary Creature
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Creature
+makeFieldsNoPrefix ''Creature
+
+instance HasVisionRadius Creature where
+  visionRadius = const 50 -- TODO
+
+instance Brain Creature where
+  step = brainVia GormlakBrain
+  entityCanMove = const True
+
+instance Entity Creature where
+  entityAttributes _ = defaultEntityAttributes
+    & blocksObject .~ True
+  description = view $ creatureType . Raw.description
+  entityChar = view $ creatureType . char
+  entityCollision = const $ Just Combat
+
+--------------------------------------------------------------------------------
+
+damage :: Hitpoints -> Creature -> Creature
+damage amount = hitpoints %~ \hp ->
+  if hp <= amount
+  then 0
+  else hp - amount
+
+isDead :: Creature -> Bool
+isDead = views hitpoints (== 0)
+
+{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}

users/aspen/xanthous/src/Xanthous/Entities/Creature/Hippocampus.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Creature.Hippocampus
+  (-- * Hippocampus
+    Hippocampus(..)
+  , initialHippocampus
+    -- ** Lenses
+  , destination
+  , greetedCharacter
+    -- ** Destination
+  , Destination(..)
+  , destinationFromPos
+    -- *** Lenses
+  , destinationPosition
+  , destinationProgress
+  )
+where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Aeson (ToJSON, FromJSON)
+import           Test.QuickCheck
+import           Test.QuickCheck.Arbitrary.Generic
+--------------------------------------------------------------------------------
+import           Xanthous.Data
+--------------------------------------------------------------------------------
+
+
+data Destination = Destination
+  { _destinationPosition :: !Position
+    -- | The progress towards the destination, tracked as an offset from the
+    -- creature's original position.
+    --
+    -- When this value reaches >= 1, the creature has reached their destination
+  , _destinationProgress :: !Tiles
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Destination
+instance Arbitrary Destination where arbitrary = genericArbitrary
+makeLenses ''Destination
+
+destinationFromPos :: Position -> Destination
+destinationFromPos _destinationPosition =
+  let _destinationProgress = 0
+  in Destination{..}
+
+data Hippocampus = Hippocampus
+  { _destination      :: !(Maybe Destination)
+  , -- | Has this creature greeted the character in any way yet?
+    --
+    -- Some creature types ignore this field
+    _greetedCharacter :: !Bool
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Hippocampus
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Hippocampus
+makeLenses ''Hippocampus
+
+initialHippocampus :: Hippocampus
+initialHippocampus = Hippocampus
+  { _destination      = Nothing
+  , _greetedCharacter = False
+  }

users/aspen/xanthous/src/Xanthous/Entities/Draw/Util.hs

@@ -0,0 +1,31 @@
+module Xanthous.Entities.Draw.Util where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Brick.Widgets.Border.Style
+import Brick.Types (Edges(..))
+--------------------------------------------------------------------------------
+
+borderFromEdges :: BorderStyle -> Edges Bool -> Char
+borderFromEdges bstyle edges = ($ bstyle) $ case edges of
+  Edges False False  False False -> const '☐'
+
+  Edges True  False  False False -> bsVertical
+  Edges False True   False False -> bsVertical
+  Edges False False  True  False -> bsHorizontal
+  Edges False False  False True  -> bsHorizontal
+
+  Edges True  True   False False -> bsVertical
+  Edges True  False  True  False -> bsCornerBR
+  Edges True  False  False True  -> bsCornerBL
+
+  Edges False True   True  False -> bsCornerTR
+  Edges False True   False True  -> bsCornerTL
+  Edges False False  True  True  -> bsHorizontal
+
+  Edges False True   True  True  -> bsIntersectT
+  Edges True  False  True  True  -> bsIntersectB
+  Edges True  True   False True  -> bsIntersectL
+  Edges True  True   True  False -> bsIntersectR
+
+  Edges True  True   True  True  -> bsIntersectFull

users/aspen/xanthous/src/Xanthous/Entities/Entities.hs

@@ -0,0 +1,63 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Entities () where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Test.QuickCheck
+import qualified Test.QuickCheck.Gen as Gen
+import           Data.Aeson
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.Character
+import           Xanthous.Entities.Item
+import           Xanthous.Entities.Creature
+import           Xanthous.Entities.Environment
+import           Xanthous.Entities.Marker
+import           Xanthous.Game.State
+import           Xanthous.Util.QuickCheck
+import           Data.Aeson.Generic.DerivingVia
+--------------------------------------------------------------------------------
+
+instance Arbitrary SomeEntity where
+  arbitrary = Gen.oneof
+    [ SomeEntity <$> arbitrary @Character
+    , SomeEntity <$> arbitrary @Item
+    , SomeEntity <$> arbitrary @Creature
+    , SomeEntity <$> arbitrary @Wall
+    , SomeEntity <$> arbitrary @Door
+    , SomeEntity <$> arbitrary @GroundMessage
+    , SomeEntity <$> arbitrary @Staircase
+    , SomeEntity <$> arbitrary @Marker
+    ]
+
+instance FromJSON SomeEntity where
+  parseJSON = withObject "Entity" $ \obj -> do
+    (entityType :: Text) <- obj .: "type"
+    case entityType of
+      "Character" -> SomeEntity @Character <$> obj .: "data"
+      "Item" -> SomeEntity @Item <$> obj .: "data"
+      "Creature" -> SomeEntity @Creature <$> obj .: "data"
+      "Wall" -> SomeEntity @Wall <$> obj .: "data"
+      "Door" -> SomeEntity @Door <$> obj .: "data"
+      "GroundMessage" -> SomeEntity @GroundMessage <$> obj .: "data"
+      "Staircase" -> SomeEntity @Staircase <$> obj .: "data"
+      "Marker" -> SomeEntity @Marker <$> obj .: "data"
+      _ -> fail . unpack $ "Invalid entity type \"" <> entityType <> "\""
+
+deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameLevel
+  instance FromJSON GameLevel
+deriving via WithOptions '[ FieldLabelModifier '[Drop 1] ] GameState
+  instance FromJSON GameState
+
+instance Entity SomeEntity where
+  entityAttributes (SomeEntity ent) = entityAttributes ent
+  description (SomeEntity ent) = description ent
+  entityChar (SomeEntity ent) = entityChar ent
+  entityCollision (SomeEntity ent) = entityCollision ent
+
+instance Function SomeEntity where
+  function = functionJSON
+
+instance CoArbitrary SomeEntity where
+  coarbitrary = coarbitrary . encode

users/aspen/xanthous/src/Xanthous/Entities/Entities.hs-boot

@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Xanthous.Entities.Entities where
+
+import Test.QuickCheck
+import Data.Aeson
+import Xanthous.Game.State (SomeEntity, GameState, Entity)
+
+instance Arbitrary SomeEntity
+instance Function SomeEntity
+instance CoArbitrary SomeEntity
+instance FromJSON SomeEntity
+instance Entity SomeEntity
+
+instance FromJSON GameState

users/aspen/xanthous/src/Xanthous/Entities/Environment.hs

@@ -0,0 +1,160 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Xanthous.Entities.Environment
+  (
+    -- * Walls
+    Wall(..)
+
+    -- * Doors
+  , Door(..)
+  , open
+  , closed
+  , locked
+  , unlockedDoor
+
+    -- * Messages
+  , GroundMessage(..)
+
+    -- * Stairs
+  , Staircase(..)
+  ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import Test.QuickCheck
+import Brick (str)
+import Brick.Widgets.Border.Style (unicode)
+import Brick.Types (Edges(..))
+import Data.Aeson
+import Data.Aeson.Generic.DerivingVia
+--------------------------------------------------------------------------------
+import Xanthous.Entities.Draw.Util
+import Xanthous.Data
+import Xanthous.Data.Entities
+import Xanthous.Game.State
+import Xanthous.Util.QuickCheck
+--------------------------------------------------------------------------------
+
+data Wall = Wall
+  deriving stock (Show, Eq, Ord, Generic, Enum)
+  deriving anyclass (NFData, CoArbitrary, Function)
+
+instance ToJSON Wall where
+  toJSON = const $ String "Wall"
+
+instance FromJSON Wall where
+  parseJSON = withText "Wall" $ \case
+    "Wall" -> pure Wall
+    _      -> fail "Invalid Wall: expected Wall"
+
+instance Brain Wall where step = brainVia Brainless
+
+instance Entity Wall where
+  entityAttributes _ = defaultEntityAttributes
+    & blocksVision .~ True
+    & blocksObject .~ True
+  description _ = "a wall"
+  entityChar _ = "┼"
+
+instance Arbitrary Wall where
+  arbitrary = pure Wall
+
+wallEdges :: (MonoFoldable mono, Element mono ~ SomeEntity)
+          => Neighbors mono -> Edges Bool
+wallEdges neighs = any (entityIs @Wall) <$> edges neighs
+
+instance Draw Wall where
+  drawWithNeighbors neighs _wall =
+    str . pure . borderFromEdges unicode $ wallEdges neighs
+
+data Door = Door
+  { _open   :: Bool
+  , _locked :: Bool
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function, ToJSON, FromJSON)
+  deriving Arbitrary via GenericArbitrary Door
+makeLenses ''Door
+
+instance Draw Door where
+  drawWithNeighbors neighs door
+    = str . pure . ($ door ^. open) $ case wallEdges neighs of
+        Edges True  False  False False -> vertDoor
+        Edges False True   False False -> vertDoor
+        Edges True  True   False False -> vertDoor
+        Edges False False  True  False -> horizDoor
+        Edges False False  False True  -> horizDoor
+        Edges False False  True  True  -> horizDoor
+        _                              -> allsidesDoor
+    where
+      horizDoor True = '␣'
+      horizDoor False = 'ᚔ'
+      vertDoor True = '['
+      vertDoor False = 'ǂ'
+      allsidesDoor True = '+'
+      allsidesDoor False = '▥'
+
+instance Brain Door where step = brainVia Brainless
+
+instance Entity Door where
+  entityAttributes door = defaultEntityAttributes
+    & blocksVision .~ not (door ^. open)
+  description door | door ^. open = "an open door"
+                   | otherwise    = "a closed door"
+  entityChar _ = "d"
+  entityCollision door | door ^. open = Nothing
+                       | otherwise = Just Stop
+
+closed :: Lens' Door Bool
+closed = open . involuted not
+
+-- | A closed, unlocked door
+unlockedDoor :: Door
+unlockedDoor = Door
+  { _open = False
+  , _locked = False
+  }
+
+--------------------------------------------------------------------------------
+
+newtype GroundMessage = GroundMessage Text
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary GroundMessage
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ 'TagSingleConstructors 'True
+                        , 'SumEnc 'ObjWithSingleField
+                        ]
+           GroundMessage
+  deriving Draw
+       via DrawStyledCharacter ('Just 'Yellow) 'Nothing "≈"
+           GroundMessage
+instance Brain GroundMessage where step = brainVia Brainless
+
+instance Entity GroundMessage where
+  description = const "a message on the ground. Press r. to read it."
+  entityChar = const "≈"
+  entityCollision = const Nothing
+
+--------------------------------------------------------------------------------
+
+data Staircase = UpStaircase | DownStaircase
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Staircase
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ 'TagSingleConstructors 'True
+                        , 'SumEnc 'ObjWithSingleField
+                        ]
+           Staircase
+instance Brain Staircase where step = brainVia Brainless
+
+instance Draw Staircase where
+  draw UpStaircase = str "<"
+  draw DownStaircase = str ">"
+
+instance Entity Staircase where
+  description UpStaircase = "a staircase leading upwards"
+  description DownStaircase = "a staircase leading downwards"
+  entityChar UpStaircase = "<"
+  entityChar DownStaircase = ">"
+  entityCollision = const Nothing

users/aspen/xanthous/src/Xanthous/Entities/Item.hs

@@ -0,0 +1,76 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE RecordWildCards #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Item
+  ( Item(..)
+  , itemType
+  , density
+  , volume
+  , newWithType
+  , isEdible
+  , weight
+  , fullDescription
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Test.QuickCheck (Arbitrary, CoArbitrary, Function)
+import           Data.Aeson (ToJSON, FromJSON)
+import           Data.Aeson.Generic.DerivingVia
+import           Control.Monad.Random (MonadRandom)
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.RawTypes (ItemType)
+import qualified Xanthous.Entities.RawTypes as Raw
+import           Xanthous.Game.State
+import           Xanthous.Data (Grams, Per, Cubic, Meters, (|*|))
+import           Xanthous.Util.QuickCheck (GenericArbitrary(GenericArbitrary))
+import           Xanthous.Random (choose, FiniteInterval(..))
+--------------------------------------------------------------------------------
+
+data Item = Item
+  { _itemType :: ItemType
+  , _density  :: Grams `Per` Cubic Meters
+  , _volume   :: Cubic Meters
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Draw via DrawRawChar "_itemType" Item
+  deriving Arbitrary via GenericArbitrary Item
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Item
+makeLenses ''Item
+
+-- deriving via (Brainless Item) instance Brain Item
+instance Brain Item where step = brainVia Brainless
+
+instance Entity Item where
+  description = view $ itemType . Raw.description
+  entityChar = view $ itemType . Raw.char
+  entityCollision = const Nothing
+
+newWithType :: MonadRandom m => ItemType -> m Item
+newWithType _itemType = do
+  _density <- choose . FiniteInterval $ _itemType ^. Raw.density
+  _volume  <- choose . FiniteInterval $ _itemType ^. Raw.volume
+  pure Item {..}
+
+isEdible :: Item -> Bool
+isEdible = Raw.isEdible . view itemType
+
+-- | The weight of this item, calculated by multiplying its volume by the
+-- density of its material
+weight :: Item -> Grams
+weight item = (item ^. density) |*| (item ^. volume)
+
+-- | Describe the item in full detail
+fullDescription :: Item -> Text
+fullDescription item = unlines
+  [ item ^. itemType . Raw.description
+  , ""
+  , item ^. itemType . Raw.longDescription
+  , ""
+  , "volume: " <> tshow (item ^. volume)
+  , "density: " <> tshow (item ^. density)
+  , "weight: " <> tshow (weight item)
+  ]

users/aspen/xanthous/src/Xanthous/Entities/Marker.hs

@@ -0,0 +1,41 @@
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Marker ( Marker(..) ) where
+--------------------------------------------------------------------------------
+import Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Data.Aeson
+import           Test.QuickCheck
+import qualified Graphics.Vty.Attributes as Vty
+import qualified Graphics.Vty.Image as Vty
+import           Brick.Widgets.Core (raw)
+--------------------------------------------------------------------------------
+import           Xanthous.Game.State
+import           Xanthous.Data.Entities (EntityAttributes(..))
+--------------------------------------------------------------------------------
+
+-- | Mark on the map - for use in debugging / development only.
+newtype Marker = Marker Text
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Semigroup, Monoid, ToJSON, FromJSON, Arbitrary) via Text
+
+instance Brain Marker where step = brainVia Brainless
+
+instance Entity Marker where
+  entityAttributes = const EntityAttributes
+    { _blocksVision = False
+    , _blocksObject = False
+    , _collision = Stop
+    }
+  description (Marker m) = "[M] " <> m
+  entityChar = const $ "X" & style .~ markerStyle
+  entityCollision = const Nothing
+
+instance Draw Marker where
+  draw = const . raw $ Vty.char markerStyle 'X'
+  drawPriority = const maxBound
+
+markerStyle :: Vty.Attr
+markerStyle = Vty.defAttr
+  `Vty.withForeColor` Vty.red
+  `Vty.withBackColor` Vty.black

users/aspen/xanthous/src/Xanthous/Entities/RawTypes.hs

@@ -0,0 +1,286 @@
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.RawTypes
+  (
+    EntityRaw(..)
+  , _Creature
+  , _Item
+
+    -- * Creatures
+  , CreatureType(..)
+  , hostile
+    -- ** Generation parameters
+  , CreatureGenerateParams(..)
+  , canGenerate
+    -- ** Language
+  , LanguageName(..)
+  , getLanguage
+    -- ** Attacks
+  , Attack(..)
+
+    -- * Items
+  , ItemType(..)
+    -- ** Item sub-types
+    -- *** Edible
+  , EdibleItem(..)
+  , isEdible
+    -- *** Wieldable
+  , WieldableItem(..)
+  , isWieldable
+
+    -- * Lens classes
+  , HasAttackMessage(..)
+  , HasAttacks(..)
+  , HasChance(..)
+  , HasChar(..)
+  , HasCreatureAttackMessage(..)
+  , HasDamage(..)
+  , HasDensity(..)
+  , HasDescription(..)
+  , HasEatMessage(..)
+  , HasEdible(..)
+  , HasEntityName(..)
+  , HasEquippedItem(..)
+  , HasFriendly(..)
+  , HasGenerateParams(..)
+  , HasHitpointsHealed(..)
+  , HasLanguage(..)
+  , HasLevelRange(..)
+  , HasLongDescription(..)
+  , HasMaxHitpoints(..)
+  , HasName(..)
+  , HasSayVerb(..)
+  , HasSpeed(..)
+  , HasVolume(..)
+  , HasWieldable(..)
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+import           Test.QuickCheck
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Aeson (ToJSON, FromJSON)
+import           Data.Interval (Interval, lowerBound', upperBound')
+import qualified Data.Interval as Interval
+--------------------------------------------------------------------------------
+import           Xanthous.Messages (Message(..))
+import           Xanthous.Data (TicksPerTile, Hitpoints, Per, Grams, Cubic, Meters)
+import           Xanthous.Data.EntityChar
+import           Xanthous.Util.QuickCheck
+import           Xanthous.Generators.Speech (Language, gormlak, english)
+import           Xanthous.Orphans ()
+import           Xanthous.Util (EqProp, EqEqProp(..))
+--------------------------------------------------------------------------------
+
+-- | Identifiers for languages that creatures can speak.
+--
+-- Non-verbal or non-sentient creatures have Nothing as their language
+--
+-- At some point, we will likely want to make languages be defined in data files
+-- somewhere, and reference them that way instead.
+data LanguageName = Gormlak | English
+  deriving stock (Show, Eq, Ord, Generic, Enum, Bounded)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary LanguageName
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ AllNullaryToStringTag 'True ]
+                       LanguageName
+
+-- | Resolve a 'LanguageName' into an actual 'Language'
+getLanguage :: LanguageName -> Language
+getLanguage Gormlak = gormlak
+getLanguage English = english
+
+-- | Natural attacks for creature types
+data Attack = Attack
+  { -- | the @{{creature}}@ @{{description}}@
+    _description :: !Message
+    -- | Damage dealt
+  , _damage      :: !Hitpoints
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary Attack
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1]
+                        , OmitNothingFields 'True
+                        ]
+                       Attack
+makeFieldsNoPrefix ''Attack
+
+-- | Description for generating an item equipped to a creature
+data CreatureEquippedItem = CreatureEquippedItem
+  { -- | Name of the entity type to generate
+    _entityName :: !Text
+    -- | Chance of generating the item when generating the creature
+    --
+    -- A chance of 1.0 will always generate the item
+  , _chance :: !Double
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary CreatureEquippedItem
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1]
+                        , OmitNothingFields 'True
+                        ]
+                       CreatureEquippedItem
+makeFieldsNoPrefix ''CreatureEquippedItem
+
+
+data CreatureGenerateParams = CreatureGenerateParams
+  { -- | Range of dungeon levels at which to generate this creature
+    _levelRange :: !(Interval Word)
+    -- | Item equipped to the creature
+  , _equippedItem :: !(Maybe CreatureEquippedItem)
+  }
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary CreatureGenerateParams
+  deriving EqProp via EqEqProp CreatureGenerateParams
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       CreatureGenerateParams
+makeFieldsNoPrefix ''CreatureGenerateParams
+
+instance Ord CreatureGenerateParams where
+  compare
+    = (compare `on` lowerBound' . _levelRange)
+    <> (compare `on` upperBound' . _levelRange)
+    <> (compare `on` _equippedItem)
+
+-- | Can a creature with these generate params be generated on this level?
+canGenerate
+  :: Word -- ^ Level number
+  -> CreatureGenerateParams
+  -> Bool
+canGenerate levelNumber gps = Interval.member levelNumber $ gps ^. levelRange
+
+data CreatureType = CreatureType
+  { _name           :: !Text
+  , _description    :: !Text
+  , _char           :: !EntityChar
+  , _maxHitpoints   :: !Hitpoints
+  , _friendly       :: !Bool
+  , _speed          :: !TicksPerTile
+  , _language       :: !(Maybe LanguageName)
+  , -- | The verb, in present tense, for when the creature says something
+    _sayVerb        :: !(Maybe Text)
+  , -- | The creature's natural attacks
+    _attacks        :: !(NonNull (Vector Attack))
+    -- | Parameters for generating the creature in levels
+  , _generateParams :: !(Maybe CreatureGenerateParams)
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary CreatureType
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1]
+                        , OmitNothingFields 'True
+                        ]
+                       CreatureType
+makeFieldsNoPrefix ''CreatureType
+
+hostile :: Lens' CreatureType Bool
+hostile = friendly . involuted not
+
+--------------------------------------------------------------------------------
+
+data EdibleItem = EdibleItem
+  { _hitpointsHealed :: !Int
+  , _eatMessage      :: !(Maybe Message)
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary EdibleItem
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       EdibleItem
+makeFieldsNoPrefix ''EdibleItem
+
+data WieldableItem = WieldableItem
+  { _damage :: !Hitpoints
+    -- | Message to use when the character is using this item to attack a
+    --  creature.
+    --
+    -- Grammatically, this should be of the form "slash at the
+    -- {{creature.creatureType.name}} with your dagger"
+    --
+    -- = Parameters
+    --
+    -- [@creature@ (type: 'Creature')] The creature being attacked
+  , _attackMessage :: !(Maybe Message)
+    -- | Message to use when a creature is using this item to attack the
+    -- character.
+    --
+    -- Grammatically, should be of the form "The creature slashes you with its
+    -- dagger".
+    --
+    -- = Parameters
+    --
+    -- [@creature@ (type: 'Creature')] The creature doing the attacking
+    -- [@item@ (type: 'Item')] The item itself
+  , _creatureAttackMessage :: !(Maybe Message)
+  }
+  deriving stock (Show, Eq, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary WieldableItem
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       WieldableItem
+makeFieldsNoPrefix ''WieldableItem
+
+--------------------------------------------------------------------------------
+
+data ItemType = ItemType
+  { _name            :: !Text
+  , _description     :: !Text
+  , _longDescription :: !Text
+  , _char            :: !EntityChar
+  , _density         :: !(Interval (Grams `Per` Cubic Meters))
+  , _volume          :: !(Interval (Cubic Meters))
+  , _edible          :: !(Maybe EdibleItem)
+  , _wieldable       :: !(Maybe WieldableItem)
+  }
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Arbitrary via GenericArbitrary ItemType
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       ItemType
+makeFieldsNoPrefix ''ItemType
+
+instance Ord ItemType where
+  compare x y
+    = compareOf name x y
+    <> compareOf description x y
+    <> compareOf longDescription x y
+    <> compareOf char x y
+    <> compareOf (density . to extractInterval) x y
+    <> compareOf (volume . to extractInterval) x y
+    <> compareOf edible x y
+    <> compareOf wieldable x y
+    where
+      compareOf l = comparing (view l)
+      extractInterval = lowerBound' &&& upperBound'
+
+-- | Can this item be eaten?
+isEdible :: ItemType -> Bool
+isEdible = has $ edible . _Just
+
+-- | Can this item be used as a weapon?
+isWieldable :: ItemType -> Bool
+isWieldable = has $ wieldable . _Just
+
+--------------------------------------------------------------------------------
+
+data EntityRaw
+  = Creature !CreatureType
+  | Item !ItemType
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData)
+  deriving Arbitrary via GenericArbitrary EntityRaw
+  deriving (FromJSON)
+       via WithOptions '[ SumEnc ObjWithSingleField ]
+                       EntityRaw
+makePrisms ''EntityRaw

users/aspen/xanthous/src/Xanthous/Entities/Raws.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Raws
+  ( raws
+  , raw
+  , RawType(..)
+  , rawsWithType
+  ) where
+--------------------------------------------------------------------------------
+import           Data.FileEmbed
+import qualified Data.Yaml as Yaml
+import           Xanthous.Prelude
+import           System.FilePath.Posix
+--------------------------------------------------------------------------------
+import           Xanthous.Entities.RawTypes
+import           Xanthous.AI.Gormlak ()
+--------------------------------------------------------------------------------
+rawRaws :: [(FilePath, ByteString)]
+rawRaws = $(embedDir "src/Xanthous/Entities/Raws")
+
+raws :: HashMap Text EntityRaw
+raws
+  = mapFromList
+  . map (bimap
+         (pack . takeBaseName)
+         (either (error . Yaml.prettyPrintParseException) id
+          . Yaml.decodeEither'))
+  $ rawRaws
+
+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
+
+--------------------------------------------------------------------------------

users/aspen/xanthous/src/Xanthous/Entities/Raws/broken-dagger.yaml

@@ -0,0 +1,24 @@
+Item:
+  name: broken dagger
+  description: a short, broken dagger
+  longDescription: A short dagger with a twisted, chipped blade
+  char:
+    char: †
+    style:
+      foreground: black
+  wieldable:
+    damage: 3
+    attackMessage:
+      - slash at the {{creature.creatureType.name}} with your dagger
+      - stab the {{creature.creatureType.name}} with your dagger
+    creatureAttackMessage:
+      - The {{creature.creatureType.name}} slashes at you with its dagger.
+      - The {{creature.creatureType.name}} stabs you with its dagger.
+  # Just the steel, not the handle, for now
+  density: [7750 , 8050000]
+  # 15cm – 45cm
+  # ×
+  # 2cm – 3cm
+  # ×
+  # .5cm – 1cm
+  volume: [0.15, 1.35]

users/aspen/xanthous/src/Xanthous/Entities/Raws/gormlak.yaml

@@ -0,0 +1,20 @@
+Creature:
+  name: gormlak
+  description: a gormlak
+  longDescription: |
+    A chittering imp-like creature with bright yellow horns and sharp claws. It
+    adores shiny objects and gathers in swarms.
+  char:
+    char: g
+    style:
+      foreground: red
+  maxHitpoints: 5
+  speed: 125
+  friendly: false
+  language: Gormlak
+  sayVerb: yells
+  attacks:
+  - description:
+      - claws you
+      - slashes you with its claws
+    damage: 1

users/aspen/xanthous/src/Xanthous/Entities/Raws/husk.yaml

@@ -0,0 +1,26 @@
+Creature:
+  name: husk
+  description: an empty husk of some humanoid creature
+  longDescription: |
+    An empty husk of a humanoid creature. All semblance of sentience has long
+    left its eyes; instead it shambles about aimlessly, always hungering for the
+    warmth of life.
+  char:
+    char: h
+    style:
+      foreground: black
+  maxHitpoints: 6
+  speed: 110
+  friendly: false
+  attacks:
+  - description:
+      - swings its arms at you
+      - elbows you
+    damage: 1
+  - description: kicks you
+    damage: 2
+  generateParams:
+    levelRange: [1, PosInf]
+    equippedItem:
+      entityName: broken-dagger
+      chance: 0.9

users/aspen/xanthous/src/Xanthous/Entities/Raws/noodles.yaml

@@ -0,0 +1,14 @@
+Item:
+  name: noodles
+  description: "a big bowl o' noodles"
+  longDescription: You know exactly what kind of noodles
+  char:
+    char: 'n'
+    style:
+      foreground: yellow
+  edible:
+    hitpointsHealed: 2
+    eatMessage:
+      - You slurp up the noodles. Yumm!
+  density: 500000
+  volume: 0.001

users/aspen/xanthous/src/Xanthous/Entities/Raws/ooze.yaml

@@ -0,0 +1,15 @@
+Creature:
+  name: ooze
+  description: an ooze
+  longDescription: |
+    A jiggling, amorphous, bright green caustic blob
+  char:
+    char: o
+    style:
+      foreground: green
+  maxHitpoints: 3
+  speed: 100
+  friendly: false
+  attacks:
+  - description: slams into you
+    damage: 1

users/aspen/xanthous/src/Xanthous/Entities/Raws/rock.yaml

@@ -0,0 +1,10 @@
+Item:
+  name: rock
+  description: a rock
+  longDescription: a medium-sized rock made out of some unknown stone
+  char: .
+  wieldable:
+    damage: 1
+    attackMessage: hit the {{creature.creatureType.name}} in the head with your rock
+  density: [ 1500000, 2500000 ]
+  volume: [ 0.000125, 0.001 ]

users/aspen/xanthous/src/Xanthous/Entities/Raws/stick.yaml

@@ -0,0 +1,22 @@
+Item:
+  name: stick
+  description: a wooden stick
+  longDescription: A sturdy branch broken off from some sort of tree
+  char:
+    char: ∤
+    style:
+      foreground: yellow
+  wieldable:
+    damage: 2
+    attackMessage:
+      - bonk the {{creature.creatureType.name}} over the head with your stick
+      - bash the {{creature.creatureType.name}} on the noggin with your stick
+      - whack the {{creature.creatureType.name}} with your stick
+    creatureAttackMessage:
+      - The {{creature.creatureType.name}} bonks you over the head with its stick.
+      - The {{creature.creatureType.name}} bashes you on the noggin with its stick.
+      - The {{creature.creatureType.name}} whacks you with its stick.
+  # https://www.sciencedirect.com/topics/agricultural-and-biological-sciences/wood-density
+  # it's a hard stick. so it's dense wood.
+  density: 890000 # g/m³
+  volume: [ 0.003, 0.006 ] # ≈3.5 cm radius × ≈1m length