{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_HADDOCK hide #-}

-- | Space types
module NumHask.Space.Types
  ( Space (..),
    Union (..),
    Intersection (..),
    FieldSpace (..),
    mid,
    interpolate,
    project,
    Pos (..),
    space1,
    unsafeSpace1,
    randomS,
    randomSM,
    randomSs,
    memberOf,
    contains,
    disjoint,
    width,
    (+/-),
    monotone,
    eps,
    widen,
    widenEps,
    scale,
    move,
    Transform (..),
    inverseTransform,
    Affinity (..),
    (|.),
    rotate,
  )
where

import Control.Monad
import NumHask.Prelude
import System.Random.Stateful
import Prelude qualified as P

-- $setup
-- >>> :set -XRebindableSyntax
-- >>> import NumHask.Prelude
-- >>> import NumHask.Space
-- >>> import System.Random.Stateful
-- >>> let g = mkStdGen 42

-- | A 'Space' is a continuous set of numbers. Continuous here means that the set has an upper and lower bound, and an element that is between these two bounds is a member of the 'Space'.
--
-- > a `union` b == b `union` a
-- > a `intersection` b == b `intersection` a
-- > (a `union` b) `intersection` c == (a `intersection` b) `union` (a `intersection` c)
-- > (a `intersection` b) `union` c == (a `union` b) `intersection` (a `union` c)
-- > norm (norm a) = norm a
-- > a |>| b == b |<| a
-- > a |.| singleton a
class Space s where
  -- | the underlying element in the space
  type Element s :: Type

  -- | lower boundary
  lower :: s -> Element s

  -- | upper boundary
  upper :: s -> Element s

  -- | space containing a single element
  singleton :: Element s -> s
  singleton Element s
s = Element s
s forall s. Space s => Element s -> Element s -> s
>.< Element s
s

  -- | the intersection of two spaces
  intersection :: s -> s -> s
  default intersection :: (Ord (Element s)) => s -> s -> s
  intersection s
a s
b = Element s
l forall s. Space s => Element s -> Element s -> s
>.< Element s
u
    where
      l :: Element s
l = forall s. Space s => s -> Element s
lower s
a forall a. Ord a => a -> a -> a
`max` forall s. Space s => s -> Element s
lower s
b
      u :: Element s
u = forall s. Space s => s -> Element s
upper s
a forall a. Ord a => a -> a -> a
`min` forall s. Space s => s -> Element s
upper s
b

  -- | the union of two spaces
  union :: s -> s -> s
  default union :: (Ord (Element s)) => s -> s -> s
  union s
a s
b = Element s
l forall s. Space s => Element s -> Element s -> s
>.< Element s
u
    where
      l :: Element s
l = forall s. Space s => s -> Element s
lower s
a forall a. Ord a => a -> a -> a
`min` forall s. Space s => s -> Element s
lower s
b
      u :: Element s
u = forall s. Space s => s -> Element s
upper s
a forall a. Ord a => a -> a -> a
`max` forall s. Space s => s -> Element s
upper s
b

  -- | Normalise a space so that
  --
  -- > lower a \/ upper a == lower a
  -- > lower a /\ upper a == upper a
  normalise :: s -> s
  normalise s
s = forall s. Space s => s -> Element s
lower s
s forall s. Space s => Element s -> Element s -> s
... forall s. Space s => s -> Element s
upper s
s

  -- | create a normalised space from two elements
  infix 3 ...

  (...) :: Element s -> Element s -> s
  default (...) :: (Ord (Element s)) => Element s -> Element s -> s
  (...) Element s
a Element s
b = (Element s
a forall a. Ord a => a -> a -> a
`min` Element s
b) forall s. Space s => Element s -> Element s -> s
>.< (Element s
a forall a. Ord a => a -> a -> a
`max` Element s
b)

  -- | create a space from two elements without normalising
  infix 3 >.<

  (>.<) :: Element s -> Element s -> s

  -- | is an element in the space
  infixl 7 |.|

  (|.|) :: Element s -> s -> Bool
  default (|.|) :: (Ord (Element s)) => Element s -> s -> Bool
  (|.|) Element s
a s
s = (Element s
a forall a. Ord a => a -> a -> Bool
>= forall s. Space s => s -> Element s
lower s
s) Bool -> Bool -> Bool
&& (forall s. Space s => s -> Element s
upper s
s forall a. Ord a => a -> a -> Bool
>= Element s
a)

  -- | is one space completely above the other
  infixl 7 |>|

  (|>|) :: s -> s -> Bool
  default (|>|) :: (Ord (Element s)) => s -> s -> Bool
  (|>|) s
s0 s
s1 =
    forall s. Space s => s -> Element s
lower s
s0 forall a. Ord a => a -> a -> Bool
>= forall s. Space s => s -> Element s
upper s
s1

  -- | is one space completely below the other
  infixl 7 |<|

  (|<|) :: s -> s -> Bool
  default (|<|) :: (Ord (Element s)) => s -> s -> Bool
  (|<|) s
s0 s
s1 =
    forall s. Space s => s -> Element s
lower s
s1 forall a. Ord a => a -> a -> Bool
<= forall s. Space s => s -> Element s
upper s
s0

-- | is a space contained within another?
--
-- > (a `union` b) `contains` a
-- > (a `union` b) `contains` b
contains :: (Space s) => s -> s -> Bool
contains :: forall s. Space s => s -> s -> Bool
contains s
s0 s
s1 =
  forall s. Space s => s -> Element s
lower s
s1 forall s. Space s => Element s -> s -> Bool
|.| s
s0
    Bool -> Bool -> Bool
&& forall s. Space s => s -> Element s
upper s
s1 forall s. Space s => Element s -> s -> Bool
|.| s
s0

-- | are two spaces disjoint?
disjoint :: (Space s) => s -> s -> Bool
disjoint :: forall s. Space s => s -> s -> Bool
disjoint s
s0 s
s1 = s
s0 forall s. Space s => s -> s -> Bool
|>| s
s1 Bool -> Bool -> Bool
|| s
s0 forall s. Space s => s -> s -> Bool
|<| s
s1

-- | is an element contained within a space
memberOf :: (Space s) => Element s -> s -> Bool
memberOf :: forall s. Space s => Element s -> s -> Bool
memberOf = forall s. Space s => Element s -> s -> Bool
(|.|)

-- | distance between boundaries
width :: (Space s, Subtractive (Element s)) => s -> Element s
width :: forall s. (Space s, Subtractive (Element s)) => s -> Element s
width s
s = forall s. Space s => s -> Element s
upper s
s forall a. Subtractive a => a -> a -> a
- forall s. Space s => s -> Element s
lower s
s

-- | create a space centered on a plus or minus b
infixl 6 +/-

(+/-) :: (Space s, Subtractive (Element s)) => Element s -> Element s -> s
Element s
a +/- :: forall s.
(Space s, Subtractive (Element s)) =>
Element s -> Element s -> s
+/- Element s
b = Element s
a forall a. Subtractive a => a -> a -> a
- Element s
b forall s. Space s => Element s -> Element s -> s
... Element s
a forall a. Additive a => a -> a -> a
+ Element s
b

-- | a convex hull
newtype Union a = Union {forall a. Union a -> a
getUnion :: a}

instance (Space a) => Semigroup (Union a) where
  <> :: Union a -> Union a -> Union a
(<>) (Union a
a) (Union a
b) = forall a. a -> Union a
Union (a
a forall s. Space s => s -> s -> s
`union` a
b)

-- | https://en.wikipedia.org/wiki/Intersection_(set_theory)
newtype Intersection a = Intersection {forall a. Intersection a -> a
getIntersection :: a}

instance (Space a) => Semigroup (Intersection a) where
  <> :: Intersection a -> Intersection a -> Intersection a
(<>) (Intersection a
a) (Intersection a
b) = forall a. a -> Intersection a
Intersection (a
a forall s. Space s => s -> s -> s
`union` a
b)

-- | supply a random element within a 'Space'
--
-- >>> randomS (one :: Range Double) g
-- (0.43085240252163404,StdGen {unStdGen = SMGen 4530528345362647137 13679457532755275413})
randomS :: (Space s, RandomGen g, UniformRange (Element s)) => s -> g -> (Element s, g)
randomS :: forall s g.
(Space s, RandomGen g, UniformRange (Element s)) =>
s -> g -> (Element s, g)
randomS s
s = forall g a. (RandomGen g, UniformRange a) => (a, a) -> g -> (a, g)
uniformR (forall s. Space s => s -> Element s
lower s
s, forall s. Space s => s -> Element s
upper s
s)

-- | StatefulGen version of randomS
--
-- >>> import Control.Monad
-- >>> runStateGen_ g (randomSM (one :: Range Double))
-- 0.43085240252163404
randomSM :: (UniformRange (Element s), StatefulGen g m, Space s) => s -> g -> m (Element s)
randomSM :: forall s g (m :: * -> *).
(UniformRange (Element s), StatefulGen g m, Space s) =>
s -> g -> m (Element s)
randomSM s
s = forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
uniformRM (forall s. Space s => s -> Element s
lower s
s, forall s. Space s => s -> Element s
upper s
s)

-- | list of n random elements within a 'Space'
--
-- >>> let g = mkStdGen 42
-- >>> fst (randomSs 3 (one :: Range Double) g)
-- [0.43085240252163404,-6.472345419562497e-2,0.3854692674681801]
--
-- >>> fst (randomSs 3 (Rect 0 10 0 10 :: Rect Int) g)
-- [Point 0 7,Point 0 2,Point 1 7]
randomSs :: (Space s, RandomGen g, UniformRange (Element s)) => Int -> s -> g -> ([Element s], g)
randomSs :: forall s g.
(Space s, RandomGen g, UniformRange (Element s)) =>
Int -> s -> g -> ([Element s], g)
randomSs Int
n s
s g
g = forall g a.
RandomGen g =>
g -> (StateGenM g -> State g a) -> (a, g)
runStateGen g
g (forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall s g (m :: * -> *).
(UniformRange (Element s), StatefulGen g m, Space s) =>
s -> g -> m (Element s)
randomSM s
s)

-- | a space that can be divided neatly
--
-- > unsafeSpace1 (grid OuterPos s g) == s
-- > getUnion (sconcat (Union <$> (gridSpace s g))) == s
class (Space s, Field (Element s)) => FieldSpace s where
  -- | the type that divides or quotients the space
  type Grid s :: Type

  -- | create equally-spaced elements across a space
  grid :: Pos -> s -> Grid s -> [Element s]

  -- | create equally-spaced spaces from a space
  gridSpace :: s -> Grid s -> [s]

-- | Pos suggests where points should be placed in forming a grid across a field space.
data Pos
  = -- | include boundaries
    OuterPos
  | -- | don't include boundaries
    InnerPos
  | -- | include the lower boundary
    LowerPos
  | -- | include the upper boundary
    UpperPos
  | -- | use the mid-point of the space
    MidPos
  deriving (Int -> Pos -> ShowS
[Pos] -> ShowS
Pos -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Pos] -> ShowS
$cshowList :: [Pos] -> ShowS
show :: Pos -> String
$cshow :: Pos -> String
showsPrec :: Int -> Pos -> ShowS
$cshowsPrec :: Int -> Pos -> ShowS
Show, Pos -> Pos -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Pos -> Pos -> Bool
$c/= :: Pos -> Pos -> Bool
== :: Pos -> Pos -> Bool
$c== :: Pos -> Pos -> Bool
Eq)

