Implement speed and ticks

Gormlaks now move 1/8th the speed of the character, which means we can
run away from them - yay!

Unfortunately this also introduces a bug where they'll eventually get
stuck and not do anything, so I'll be tackling that next.

1 files changed, 112 insertions, 25 deletions

diff --git a/src/Xanthous/Data.hs b/src/Xanthous/Data.hs
index b7df191e58..5699228436 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 = (|*|)