about summary refs log tree commit diff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/Xanthous/AI/Gormlak.hs72
-rw-r--r--src/Xanthous/App.hs25
-rw-r--r--src/Xanthous/Data.hs137
-rw-r--r--src/Xanthous/Entities/Character.hs10
-rw-r--r--src/Xanthous/Entities/Creature.hs69
-rw-r--r--src/Xanthous/Entities/RawTypes.hs19
-rw-r--r--src/Xanthous/Entities/Raws/gormlak.yaml2
-rw-r--r--src/Xanthous/Game/Draw.hs2
-rw-r--r--src/Xanthous/Game/State.hs15
-rw-r--r--src/Xanthous/Generators.hs2
-rw-r--r--test/Xanthous/DataSpec.hs8
11 files changed, 277 insertions, 84 deletions
diff --git a/src/Xanthous/AI/Gormlak.hs b/src/Xanthous/AI/Gormlak.hs
index db504c1e7d3a..e13eb8ffe71a 100644
--- a/src/Xanthous/AI/Gormlak.hs
+++ b/src/Xanthous/AI/Gormlak.hs
@@ -10,10 +10,17 @@ import           Control.Monad.Random
 import           Data.Aeson (object)
 import qualified Data.Aeson as A
 --------------------------------------------------------------------------------
-import           Xanthous.Data (Positioned(..), diffPositions, stepTowards, isUnit)
+import           Xanthous.Data
+                 ( Positioned(..), positioned, position
+                 , diffPositions, stepTowards, isUnit
+                 , Ticks, (|*|), invertedRate
+                 )
 import           Xanthous.Data.EntityMap
 import qualified Xanthous.Entities.Creature as Creature
-import           Xanthous.Entities.Creature (Creature)
+import           Xanthous.Entities.Creature
+                 ( Creature, hippocampus, creatureType
+                 , destination, destinationProgress, destinationPosition
+                 )
 import           Xanthous.Entities.Character (Character)
 import qualified Xanthous.Entities.Character as Character
 import qualified Xanthous.Entities.RawTypes as Raw
@@ -28,30 +35,47 @@ import           Xanthous.Monad (say)
 
 stepGormlak
   :: (MonadState GameState m, MonadRandom m)
-  => Positioned Creature
+  => Ticks
+  -> 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 $> pos
-          else pure $ pos `stepTowards` charPos
+stepGormlak ticks pe@(Positioned pos creature) = do
+  dest <- maybe (selectDestination pos creature) pure
+         $ creature ^. hippocampus . destination
+  let progress' =
+        dest ^. destinationProgress
+        + creature ^. creatureType . Raw.speed . invertedRate |*| ticks
+  if progress' < 1
+    then pure
+         $ pe
+         & positioned . hippocampus . destination
+         ?~ (dest & destinationProgress .~ progress')
     else do
-      lines <- uses entities $ linesOfSight pos (Creature.visionRadius creature)
-      line <- choose $ weightedBy length lines
-      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
-      when (any (entityIs @Character) ents) attackCharacter
-      pure pe
-
+      let newPos = dest ^. destinationPosition
+          remainingSpeed = progress' - 1
+      newDest <- selectDestination newPos creature
+                <&> destinationProgress +~ remainingSpeed
+      let pe' = pe & positioned . hippocampus . destination ?~ newDest
+      collisionAt newPos >>= \case
+        Nothing -> pure $ pe' & position .~ newPos
+        Just Stop -> pure pe'
+        Just Combat -> do
+          ents <- use $ entities . atPosition newPos
+          when (any (entityIs @Character) ents) attackCharacter
+          pure pe'
   where
+    selectDestination pos' creature' = Creature.destinationFromPos <$> do
+      canSeeCharacter <- uses entities $ canSee (entityIs @Character) pos' vision
+      if canSeeCharacter
+        then do
+          charPos <- use characterPosition
+          if isUnit (pos' `diffPositions` charPos)
+            then attackCharacter $> pos'
+            else pure $ pos' `stepTowards` charPos
+      else do
+        lines <- uses entities $ linesOfSight pos' (Creature.visionRadius creature')
+        line <- choose $ weightedBy length lines
+        pure $ fromMaybe pos' $ fmap fst . headMay =<< tailMay =<< line
+
     vision = Creature.visionRadius creature
     attackCharacter = do
       say ["combat", "creatureAttack"] $ object [ "creature" A..= creature ]
@@ -60,7 +84,7 @@ stepGormlak pe@(Positioned pos creature) = do
 newtype GormlakBrain = GormlakBrain Creature
 
 instance Brain GormlakBrain where
-  step = fmap coerce . stepGormlak . coerce
+  step ticks = fmap coerce . stepGormlak ticks . coerce
 
 --------------------------------------------------------------------------------
 
diff --git a/src/Xanthous/App.hs b/src/Xanthous/App.hs
index 7c103ccfbcb3..d3f266a1e340 100644
--- a/src/Xanthous/App.hs
+++ b/src/Xanthous/App.hs
@@ -22,6 +22,9 @@ import           Xanthous.Data
                  , Dimensions'(Dimensions)
                  , positioned
                  , Position
+                 , Ticks
+                 , Position'(Position)
+                 , (|*|)
                  )
 import           Xanthous.Data.EntityMap (EntityMap)
 import qualified Xanthous.Data.EntityMap as EntityMap