-- | middle element of the space
mid :: (Space s, Field (Element s)) => s -> Element s
mid :: forall s. (Space s, Field (Element s)) => s -> Element s
mid s
s = (forall s. Space s => s -> Element s
lower s
s forall a. Additive a => a -> a -> a
+ forall s. Space s => s -> Element s
upper s
s) forall a. Divisive a => a -> a -> a
/ (forall a. Multiplicative a => a
one forall a. Additive a => a -> a -> a
+ forall a. Multiplicative a => a
one)

-- | interpolate a space
--
-- > interpolate s x == project s (zero ... one) x
interpolate :: (Space s, Ring (Element s)) => s -> Element s -> Element s
interpolate :: forall s.
(Space s, Ring (Element s)) =>
s -> Element s -> Element s
interpolate s
s Element s
x = forall s. Space s => s -> Element s
lower s
s forall a. Additive a => a -> a -> a
+ Element s
x forall a. Multiplicative a => a -> a -> a
* forall s. (Space s, Subtractive (Element s)) => s -> Element s
width s
s

-- | project an element from one space to another, preserving relative position.
--
-- > project o n (lower o) = lower n
-- > project o n (upper o) = upper n
-- > project o n (mid o) = mid n
-- > project a a x = x
project :: (Space s, Field (Element s)) => s -> s -> Element s -> Element s
project :: forall s.
(Space s, Field (Element s)) =>
s -> s -> Element s -> Element s
project s
s0 s
s1 Element s
p =
  ((Element s
p forall a. Subtractive a => a -> a -> a
- forall s. Space s => s -> Element s
lower s
s0) forall a. Divisive a => a -> a -> a
/ (forall s. Space s => s -> Element s
upper s
s0 forall a. Subtractive a => a -> a -> a
- forall s. Space s => s -> Element s
lower s
s0)) forall a. Multiplicative a => a -> a -> a
* (forall s. Space s => s -> Element s
upper s
s1 forall a. Subtractive a => a -> a -> a
- forall s. Space s => s -> Element s
lower s
s1) forall a. Additive a => a -> a -> a
+ forall s. Space s => s -> Element s
lower s
s1

