Add 'users/glittershark/xanthous/' from commit '53b56744f4'

git-subtree-dir: users/glittershark/xanthous
git-subtree-mainline: 91f53f02d8
git-subtree-split: 53b56744f4

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

@@ -0,0 +1,92 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+--------------------------------------------------------------------------------
+module Xanthous.Entities.Creature
+  ( -- * Creature
+    Creature(..)
+    -- ** Lenses
+  , creatureType
+  , hitpoints
+  , hippocampus
+
+    -- ** Creature functions
+  , newWithType
+  , damage
+  , isDead
+  , visionRadius
+
+    -- * Hippocampus
+  , Hippocampus(..)
+    -- ** Lenses
+  , destination
+    -- ** Destination
+  , Destination(..)
+  , destinationFromPos
+    -- *** Lenses
+  , destinationPosition
+  , destinationProgress
+  ) where
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude
+--------------------------------------------------------------------------------
+import           Test.QuickCheck
+import           Test.QuickCheck.Arbitrary.Generic
+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
+--------------------------------------------------------------------------------
+
+data Creature = Creature
+  { _creatureType :: !CreatureType
+  , _hitpoints    :: !Hitpoints
+  , _hippocampus  :: !Hippocampus
+  }
+  deriving stock (Eq, Show, Ord, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving Draw via DrawRawCharPriority "_creatureType" 1000 Creature
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Creature
+instance Arbitrary Creature where arbitrary = genericArbitrary
+makeLenses ''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
+
+--------------------------------------------------------------------------------
+
+newWithType :: CreatureType -> Creature
+newWithType _creatureType =
+  let _hitpoints = _creatureType ^. maxHitpoints
+      _hippocampus = initialHippocampus
+  in Creature {..}
+
+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) #-}