@@ -85,11 +88,11 @@ initLevel = do
 
 --------------------------------------------------------------------------------
 
-stepGame :: AppM ()
-stepGame = do
+stepGameBy :: Ticks -> AppM ()
+stepGameBy ticks = do
   ents <- uses entities EntityMap.toEIDsAndPositioned
   for_ ents $ \(eid, pEntity) -> do
-    pEntity' <- step pEntity
+    pEntity' <- step ticks pEntity
     entities . ix eid .= pEntity'
 
   whenM (uses (character . characterHitpoints) (== 0))
@@ -97,6 +100,12 @@ stepGame = do
     . const . lift . liftIO
     $ exitSuccess
 
+ticksPerTurn :: Ticks
+ticksPerTurn = 100
+
+stepGame :: AppM ()
+stepGame = stepGameBy ticksPerTurn
+
 --------------------------------------------------------------------------------
 
 handleEvent :: BrickEvent Name () -> AppM (Next GameState)
@@ -119,7 +128,7 @@ handleCommand (Move dir) = do
   collisionAt newPos >>= \case
     Nothing -> do
       characterPosition .= newPos
-      stepGame
+      stepGameBy =<< uses (character . speed) (|*| 1)
       describeEntitiesAt newPos
       modify updateCharacterVision
     Just Combat -> attackAt newPos
@@ -135,7 +144,7 @@ handleCommand PickUp = do
       character %= Character.pickUpItem item
       entities . at itemID .= Nothing
       say ["items", "pickUp"] $ object [ "item" A..= item ]
-      stepGame
+      stepGameBy 100 -- TODO
     _ -> undefined
   continue
 
@@ -155,7 +164,7 @@ handleCommand Open = do
                entities . ix eid . positioned . _SomeEntity . open .= True
              say_ ["open", "success"]
       pure ()
-  stepGame
+  stepGame -- TODO
   continue
 
 handleCommand Wait = stepGame >> continue
@@ -180,7 +189,7 @@ handleCommand Eat = do
             character . characterHitpoints +=
               edibleItem ^. hitpointsHealed . to fromIntegral
             message msg $ object ["item" A..= item]
-  stepGame
+  stepGame -- TODO
   continue
 
 handleCommand ToggleRevealAll = do
@@ -318,4 +327,4 @@ attackAt pos =
       else do
         say ["combat", "hit"] msgParams
         entities . ix creatureID . positioned .= SomeEntity creature'