-- | the containing space of a non-empty Traversable.
--
-- partial function.
--
-- > all $ unsafeSpace1 a `contains` <$> a
unsafeSpace1 :: (Space s, Traversable f) => f (Element s) -> s
unsafeSpace1 :: forall s (f :: * -> *).
(Space s, Traversable f) =>
f (Element s) -> s
unsafeSpace1 = forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
P.foldr1 forall s. Space s => s -> s -> s
union forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall s. Space s => Element s -> s
singleton

-- | Maybe containing space of a traversable.
space1 :: (Space s, Traversable f) => f (Element s) -> Maybe s
space1 :: forall s (f :: * -> *).
(Space s, Traversable f) =>
f (Element s) -> Maybe s
space1 f (Element s)
s = forall a. a -> a -> Bool -> a
bool (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall s (f :: * -> *).
(Space s, Traversable f) =>
f (Element s) -> s
unsafeSpace1 f (Element s)
s) forall a. Maybe a
Nothing (forall (t :: * -> *) a. Foldable t => t a -> Bool
null f (Element s)
s)

-- | lift a monotone function (increasing or decreasing) over a given space
monotone :: (Space a, Space b) => (Element a -> Element b) -> a -> b
monotone :: forall a b.
(Space a, Space b) =>
(Element a -> Element b) -> a -> b
monotone Element a -> Element b
f a
s = forall s (f :: * -> *).
(Space s, Traversable f) =>
f (Element s) -> s
unsafeSpace1 [Element a -> Element b
f (forall s. Space s => s -> Element s
lower a
s), Element a -> Element b
f (forall s. Space s => s -> Element s
upper a
s)]

