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, 0 insertions, 822 deletions
diff --git a/users/grfn/xanthous/src/Xanthous/Data.hs b/users/grfn/xanthous/src/Xanthous/Data.hs deleted file mode 100644 index 703955206a..0000000000 --- a/users/grfn/xanthous/src/Xanthous/Data.hs +++ /dev/null @@ -1,822 +0,0 @@ -{-# 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 (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 (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 (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] |