-    stepGame
+    stepGame -- TODO
diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs
index b7df191e58a8..569922843644 100644
--- a/src/Xanthous/Data.hs
+++ b/src/Xanthous/Data.hs
@@ -1,16 +1,20 @@
-{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE RoleAnnotations #-}
-{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE PartialTypeSignatures #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE ViewPatterns      #-}
+{-# LANGUAGE RoleAnnotations   #-}
+{-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE DeriveFoldable #-}
-{-# LANGUAGE DeriveFunctor #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE DeriveFoldable    #-}
+{-# LANGUAGE DeriveFunctor     #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE NoTypeSynonymInstances   #-}
 --------------------------------------------------------------------------------
 -- | Common data types for Xanthous
 --------------------------------------------------------------------------------
 module Xanthous.Data
   ( -- *
-    Position(..)
+    Position'(..)
+  , Position
   , x
   , y
 
@@ -27,6 +31,17 @@ module Xanthous.Data
   , isUnit
 
     -- *
+  , Per(..)
+  , invertRate
+  , invertedRate
+  , (|*|)
+  , Ticks(..)
+  , Tiles(..)
+  , TicksPerTile
+  , TilesPerTick
+  , timesTiles
+
+    -- *
   , Dimensions'(..)
   , Dimensions
   , HasWidth(..)
@@ -51,33 +66,67 @@ import           Test.QuickCheck (Arbitrary, CoArbitrary, Function)
 import           Test.QuickCheck.Arbitrary.Generic
 import           Data.Group
 import           Brick (Location(Location), Edges(..))
+import           Data.Monoid (Product(..), Sum(..))
+import           Data.Aeson.Generic.DerivingVia
+import           Data.Aeson (ToJSON, FromJSON)
 --------------------------------------------------------------------------------
 import           Xanthous.Util (EqEqProp(..), EqProp)
 import           Xanthous.Orphans ()
 import           Xanthous.Util.Graphics
 --------------------------------------------------------------------------------
 
-data Position where
-  Position :: { _x :: Int
-             , _y :: Int
-             } -> Position
-  deriving stock (Show, Eq, Generic, Ord)
-  deriving anyclass (Hashable, CoArbitrary, Function)
-  deriving EqProp via EqEqProp Position
-makeLenses ''Position
+-- fromScalar ∘ scalar ≡ id
+class Scalar a where
+  scalar :: a -> Double
+  fromScalar :: Double -> a
+
+instance Scalar Double where
+  scalar = id
+  fromScalar = id
+
+newtype ScalarIntegral a = ScalarIntegral a
+  deriving newtype (Eq, Ord, Num, Enum, Real, Integral)
+instance Integral a => Scalar (ScalarIntegral a) where
+  scalar = fromIntegral
+  fromScalar = floor
+
+deriving via (ScalarIntegral Integer) instance Scalar Integer
+deriving via (ScalarIntegral Word) instance Scalar Word
 
-instance Arbitrary Position where
+--------------------------------------------------------------------------------
+
+data Position' a where
+  Position :: { _x :: a
+             , _y :: a
+             } -> (Position' a)
+  deriving stock (Show, Eq, Generic, Ord, Functor, Foldable, Traversable)
+  deriving anyclass (NFData, Hashable, CoArbitrary, Function)
+  deriving EqProp via EqEqProp (Position' a)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       (Position' a)
+makeLenses ''Position'
+
+type Position = Position' Int
+
+instance Arbitrary a => Arbitrary (Position' a) where
   arbitrary = genericArbitrary
   shrink = genericShrink
 
-instance Semigroup Position where
+instance Num a => Semigroup (Position' a) where
   (Position x₁ y₁) <> (Position x₂ y₂) = Position (x₁ + x₂) (y₁ + y₂)
 
-instance Monoid Position where
+instance Num a => Monoid (Position' a) where
   mempty = Position 0 0
 
-instance Group Position where
-  invert (Position px py) = Position (-px) (-py)
+instance Num a => Group (Position' a) where
+  invert (Position px py) = Position (negate px) (negate py)
+
+-- | Positions convert to scalars by discarding their orientation and just
+-- measuring the length from the origin
+instance (Ord a, Num a, Scalar a) => Scalar (Position' a) where
+  scalar = fromIntegral . length . line (0, 0) . view _Position
+  fromScalar n = Position (fromScalar n) (fromScalar n)
 
 data Positioned a where
   Positioned :: Position -> a -> Positioned a
@@ -110,32 +159,32 @@ loc = iso hither yon
     hither (Position px py) = Location (px, py)
     yon (Location (lx, ly)) = Position lx ly
 
-_Position :: Iso' Position (Int, Int)
+_Position :: Iso' (Position' a) (a, a)
 _Position = iso hither yon
   where
     hither (Position px py) = (px, py)
     yon (lx, ly) = Position lx ly
 
-positionFromPair :: (Integral i, Integral j) => (i, j) -> Position
+positionFromPair :: (Num a, Integral i, Integral j) => (i, j) -> Position' a
 positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j)
 
 -- | Add two positions
 --
 -- Operation for the additive group on positions
-addPositions :: Position -> Position -> Position
+addPositions :: Num a => Position' a -> Position' a -> Position' a
 addPositions = (<>)
 
 -- | Subtract two positions.
 --
 -- diffPositions pos₁ pos₂ = pos₁ `addPositions` (invert pos₂)
-diffPositions :: Position -> Position -> Position
+diffPositions :: Num a => Position' a -> Position' a -> Position' a
 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 :: (Eq a, Num a) => Position' a -> Bool
 isUnit (Position px py) =
   abs px `elem` [0,1] && abs py `elem` [0, 1] && (px, py) /= (0, 0)
 
@@ -291,3 +340,41 @@ neighborPositions :: Position -> Neighbors Position
 neighborPositions pos = (`move` pos) <$> neighborDirections
 
 --------------------------------------------------------------------------------
+
+newtype Per a b = Rate Double
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Num, Ord, Enum, Real, ToJSON, FromJSON) via Double
+  deriving (Semigroup, Monoid) via Product Double
+instance Arbitrary (Per a b) where arbitrary = genericArbitrary
+
+invertRate :: a `Per` b -> b `Per` a
+invertRate (Rate p) = Rate $ 1 / p
+
+invertedRate :: Iso (a `Per` b) (b' `Per` a') (b `Per` a) (a' `Per` b')
+invertedRate = iso invertRate invertRate
+
+infixl 7 |*|
+(|*|) :: (Scalar a, Scalar b) => a `Per` b -> b -> a
+(|*|) (Rate rate) b = fromScalar $ rate * scalar b
+
+newtype Ticks = Ticks Word
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Num, Ord, Bounded, Enum, Integral, Real, ToJSON, FromJSON) via Word
+  deriving (Semigroup, Monoid) via (Sum Word)
+  deriving Scalar via ScalarIntegral Ticks
+instance Arbitrary Ticks where arbitrary = genericArbitrary
+
+newtype Tiles = Tiles Double
+  deriving stock (Show, Eq, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double
+  deriving (Semigroup, Monoid) via (Sum Double)
+instance Arbitrary Tiles where arbitrary = genericArbitrary
+
+type TicksPerTile = Ticks `Per` Tiles
+type TilesPerTick = Tiles `Per` Ticks
+
+timesTiles :: TicksPerTile -> Tiles -> Ticks
+timesTiles = (|*|)
diff --git a/src/Xanthous/Entities/Character.hs b/src/Xanthous/Entities/Character.hs
index 84e653e6a09d..7d2d22c9983b 100644
--- a/src/Xanthous/Entities/Character.hs
+++ b/src/Xanthous/Entities/Character.hs
@@ -5,6 +5,9 @@ module Xanthous.Entities.Character
   , inventory
   , characterDamage
   , characterHitpoints
+  , speed
+
+    -- *
   , mkCharacter
   , pickUpItem
   , isDead
@@ -12,6 +15,7 @@ module Xanthous.Entities.Character
   ) where
 --------------------------------------------------------------------------------
 import Xanthous.Prelude
+--------------------------------------------------------------------------------
 import Test.QuickCheck
 import Test.QuickCheck.Instances.Vector ()
 import Test.QuickCheck.Arbitrary.Generic
@@ -21,6 +25,7 @@ import Data.Aeson (ToJSON, FromJSON)
 --------------------------------------------------------------------------------
 import Xanthous.Entities
 import Xanthous.Entities.Item
+import Xanthous.Data (TicksPerTile)
 --------------------------------------------------------------------------------
 
 data Character = Character
@@ -28,6 +33,7 @@ data Character = Character
   , _characterName :: !(Maybe Text)
   , _characterDamage :: !Word
   , _characterHitpoints :: !Word
+  , _speed :: TicksPerTile
   }
   deriving stock (Show, Eq, Generic)
   deriving anyclass (CoArbitrary, Function)
@@ -58,12 +64,16 @@ instance Arbitrary Character where
 initialHitpoints :: Word
 initialHitpoints = 10
 
+defaultSpeed :: TicksPerTile
+defaultSpeed = 100
+
 mkCharacter :: Character
 mkCharacter = Character
   { _inventory = mempty
   , _characterName = Nothing
   , _characterDamage = 1
   , _characterHitpoints = initialHitpoints
+  , _speed = defaultSpeed
   }
 
 isDead :: Character -> Bool
diff --git a/src/Xanthous/Entities/Creature.hs b/src/Xanthous/Entities/Creature.hs
index f2c789d6a6a8..6ea6f93e4254 100644
--- a/src/Xanthous/Entities/Creature.hs
+++ b/src/Xanthous/Entities/Creature.hs
@@ -2,44 +2,101 @@
 {-# LANGUAGE TemplateHaskell #-}
 --------------------------------------------------------------------------------
 module Xanthous.Entities.Creature
-  ( 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.Entities.RawTypes hiding (Creature, description)
 import           Xanthous.Entities (Draw(..), DrawRawChar(..))
+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, 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)
+  }
+  deriving stock (Eq, Show, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
+  deriving (ToJSON, FromJSON)
+       via WithOptions '[ FieldLabelModifier '[Drop 1] ]
+                       Hippocampus
+instance Arbitrary Hippocampus where arbitrary = genericArbitrary
+makeLenses ''Hippocampus
+
+initialHippocampus :: Hippocampus
+initialHippocampus = Hippocampus Nothing
+
 --------------------------------------------------------------------------------
 
 data Creature = Creature
-  { _creatureType :: CreatureType
-  , _hitpoints :: Word
+  { _creatureType :: !CreatureType
+  , _hitpoints    :: !Word
+  , _hippocampus  :: !Hippocampus
   }
   deriving stock (Eq, Show, Generic)
+  deriving anyclass (NFData, CoArbitrary, Function)
   deriving Draw via DrawRawChar "_creatureType" Creature
   deriving (ToJSON, FromJSON)
        via WithOptions '[ FieldLabelModifier '[Drop 1] ]
                        Creature
+instance Arbitrary Creature where arbitrary = genericArbitrary
 makeLenses ''Creature
 
-instance Arbitrary Creature where
-  arbitrary = genericArbitrary
 
 --------------------------------------------------------------------------------
 
 newWithType :: CreatureType -> Creature
 newWithType _creatureType =
   let _hitpoints = _creatureType ^. maxHitpoints
+      _hippocampus = initialHippocampus
   in Creature {..}
 
 damage :: Word -> Creature -> Creature
@@ -53,3 +110,5 @@ isDead = views hitpoints (== 0)
 
 visionRadius :: Creature -> Word
 visionRadius = const 50 -- TODO
+
+{-# ANN module ("Hlint: ignore Use newtype instead of data" :: String) #-}
diff --git a/src/Xanthous/Entities/RawTypes.hs b/src/Xanthous/Entities/RawTypes.hs
index f1f5e05f7aac..fd66140376bb 100644
--- a/src/Xanthous/Entities/RawTypes.hs
+++ b/src/Xanthous/Entities/RawTypes.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 --------------------------------------------------------------------------------
 module Xanthous.Entities.RawTypes
@@ -8,6 +8,7 @@ module Xanthous.Entities.RawTypes
   , isEdible
   , EntityRaw(..)
 
+  , _Creature
     -- * Lens classes
   , HasName(..)
   , HasDescription(..)
@@ -17,7 +18,7 @@ module Xanthous.Entities.RawTypes
   , HasEatMessage(..)
   , HasHitpointsHealed(..)
   , HasEdible(..)
-  , _Creature
+  , HasSpeed(..)
   ) where
 --------------------------------------------------------------------------------
 import Xanthous.Prelude
@@ -28,16 +29,18 @@ import Data.Aeson (ToJSON, FromJSON)
 --------------------------------------------------------------------------------
 import Xanthous.Entities (EntityChar, HasChar(..))
 import Xanthous.Messages (Message(..))
+import Xanthous.Data (TicksPerTile)
 --------------------------------------------------------------------------------
 data CreatureType = CreatureType
-  { _name :: Text
-  , _description :: Text
-  , _char :: EntityChar
-  , _maxHitpoints :: Word
-  , _friendly :: Bool
+  { _name         :: !Text
+  , _description  :: !Text
+  , _char         :: !EntityChar
+  , _maxHitpoints :: !Word
+  , _friendly     :: !Bool
+  , _speed        :: !TicksPerTile
   }
   deriving stock (Show, Eq, Generic)
-  deriving anyclass (NFData)
+  deriving anyclass (NFData, CoArbitrary, Function)
   deriving (ToJSON, FromJSON)
        via WithOptions '[ FieldLabelModifier '[Drop 1] ]
                        CreatureType
diff --git a/src/Xanthous/Entities/Raws/gormlak.yaml b/src/Xanthous/Entities/Raws/gormlak.yaml
index 2441e7e7822e..9a9281c9a91a 100644
--- a/src/Xanthous/Entities/Raws/gormlak.yaml
+++ b/src/Xanthous/Entities/Raws/gormlak.yaml
@@ -8,5 +8,5 @@ Creature:
     style:
       foreground: red
   maxHitpoints: 5
-  speed: 120
+  speed: 125
   friendly: false
diff --git a/src/Xanthous/Game/Draw.hs b/src/Xanthous/Game/Draw.hs
index 9f247d383325..24c177513ed1 100644
--- a/src/Xanthous/Game/Draw.hs
+++ b/src/Xanthous/Game/Draw.hs
@@ -9,7 +9,7 @@ import           Brick.Widgets.Border
 import           Brick.Widgets.Border.Style
 import           Brick.Widgets.Edit
 --------------------------------------------------------------------------------
-import           Xanthous.Data (Position(Position), x, y, loc)
+import           Xanthous.Data (Position'(..), type Position, x, y, loc)
 import           Xanthous.Data.EntityMap (EntityMap, atPosition)
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Entities
diff --git a/src/Xanthous/Game/State.hs b/src/Xanthous/Game/State.hs
index 302d20e1efdc..c437f640c091 100644
--- a/src/Xanthous/Game/State.hs
+++ b/src/Xanthous/Game/State.hs
@@ -57,7 +57,8 @@ import           Control.Monad.Random.Class
 import           Brick (EventM, Widget)
 --------------------------------------------------------------------------------
 import           Xanthous.Data.EntityMap (EntityMap, EntityID)
-import           Xanthous.Data (Positioned(..), Position(..), Neighbors)
+import           Xanthous.Data
+                 (Positioned(..), type Position, Neighbors, Ticks(..))
 import           Xanthous.Orphans ()
 import           Xanthous.Game.Prompt
 import           Xanthous.Resource
@@ -149,12 +150,12 @@ instance Draw a => Draw (Positioned a) where
 --------------------------------------------------------------------------------
 
 class Brain a where
-  step :: Positioned a -> AppM (Positioned a)
+  step :: Ticks -> Positioned a -> AppM (Positioned a)
 
 newtype Brainless a = Brainless a
 
 instance Brain (Brainless a) where
-  step = pure
+  step = const pure
 
 -- | Workaround for the inability to use DerivingVia on Brain due to the lack of
 -- higher-order roles (specifically AppT not having its last type argument have
@@ -162,8 +163,8 @@ instance Brain (Brainless a) where
 brainVia
   :: forall brain entity. (Coercible entity brain, Brain brain)
   => (entity -> brain) -- ^ constructor, ignored
-  -> (Positioned entity -> AppM (Positioned entity))
-brainVia _ = fmap coerce . step . coerce @_ @(Positioned brain)
+  -> (Ticks -> Positioned entity -> AppM (Positioned entity))
+brainVia _ ticks = fmap coerce . step ticks . coerce @_ @(Positioned brain)
 
 --------------------------------------------------------------------------------
 
@@ -186,8 +187,8 @@ instance Draw SomeEntity where
   drawWithNeighbors ns (SomeEntity ent) = drawWithNeighbors ns ent
 
 instance Brain SomeEntity where
-  step (Positioned pos (SomeEntity ent)) =
-    fmap SomeEntity <$> step (Positioned pos ent)
+  step ticks (Positioned pos (SomeEntity ent)) =
+    fmap SomeEntity <$> step ticks (Positioned pos ent)
 
 instance Entity SomeEntity where
   blocksVision (SomeEntity ent) = blocksVision ent
diff --git a/src/Xanthous/Generators.hs b/src/Xanthous/Generators.hs
index 7bcf4da0515e..6b1a57299ea1 100644
--- a/src/Xanthous/Generators.hs
+++ b/src/Xanthous/Generators.hs
@@ -26,7 +26,7 @@ import           Control.Monad.Random
 import qualified Xanthous.Generators.CaveAutomata as CaveAutomata
 import           Xanthous.Generators.Util
 import           Xanthous.Generators.LevelContents
-import           Xanthous.Data (Dimensions, Position(Position))
+import           Xanthous.Data (Dimensions, Position'(Position), Position)
 import           Xanthous.Data.EntityMap (EntityMap)
 import qualified Xanthous.Data.EntityMap as EntityMap
 import           Xanthous.Entities.Environment
diff --git a/test/Xanthous/DataSpec.hs b/test/Xanthous/DataSpec.hs
index 26a862baa6a6..6fad88681acb 100644
--- a/test/Xanthous/DataSpec.hs
+++ b/test/Xanthous/DataSpec.hs
@@ -24,15 +24,15 @@ test = testGroup "Xanthous.Data"
       ]
     , testProperty "directionOf laws" $ \pos dir ->
         directionOf pos (move dir pos) == dir
-    , testProperty "diffPositions is add inverse" $ \pos₁ pos₂ ->
+    , testProperty "diffPositions is add inverse" $ \(pos₁ :: Position) pos₂ ->
         diffPositions pos₁ pos₂ == addPositions pos₁ (invert pos₂)
     , testGroup "isUnit"
       [ testProperty "double direction is never unit" $ \dir ->
           not . isUnit $ move dir (asPosition dir)
       , testCase "examples" $ do
-          isUnit (Position 1 1) @? "not . isUnit $ Position 1 1"
-          isUnit (Position 0 (-1)) @? "not . isUnit $ Position 0 (-1)"
-          (not . isUnit) (Position 1 13) @? "isUnit $ Position 1 13"
+          isUnit (Position @Int 1 1) @? "not . isUnit $ Position 1 1"
+          isUnit (Position @Int 0 (-1)) @? "not . isUnit $ Position 0 (-1)"
+          (not . isUnit) (Position @Int 1 13) @? "isUnit $ Position 1 13"
       ]
     ]
   , testGroup "Direction"
generated by cgit-pink 1.4.1 (git 2.44.2) at 2024-11-07T15·57+0000