diff options
Diffstat (limited to 'users/grfn/xanthous/src/Xanthous/Data.hs')
| -rw-r--r-- | users/grfn/xanthous/src/Xanthous/Data.hs | 822 |
1 files changed, 822 insertions, 0 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Data.hs b/users/grfn/xanthous/src/Xanthous/Data.hs new file mode 100644 index 000000000000..1acd14a0640b --- /dev/null +++ b/users/grfn/xanthous/src/Xanthous/Data.hs @@ -0,0 +1,822 @@ +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoTypeSynonymInstances #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +-------------------------------------------------------------------------------- +-- | Common data types for Xanthous ------------------------------------------------------------------------------ +module Xanthous.Data + ( Opposite(..) + + -- * + , Position'(..) + , Position + , x + , y + + -- ** + , Positioned(..) + , _Positioned + , position + , positioned + , loc + , _Position + , positionFromPair + , positionFromV2 + , addPositions + , diffPositions + , stepTowards + , isUnit + , distance + + -- * Boxes + , Box(..) + , topLeftCorner + , bottomRightCorner + , setBottomRightCorner + , dimensions + , inBox + , boxIntersects + , boxCenter + , boxEdge + , module Linear.V2 + + -- * Unit math + , Scalar(..) + , Per(..) + , invertRate + , invertedRate + , (|+|) + , (|*|) + , (|/|) + , (:+:) + , (:*:) + , (:/:) + , (:**:)(..) + , Ticks(..) + , Tiles(..) + , TicksPerTile + , TilesPerTick + , timesTiles + , Square(..) + , squared + , Cubic(..) + , Grams + , Meters + , Uno(..) + , Unit(..) + , UnitSymbol(..) + + -- * + , Dimensions'(..) + , Dimensions + , HasWidth(..) + , HasHeight(..) + + -- * + , Direction(..) + , move + , asPosition + , directionOf + , Cardinal(..) + + -- * + , Corner(..) + , Edge(..) + , cornerEdges + + -- * + , Neighbors(..) + , edges + , neighborDirections + , neighborPositions + , neighborCells + , arrayNeighbors + , rotations + , HasTopLeft(..) + , HasTop(..) + , HasTopRight(..) + , HasLeft(..) + , HasRight(..) + , HasBottomLeft(..) + , HasBottom(..) + , HasBottomRight(..) + + -- * + , Hitpoints(..) + ) where +-------------------------------------------------------------------------------- +import Xanthous.Prelude hiding (Left, Down, Right, (.=), elements) +-------------------------------------------------------------------------------- +import Linear.V2 hiding (_x, _y) +import qualified Linear.V2 as L +import Linear.V4 hiding (_x, _y) +import Test.QuickCheck (CoArbitrary, Function, elements) +import Test.QuickCheck.Arbitrary.Generic +import Data.Group +import Brick (Location(Location), Edges(..)) +import Data.Monoid (Product(..), Sum(..)) +import Data.Array.IArray +import Data.Aeson.Generic.DerivingVia +import Data.Aeson + ( ToJSON(..), FromJSON(..), object, (.=), (.:), withObject) +import Data.Random (Distribution) +import Data.Coerce +import Data.Proxy (Proxy(Proxy)) +-------------------------------------------------------------------------------- +import Xanthous.Util (EqEqProp(..), EqProp, between) +import Xanthous.Orphans () +import Xanthous.Util.Graphics +import qualified Linear.Metric as Metric +-------------------------------------------------------------------------------- + +-- | opposite ∘ opposite ≡ id +class Opposite x where + opposite :: x -> x + +-------------------------------------------------------------------------------- + +-- 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 + +-- | Units of measure +class Unit a where + unitSuffix :: Text +type UnitSymbol :: Symbol -> Type -> Type +newtype UnitSymbol suffix a = UnitSymbol a +instance KnownSymbol suffix => Unit (UnitSymbol suffix a) where + unitSuffix = pack $ symbolVal @suffix Proxy + +newtype ShowUnitSuffix a b = ShowUnitSuffix a +instance (Show b, Unit a, Coercible a b) => Show (ShowUnitSuffix a b) where + show a = show (coerce @_ @b a) <> " " <> unpack (unitSuffix @a) + +-------------------------------------------------------------------------------- + +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) + +x, y :: Lens' (Position' a) a +x = lens (\(Position xx _) -> xx) (\(Position _ yy) xx -> Position xx yy) +y = lens (\(Position _ yy) -> yy) (\(Position xx _) yy -> Position xx yy) + +type Position = Position' Int + +instance (Arg (Position' a) a, Arbitrary a) => Arbitrary (Position' a) where + arbitrary = genericArbitrary + shrink (Position px py) = Position <$> shrink px <*> shrink py + + +instance Num a => Semigroup (Position' a) where + (Position x₁ y₁) <> (Position x₂ y₂) = Position (x₁ + x₂) (y₁ + y₂) + +instance Num a => Monoid (Position' a) where + mempty = Position 0 0 + +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 . view _Position + fromScalar n = Position (fromScalar n) (fromScalar n) + +data Positioned a where + Positioned :: Position -> a -> Positioned a + deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + deriving anyclass (NFData, CoArbitrary, Function) +type role Positioned representational + +_Positioned :: Iso (Position, a) (Position, b) (Positioned a) (Positioned b) +_Positioned = iso hither yon + where + hither (pos, a) = Positioned pos a + yon (Positioned pos b) = (pos, b) + +instance Arbitrary a => Arbitrary (Positioned a) where + arbitrary = Positioned <$> arbitrary <*> arbitrary + +instance ToJSON a => ToJSON (Positioned a) where + toJSON (Positioned pos val) = object + [ "position" .= pos + , "data" .= val + ] + +instance FromJSON a => FromJSON (Positioned a) where + parseJSON = withObject "Positioned" $ \obj -> + Positioned <$> obj .: "position" <*> obj .: "data" + +position :: Lens' (Positioned a) Position +position = lens + (\(Positioned pos _) -> pos) + (\(Positioned _ a) pos -> Positioned pos a) + +positioned :: Lens (Positioned a) (Positioned b) a b +positioned = lens + (\(Positioned _ x') -> x') + (\(Positioned pos _) x' -> Positioned pos x') + +loc :: Iso' Position Location +loc = iso hither yon + where + hither (Position px py) = Location (px, py) + yon (Location (lx, ly)) = Position lx ly + +_Position :: Iso' (Position' a) (V2 a) +_Position = iso hither yon + where + hither (Position px py) = V2 px py + yon (V2 lx ly) = Position lx ly + +positionFromPair :: (Num a, Integral i, Integral j) => (i, j) -> Position' a +positionFromPair (i, j) = Position (fromIntegral i) (fromIntegral j) + +positionFromV2 :: (Num a, Integral i) => V2 i -> Position' a +positionFromV2 (V2 xx yy) = Position (fromIntegral xx) (fromIntegral yy) + +-- | Add two positions +-- +-- Operation for the additive group on positions +addPositions :: Num a => Position' a -> Position' a -> Position' a +addPositions = (<>) + +-- | Subtract two positions. +-- +-- diffPositions pos₁ pos₂ = pos₁ `addPositions` (invert pos₂) +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 :: (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) + +-------------------------------------------------------------------------------- + +data Dimensions' a = Dimensions + { _width :: a + , _height :: a + } + deriving stock (Show, Eq, Functor, Generic) + deriving anyclass (CoArbitrary, Function) +makeFieldsNoPrefix ''Dimensions' + +instance Arbitrary a => Arbitrary (Dimensions' a) where + arbitrary = Dimensions <$> arbitrary <*> arbitrary + +type Dimensions = Dimensions' Word + +-------------------------------------------------------------------------------- + +data Direction where + Up :: Direction + Down :: Direction + Left :: Direction + Right :: Direction + UpLeft :: Direction + UpRight :: Direction + DownLeft :: Direction + DownRight :: Direction + Here :: Direction + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (CoArbitrary, Function, NFData, ToJSON, FromJSON, Hashable) + +deriving via (GenericArbitrary Direction) instance Arbitrary Direction + +instance Opposite Direction where + opposite Up = Down + opposite Down = Up + opposite Left = Right + opposite Right = Left + opposite UpLeft = DownRight + opposite UpRight = DownLeft + opposite DownLeft = UpRight + opposite DownRight = UpLeft + opposite Here = Here + +move :: Num a => Direction -> Position' a -> Position' a +move Up = y -~ 1 +move Down = y +~ 1 +move Left = x -~ 1 +move Right = x +~ 1 +move UpLeft = move Up . move Left +move UpRight = move Up . move Right +move DownLeft = move Down . move Left +move DownRight = move Down . move Right +move Here = id + +asPosition :: Direction -> Position +asPosition dir = move dir mempty + +-- | Returns the direction that a given position is from a given source position +directionOf + :: Position -- ^ Source + -> Position -- ^ Target + -> Direction +directionOf (Position x₁ y₁) (Position x₂ y₂) = + case (x₁ `compare` x₂, y₁ `compare` y₂) of + (EQ, EQ) -> Here + (EQ, LT) -> Down + (EQ, GT) -> Up + (LT, EQ) -> Right + (GT, EQ) -> Left + + (LT, LT) -> DownRight + (GT, LT) -> DownLeft + + (LT, GT) -> UpRight + (GT, GT) -> UpLeft + +-- | Take one (potentially diagonal) step towards the given position +-- +-- ∀ src tgt. isUnit (src `diffPositions` (src `stepTowards tgt`)) +stepTowards + :: Position -- ^ Source + -> Position -- ^ Target + -> Position +stepTowards (view _Position -> p₁) (view _Position -> p₂) + | p₁ == p₂ = _Position # p₁ + | otherwise = + let (_:p:_) = line p₁ p₂ + in _Position # p + +-- | Newtype controlling arbitrary generation to only include cardinal +-- directions ('Up', 'Down', 'Left', 'Right') +newtype Cardinal = Cardinal { getCardinal :: Direction } + deriving stock (Eq, Show, Ord, Generic) + deriving anyclass (NFData, Function, CoArbitrary) + deriving newtype (Opposite) + +instance Arbitrary Cardinal where + arbitrary = Cardinal <$> elements [Up, Down, Left, Right] + +-------------------------------------------------------------------------------- + +data Corner + = TopLeft + | TopRight + | BottomLeft + | BottomRight + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) + deriving Arbitrary via GenericArbitrary Corner + +instance Opposite Corner where + opposite TopLeft = BottomRight + opposite TopRight = BottomLeft + opposite BottomLeft = TopRight + opposite BottomRight = TopLeft + +data Edge + = TopEdge + | LeftEdge + | RightEdge + | BottomEdge + deriving stock (Show, Eq, Ord, Enum, Bounded, Generic) + deriving Arbitrary via GenericArbitrary Edge + +instance Opposite Edge where + opposite TopEdge = BottomEdge + opposite BottomEdge = TopEdge + opposite LeftEdge = RightEdge + opposite RightEdge = LeftEdge + +cornerEdges :: Corner -> (Edge, Edge) +cornerEdges TopLeft = (TopEdge, LeftEdge) +cornerEdges TopRight = (TopEdge, RightEdge) +cornerEdges BottomLeft = (BottomEdge, LeftEdge) +cornerEdges BottomRight = (BottomEdge, RightEdge) + +-------------------------------------------------------------------------------- + +data Neighbors a = Neighbors + { _topLeft + , _top + , _topRight + , _left + , _right + , _bottomLeft + , _bottom + , _bottomRight :: a + } + deriving stock (Show, Eq, Ord, Functor, Foldable, Traversable, Generic) + deriving anyclass (NFData, CoArbitrary, Function, MonoFoldable) + +deriving via (GenericArbitrary (Neighbors a)) instance (Arg (Neighbors a) a, Arbitrary a) => Arbitrary (Neighbors a) + +type instance Element (Neighbors a) = a + +makeFieldsNoPrefix ''Neighbors + +instance Applicative Neighbors where + pure α = Neighbors + { _topLeft = α + , _top = α + , _topRight = α + , _left = α + , _right = α + , _bottomLeft = α + , _bottom = α + , _bottomRight = α + } + nf <*> nx = Neighbors + { _topLeft = nf ^. topLeft $ nx ^. topLeft + , _top = nf ^. top $ nx ^. top + , _topRight = nf ^. topRight $ nx ^. topRight + , _left = nf ^. left $ nx ^. left + , _right = nf ^. right $ nx ^. right + , _bottomLeft = nf ^. bottomLeft $ nx ^. bottomLeft + , _bottom = nf ^. bottom $ nx ^. bottom + , _bottomRight = nf ^. bottomRight $ nx ^. bottomRight + } + +edges :: Neighbors a -> Edges a +edges neighs = Edges + { eTop = neighs ^. top + , eBottom = neighs ^. bottom + , eLeft = neighs ^. left + , eRight = neighs ^. right + } + +neighborDirections :: Neighbors Direction +neighborDirections = Neighbors + { _topLeft = UpLeft + , _top = Up + , _topRight = UpRight + , _left = Left + , _right = Right + , _bottomLeft = DownLeft + , _bottom = Down + , _bottomRight = DownRight + } + +neighborPositions :: Num a => Position' a -> Neighbors (Position' a) +neighborPositions pos = (`move` pos) <$> neighborDirections + +neighborCells :: Num a => V2 a -> Neighbors (V2 a) +neighborCells = map (view _Position) . neighborPositions . review _Position + +arrayNeighbors + :: (IArray a e, Ix i, Num i) + => a (V2 i) e + -> V2 i + -> Neighbors (Maybe e) +arrayNeighbors arr center = arrLookup <$> neighborPositions (_Position # center) + where + arrLookup (view _Position -> pos) + | inRange (bounds arr) pos = Just $ arr ! pos + | otherwise = Nothing + +-- | Returns a list of all 4 90-degree rotations of the given neighbors +rotations :: Neighbors a -> V4 (Neighbors a) +rotations orig@(Neighbors tl t tr l r bl b br) = V4 + orig -- tl t tr + -- l r + -- bl b br + + (Neighbors bl l tl b t br r tr) -- bl l tl + -- b t + -- br r tr + + (Neighbors br b bl r l tr t tl) -- br b bl + -- r l + -- tr t tl + + (Neighbors tr r br t b tl l bl) -- tr r br + -- t b + -- tl l bl + +-------------------------------------------------------------------------------- + +newtype Per a b = Rate Double + deriving stock (Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) + via Double + deriving (Semigroup, Monoid) via Product Double + deriving Show via ShowUnitSuffix (Per a b) Double +deriving via Double + instance ( Distribution d Double + , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) + ) + => Distribution d (Per a b) + +instance (Unit a, Unit b) => Unit (a `Per` b) where + unitSuffix = unitSuffix @a <> "/" <> unitSuffix @b + +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 + +type (:+:) :: Type -> Type -> Type +type family (:+:) a b where + a :+: a = a + a :+: (Uno b) = a + +infixl 6 |+| +class AddUnit a b where + (|+|) :: a -> b -> a :+: b + +instance Scalar a => AddUnit a a where + x' |+| y' = fromScalar $ scalar x' + scalar y' + +instance (Scalar a, Scalar b) => AddUnit a (Uno b) where + x' |+| y' = fromScalar $ scalar x' + scalar y' + +type (:*:) :: Type -> Type -> Type +type family (:*:) a b where + (a `Per` b) :*: b = a + (Square a) :*: a = Cubic a + a :*: a = Square a + a :*: Uno b = a + a :*: b = a :**: b + +infixl 7 |*| +class MulUnit a b where + (|*|) :: a -> b -> a :*: b + +instance (Scalar a, Scalar b) => MulUnit (a `Per` b) b where + (Rate rate) |*| b = fromScalar $ rate * scalar b + +instance forall a. (Scalar a, a :*: a ~ Square a) => MulUnit a a where + x' |*| y' = Square @a . fromScalar $ scalar x' * scalar y' + +instance forall a. (Scalar a) => MulUnit (Square a) a where + x' |*| y' = Cubic @a . fromScalar $ scalar x' * scalar y' + +instance {-# INCOHERENT #-} forall a b. + (Scalar a, Scalar b, Scalar (a :*: Uno b)) + => MulUnit a (Uno b) where + x' |*| y' = fromScalar $ scalar x' * scalar y' + +type (:/:) :: Type -> Type -> Type +type family (:/:) a b where + (Square a) :/: a = a + (Cubic a) :/: a = Square a + (Cubic a) :/: (Square a) = a + (a :**: b) :/: b = a + (a :**: b) :/: a = b + a :/: Uno b = a + a :/: b = a `Per` b + +infixl 7 |/| +class DivUnit a b where + (|/|) :: a -> b -> a :/: b + +instance Scalar a => DivUnit (Square a) a where + (Square a) |/| b = fromScalar $ scalar a / scalar b + +instance Scalar a => DivUnit (Cubic a) a where + (Cubic a) |/| b = fromScalar $ scalar a / scalar b + +instance (Scalar a, Cubic a :/: Square a ~ a) + => DivUnit (Cubic a) (Square a) where + (Cubic a) |/| (Square b) = fromScalar $ scalar a / scalar b + +instance (Scalar a, Scalar b) => DivUnit (a :**: b) b where + (Times a) |/| b = fromScalar $ scalar a / scalar b + +instance (Scalar a, Scalar b) => DivUnit (a :**: b) a where + (Times a) |/| b = fromScalar $ scalar a / scalar b + +instance {-# INCOHERENT #-} forall a b. + (Scalar a, Scalar b, Scalar (a :/: Uno b)) + => DivUnit a (Uno b) where + x' |/| y' = fromScalar $ scalar x' / scalar y' + +-- | Dimensionless quantitites (mass per unit mass, radians, etc) +-- +-- see <https://en.wikipedia.org/wiki/Parts-per_notation#Uno> +newtype Uno a = Uno a + deriving stock (Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON + , Scalar, Show + ) + via a + deriving Unit via UnitSymbol "" (Uno a) + +newtype Square a = Square a + deriving stock (Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON + , Scalar + ) + via a +deriving via (a :: Type) + instance ( Distribution d a + , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) + ) + => Distribution d (Square a) + +instance Unit a => Unit (Square a) where + unitSuffix = unitSuffix @a <> "²" + +instance Show a => Show (Square a) where + show (Square n) = show n <> "²" + +squared :: (Scalar a, a :*: a ~ Square a) => a -> Square a +squared v = v |*| v + +newtype Cubic a = Cubic a + deriving stock (Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving ( Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON + , Scalar + ) + via a +deriving via (a :: Type) + instance ( Distribution d a + , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) + ) + => Distribution d (Cubic a) + +instance Unit a => Unit (Cubic a) where + unitSuffix = unitSuffix @a <> "³" + +instance Show a => Show (Cubic a) where + show (Cubic n) = show n <> "³" + +newtype (:**:) a b = Times Double + deriving stock (Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (Arbitrary, Num, Ord, Enum, Real, Fractional, ToJSON, FromJSON) + via Double + deriving (Semigroup, Monoid) via Sum Double + deriving Show via ShowUnitSuffix (a :**: b) Double +deriving via Double + instance ( Distribution d Double + , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) + ) + => Distribution d (a :**: b) + +instance (Unit a, Unit b) => Unit (a :**: b) where + unitSuffix = unitSuffix @a <> " " <> unitSuffix @b + +-------------------------------------------------------------------------------- + +newtype Ticks = Ticks Word + deriving stock (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 + deriving Arbitrary via GenericArbitrary Ticks + deriving Unit via UnitSymbol "ticks" Ticks + deriving Show via ShowUnitSuffix Ticks Word +deriving via Word + instance ( Distribution d Word + , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) + ) + => Distribution d Ticks + +newtype Tiles = Tiles Double + deriving stock (Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving (Num, Ord, Enum, Real, ToJSON, FromJSON, Scalar) via Double + deriving (Semigroup, Monoid) via (Sum Double) + deriving Arbitrary via GenericArbitrary Tiles + deriving Unit via UnitSymbol "m" Tiles + deriving Show via ShowUnitSuffix Tiles Double +deriving via Double + instance ( Distribution d Double + , forall xx yy. Coercible xx yy => Coercible (d xx) (d yy) + ) + => Distribution d Tiles + +type TicksPerTile = Ticks `Per` Tiles +type TilesPerTick = Tiles `Per` Ticks + +timesTiles :: TicksPerTile -> Tiles -> Ticks +timesTiles = (|*|) + +-- | Calculate the (cartesian) distance between two 'Position's, floored and +-- represented as a number of 'Tile's +-- +-- Note that this is imprecise, and may be different than the length of a +-- bresenham's line between the points +distance :: Position -> Position -> Tiles +distance + = (fromScalar .) . (Metric.distance `on` (fmap fromIntegral . view _Position)) + +-------------------------------------------------------------------------------- + +newtype Hitpoints = Hitpoints Word + deriving stock (Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving ( Arbitrary, Num, Ord, Bounded, Enum, Integral, Real, Scalar + , ToJSON, FromJSON + ) + via Word + deriving (Semigroup, Monoid) via Sum Word + deriving Unit via UnitSymbol "hp" Hitpoints + deriving Show via ShowUnitSuffix Hitpoints Word + +-------------------------------------------------------------------------------- + +-- | Grams, the fundamental measure of weight in Xanthous. +newtype Grams = Grams Double + deriving stock (Eq, Generic) + deriving anyclass (NFData, CoArbitrary, Function) + deriving ( Arbitrary, Num, Ord, Enum, Real, Floating, Fractional, RealFloat + , RealFrac, Scalar, ToJSON, FromJSON + ) + via Double + deriving (Semigroup, Monoid) via Sum Double + deriving Unit via UnitSymbol "g" Grams + deriving Show via ShowUnitSuffix Grams Double + +-- | Every tile is 1 meter +type Meters = Tiles + +-------------------------------------------------------------------------------- + +data Box a = Box + { _topLeftCorner :: V2 a + , _dimensions :: V2 a + } + deriving stock (Show, Eq, Ord, Functor, Generic) +makeFieldsNoPrefix ''Box + +-- It seems to be necessary to have an `Arg (V2 a) a` constraint, as a is passed +-- to V2 internally, in order to make GHC figure out this deriving via correctly. +deriving via (GenericArbitrary (Box a)) instance (Arg (V2 a) a, Arbitrary a) => Arbitrary (Box a) + +bottomRightCorner :: Num a => Box a -> V2 a +bottomRightCorner box = + V2 (box ^. topLeftCorner . L._x + box ^. dimensions . L._x) + (box ^. topLeftCorner . L._y + box ^. dimensions . L._y) + +setBottomRightCorner :: (Num a, Ord a) => Box a -> V2 a -> Box a +setBottomRightCorner box br@(V2 brx bry) + | brx < box ^. topLeftCorner . L._x || bry < box ^. topLeftCorner . L._y + = box & topLeftCorner .~ br + & dimensions . L._x .~ ((box ^. topLeftCorner . L._x) - brx) + & dimensions . L._y .~ ((box ^. topLeftCorner . L._y) - bry) + | otherwise + = box & dimensions . L._x .~ (brx - (box ^. topLeftCorner . L._x)) + & dimensions . L._y .~ (bry - (box ^. topLeftCorner . L._y)) + +inBox :: (Ord a, Num a) => Box a -> V2 a -> Bool +inBox box pt = flip all [L._x, L._y] $ \component -> + between (box ^. topLeftCorner . component) + (box ^. to bottomRightCorner . component) + (pt ^. component) + +boxIntersects :: (Ord a, Num a) => Box a -> Box a -> Bool +boxIntersects box₁ box₂ + = any (inBox box₁) [box₂ ^. topLeftCorner, bottomRightCorner box₂] + +boxCenter :: (Fractional a) => Box a -> V2 a +boxCenter box = V2 cx cy + where + cx = box ^. topLeftCorner . L._x + (box ^. dimensions . L._x / 2) + cy = box ^. topLeftCorner . L._y + (box ^. dimensions . L._y / 2) + +boxEdge :: (Enum a, Num a) => Box a -> Edge -> [V2 a] +boxEdge box LeftEdge = + V2 (box ^. topLeftCorner . L._x) + <$> [box ^. topLeftCorner . L._y .. box ^. to bottomRightCorner . L._y] +boxEdge box RightEdge = + V2 (box ^. to bottomRightCorner . L._x) + <$> [box ^. to bottomRightCorner . L._y .. box ^. to bottomRightCorner . L._y] +boxEdge box TopEdge = + flip V2 (box ^. topLeftCorner . L._y) + <$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x] +boxEdge box BottomEdge = + flip V2 (box ^. to bottomRightCorner . L._y) + <$> [box ^. topLeftCorner . L._x .. box ^. to bottomRightCorner . L._x] |