-- | a small space
eps ::
  ( Space s,
    FromRational (Element s),
    Field (Element s)
  ) =>
  Element s ->
  Element s ->
  s
eps :: forall s.
(Space s, FromRational (Element s), Field (Element s)) =>
Element s -> Element s -> s
eps Element s
accuracy Element s
a = Element s
a forall s.
(Space s, Subtractive (Element s)) =>
Element s -> Element s -> s
+/- (Element s
accuracy forall a. Multiplicative a => a -> a -> a
* Element s
a forall a. Multiplicative a => a -> a -> a
* Element s
1e-6)

-- | widen a space
widen ::
  ( Space s,
    Ring (Element s)
  ) =>
  Element s ->
  s ->
  s
widen :: forall s. (Space s, Ring (Element s)) => Element s -> s -> s
widen Element s
a s
s = (forall s. Space s => s -> Element s
lower s
s forall a. Subtractive a => a -> a -> a
- Element s
a) forall s. Space s => Element s -> Element s -> s
>.< (forall s. Space s => s -> Element s
upper s
s forall a. Additive a => a -> a -> a
+ Element s
a)

-- | widen by a small amount
widenEps ::
  ( Space s,
    FromRational (Element s),
    Ring (Element s)
  ) =>
  Element s ->
  s ->
  s
widenEps :: forall s.
(Space s, FromRational (Element s), Ring (Element s)) =>
Element s -> s -> s
widenEps Element s
accuracy = forall s. (Space s, Ring (Element s)) => Element s -> s -> s
widen (Element s
accuracy forall a. Multiplicative a => a -> a -> a
* Element s
1e-6)

-- | Scale a Space. (scalar multiplication)
scale :: (Multiplicative (Element s), Space s) => Element s -> s -> s
scale :: forall s.
(Multiplicative (Element s), Space s) =>
Element s -> s -> s
scale Element s
e s
s = (Element s
e forall a. Multiplicative a => a -> a -> a
* forall s. Space s => s -> Element s
lower s
s) forall s. Space s => Element s -> Element s -> s
... (Element s
e forall a. Multiplicative a => a -> a -> a
* forall s. Space s => s -> Element s
upper s
s)

-- | Move a Space. (scalar addition)
move :: (Additive (Element s), Space s) => Element s -> s -> s
move :: forall s. (Additive (Element s), Space s) => Element s -> s -> s
move Element s
e s
s = (Element s
e forall a. Additive a => a -> a -> a
+ forall s. Space s => s -> Element s
lower s
s) forall s. Space s => Element s -> Element s -> s
... (Element s
e forall a. Additive a => a -> a -> a
+ forall s. Space s => s -> Element s
upper s
s)

-- | linear transform + translate of a point-like number
--
-- > (x, y) -> (ax + by + c, dx + ey + d)
--
-- or
--
-- \[
-- \begin{pmatrix}
-- a & b & c\\
-- d & e & f\\
-- 0 & 0 & 1
-- \end{pmatrix}
-- \begin{pmatrix}
-- x\\
-- y\\
-- 1
-- \end{pmatrix}
-- \]
data Transform a = Transform
  { forall a. Transform a -> a
ta :: !a,
    forall a. Transform a -> a
tb :: !a,
    forall a. Transform a -> a
tc :: !a,
    forall a. Transform a -> a
td :: !a,
    forall a. Transform a -> a
te :: !a,
    forall a. Transform a -> a
tf :: !a
  }
  deriving (Transform a -> Transform a -> Bool
forall a. Eq a => Transform a -> Transform a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Transform a -> Transform a -> Bool
$c/= :: forall a. Eq a => Transform a -> Transform a -> Bool
== :: Transform a -> Transform a -> Bool
$c== :: forall a. Eq a => Transform a -> Transform a -> Bool
Eq, Int -> Transform a -> ShowS
forall a. Show a => Int -> Transform a -> ShowS
forall a. Show a => [Transform a] -> ShowS
forall a. Show a => Transform a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Transform a] -> ShowS
$cshowList :: forall a. Show a => [Transform a] -> ShowS
show :: Transform a -> String
$cshow :: forall a. Show a => Transform a -> String
showsPrec :: Int -> Transform a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Transform a -> ShowS
Show, forall a b. a -> Transform b -> Transform a
forall a b. (a -> b) -> Transform a -> Transform b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Transform b -> Transform a
$c<$ :: forall a b. a -> Transform b -> Transform a
fmap :: forall a b. (a -> b) -> Transform a -> Transform b
$cfmap :: forall a b. (a -> b) -> Transform a -> Transform b
Functor, forall a. Eq a => a -> Transform a -> Bool
forall a. Num a => Transform a -> a
forall a. Ord a => Transform a -> a
forall m. Monoid m => Transform m -> m
forall a. Transform a -> Bool
forall a. Transform a -> Int
forall a. Transform a -> [a]
forall a. (a -> a -> a) -> Transform a -> a
forall m a. Monoid m => (a -> m) -> Transform a -> m
forall b a. (b -> a -> b) -> b -> Transform a -> b
forall a b. (a -> b -> b) -> b -> Transform a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => Transform a -> a
$cproduct :: forall a. Num a => Transform a -> a
sum :: forall a. Num a => Transform a -> a
$csum :: forall a. Num a => Transform a -> a
minimum :: forall a. Ord a => Transform a -> a
$cminimum :: forall a. Ord a => Transform a -> a
maximum :: forall a. Ord a => Transform a -> a
$cmaximum :: forall a. Ord a => Transform a -> a
elem :: forall a. Eq a => a -> Transform a -> Bool
$celem :: forall a. Eq a => a -> Transform a -> Bool
length :: forall a. Transform a -> Int
$clength :: forall a. Transform a -> Int
null :: forall a. Transform a -> Bool
$cnull :: forall a. Transform a -> Bool
toList :: forall a. Transform a -> [a]
$ctoList :: forall a. Transform a -> [a]
foldl1 :: forall a. (a -> a -> a) -> Transform a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> Transform a -> a
foldr1 :: forall a. (a -> a -> a) -> Transform a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> Transform a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> Transform a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> Transform a -> b
foldl :: forall b a. (b -> a -> b) -> b -> Transform a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> Transform a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> Transform a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> Transform a -> b
foldr :: forall a b. (a -> b -> b) -> b -> Transform a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> Transform a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> Transform a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> Transform a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> Transform a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> Transform a -> m
fold :: forall m. Monoid m => Transform m -> m
$cfold :: forall m. Monoid m => Transform m -> m
Foldable, Functor Transform
Foldable Transform
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
Transform (m a) -> m (Transform a)
forall (f :: * -> *) a.
Applicative f =>
Transform (f a) -> f (Transform a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Transform a -> m (Transform b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Transform a -> f (Transform b)
sequence :: forall (m :: * -> *) a.
Monad m =>
Transform (m a) -> m (Transform a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
Transform (m a) -> m (Transform a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Transform a -> m (Transform b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> Transform a -> m (Transform b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
Transform (f a) -> f (Transform a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
Transform (f a) -> f (Transform a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Transform a -> f (Transform b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Transform a -> f (Transform b)
Traversable)

-- | Calculate the inverse of a transformation.
inverseTransform :: (Eq a, Field a) => Transform a -> Maybe (Transform a)
inverseTransform :: forall a. (Eq a, Field a) => Transform a -> Maybe (Transform a)
inverseTransform (Transform a
a a
b a
c a
d a
e a
f) =
  let det :: a
det = a
a forall a. Multiplicative a => a -> a -> a
* a
e forall a. Subtractive a => a -> a -> a
- a
b forall a. Multiplicative a => a -> a -> a
* a
d
   in forall a. a -> a -> Bool -> a
bool
        ( forall a. a -> Maybe a
Just
            ( forall a. a -> a -> a -> a -> a -> a -> Transform a
Transform
                (a
a forall a. Divisive a => a -> a -> a
/ a
det)
                (a
d forall a. Divisive a => a -> a -> a
/ a
det)
                (-(a
a forall a. Multiplicative a => a -> a -> a
* a
c forall a. Additive a => a -> a -> a
+ a
d forall a. Multiplicative a => a -> a -> a
* a
f) forall a. Divisive a => a -> a -> a
/ a
det)
                (a
b forall a. Divisive a => a -> a -> a
/ a
det)
                (a
e forall a. Divisive a => a -> a -> a
/ a
det)
                (-(a
b forall a. Multiplicative a => a -> a -> a
* a
c forall a. Additive a => a -> a -> a
+ a
e forall a. Multiplicative a => a -> a -> a
* a
f) forall a. Divisive a => a -> a -> a
/ a
det)
            )
        )
        forall a. Maybe a
Nothing
        (a
det forall a. Eq a => a -> a -> Bool
== forall a. Additive a => a
zero)

-- | An 'Affinity' is something that can be subjected to an affine transformation in 2-dimensional space, where affine means a linear matrix operation or a translation (+).
--
-- https://en.wikipedia.org/wiki/Affine_transformation
class Affinity a b | a -> b where
  transform :: Transform b -> a -> a

infix 3 |.

-- | Apply a 'Transform' to an 'Affinity'
(|.) :: (Affinity a b) => Transform b -> a -> a
|. :: forall a b. Affinity a b => Transform b -> a -> a
(|.) = forall a b. Affinity a b => Transform b -> a -> a
transform

instance (Multiplicative a, Additive a) => Affinity (Transform a) a where
  transform :: Transform a -> Transform a -> Transform a
transform (Transform a
a' a
b' a
c' a
d' a
e' a
f') (Transform a
a a
b a
c a
d a
e a
f) =
    forall a. a -> a -> a -> a -> a -> a -> Transform a
Transform
      (a
a forall a. Multiplicative a => a -> a -> a
* a
a' forall a. Additive a => a -> a -> a
+ a
b' forall a. Multiplicative a => a -> a -> a
* a
d)
      (a
a' forall a. Multiplicative a => a -> a -> a
* a
b forall a. Additive a => a -> a -> a
+ a
b' forall a. Multiplicative a => a -> a -> a
* a
e)
      (a
a' forall a. Multiplicative a => a -> a -> a
* a
c forall a. Additive a => a -> a -> a
+ a
b' forall a. Multiplicative a => a -> a -> a
* a
f forall a. Additive a => a -> a -> a
+ a
c')
      (a
d' forall a. Multiplicative a => a -> a -> a
* a
a forall a. Additive a => a -> a -> a
+ a
e' forall a. Multiplicative a => a -> a -> a
* a
d)
      (a
d' forall a. Multiplicative a => a -> a -> a
* a
b forall a. Additive a => a -> a -> a
+ a
e' forall a. Multiplicative a => a -> a -> a
* a
e)
      (a
d' forall a. Multiplicative a => a -> a -> a
* a
c forall a. Additive a => a -> a -> a
+ a
e' forall a. Multiplicative a => a -> a -> a
* a
f forall a. Additive a => a -> a -> a
+ a
f')

-- | Rotate an 'Affinity' (counter-clockwise)
rotate :: (TrigField a) => a -> Transform a
rotate :: forall a. TrigField a => a -> Transform a
rotate a
a = forall a. a -> a -> a -> a -> a -> a -> Transform a
Transform (forall a. TrigField a => a -> a
cos a
a) (-forall a. TrigField a => a -> a
sin a
a) forall a. Additive a => a
zero (forall a. TrigField a => a -> a
sin a
a) (forall a. TrigField a => a -> a
cos a
a) forall a. Additive a => a
zero