{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Geometry.Vector
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- \(d\)-dimensional vectors.
--
--------------------------------------------------------------------------------
module Data.Geometry.Vector( module Data.Geometry.Vector.VectorFamily
                           , module LV
                           , C(..)
                           , Affine(..)
                           , quadrance, qdA, distanceA
                           , dot, norm, signorm
                           , isScalarMultipleOf
                           , scalarMultiple, sameDirection
                           -- reexports
                           , FV.replicate
                           , xComponent, yComponent, zComponent
                           ) where

import           Control.Applicative               (liftA2)
import           Control.Lens                      (Lens')
import           Control.Monad.State
import qualified Data.Foldable                     as F
import           Data.Geometry.Properties
import           Data.Geometry.Vector.VectorFamily
import           Data.Geometry.Vector.VectorFixed  (C (..))
import qualified Data.Vector.Fixed                 as FV
import           GHC.TypeLits
import           Linear.Affine                     (Affine (..), distanceA, qdA)
import           Linear.Metric                     (dot, norm, quadrance, signorm)
import           Linear.Vector                     as LV hiding (E (..))
import           System.Random                     (Random (..))
import           Test.QuickCheck                   (Arbitrary (..), Arbitrary1 (..), infiniteList,
                                                    infiniteListOf)

--------------------------------------------------------------------------------

-- $setup
-- >>> import Control.Lens

type instance Dimension (Vector d r) = d
type instance NumType   (Vector d r) = r

instance (Arbitrary r, Arity d) => Arbitrary (Vector d r) where
  arbitrary :: Gen (Vector d r)
arbitrary = [r] -> Vector d r
forall (d :: Nat) r. Arity d => [r] -> Vector d r
vectorFromListUnsafe ([r] -> Vector d r) -> Gen [r] -> Gen (Vector d r)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen [r]
forall a. Arbitrary a => Gen [a]
infiniteList

instance (Arity d) => Arbitrary1 (Vector d) where
  liftArbitrary :: Gen a -> Gen (Vector d a)
liftArbitrary Gen a
gen = [a] -> Vector d a
forall (d :: Nat) r. Arity d => [r] -> Vector d r
vectorFromListUnsafe ([a] -> Vector d a) -> Gen [a] -> Gen (Vector d a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Gen a -> Gen [a]
forall a. Gen a -> Gen [a]
infiniteListOf Gen a
gen

instance (Random r, Arity d) => Random (Vector d r) where
  randomR :: (Vector d r, Vector d r) -> g -> (Vector d r, g)
randomR (Vector d r
lows,Vector d r
highs) g
g0 = (State g (Vector d r) -> g -> (Vector d r, g))
-> g -> State g (Vector d r) -> (Vector d r, g)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State g (Vector d r) -> g -> (Vector d r, g)
forall s a. State s a -> s -> (a, s)
runState g
g0 (State g (Vector d r) -> (Vector d r, g))
-> State g (Vector d r) -> (Vector d r, g)
forall a b. (a -> b) -> a -> b
$
                            (r -> r -> StateT g Identity r)
-> Vector d r -> Vector d r -> State g (Vector d r)
forall (v :: * -> *) a b c (f :: * -> *).
(Vector v a, Vector v b, Vector v c, Applicative f) =>
(a -> b -> f c) -> v a -> v b -> f (v c)
FV.zipWithM (\r
l r
h -> (g -> (r, g)) -> StateT g Identity r
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((g -> (r, g)) -> StateT g Identity r)
-> (g -> (r, g)) -> StateT g Identity r
forall a b. (a -> b) -> a -> b
$ (r, r) -> g -> (r, g)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (r
l,r
h)) Vector d r
lows Vector d r
highs
  random :: g -> (Vector d r, g)
random g
g0 = (State g (Vector d r) -> g -> (Vector d r, g))
-> g -> State g (Vector d r) -> (Vector d r, g)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State g (Vector d r) -> g -> (Vector d r, g)
forall s a. State s a -> s -> (a, s)
runState g
g0 (State g (Vector d r) -> (Vector d r, g))
-> State g (Vector d r) -> (Vector d r, g)
forall a b. (a -> b) -> a -> b
$ StateT g Identity r -> State g (Vector d r)
forall (v :: * -> *) a (f :: * -> *).
(Vector v a, Applicative f) =>
f a -> f (v a)
FV.replicateM ((g -> (r, g)) -> StateT g Identity r
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state g -> (r, g)
forall a g. (Random a, RandomGen g) => g -> (a, g)
random)

-- | 'isScalarmultipleof u v' test if v is a scalar multiple of u.
--
-- >>> Vector2 1 1 `isScalarMultipleOf` Vector2 10 10
-- True
-- >>> Vector3 1 1 2 `isScalarMultipleOf` Vector3 10 10 20
-- True
-- >>> Vector2 1 1 `isScalarMultipleOf` Vector2 10 1
-- False
-- >>> Vector2 1 1 `isScalarMultipleOf` Vector2 (-1) (-1)
-- True
-- >>> Vector2 1 1 `isScalarMultipleOf` Vector2 11.1 11.1
-- True
-- >>> Vector2 1 1 `isScalarMultipleOf` Vector2 11.1 11.2
-- False
-- >>> Vector2 2 1 `isScalarMultipleOf` Vector2 11.1 11.2
-- False
-- >>> Vector2 2 1 `isScalarMultipleOf` Vector2 4 2
-- True
-- >>> Vector2 2 1 `isScalarMultipleOf` Vector2 4 0
-- False
-- >>> Vector3 2 1 0 `isScalarMultipleOf` Vector3 4 0 5
-- False
-- >>> Vector3 0 0 0 `isScalarMultipleOf` Vector3 4 0 5
-- True
isScalarMultipleOf       :: (Eq r, Fractional r, Arity d)
                         => Vector d r -> Vector d r -> Bool
Vector d r
u isScalarMultipleOf :: Vector d r -> Vector d r -> Bool
`isScalarMultipleOf` Vector d r
v = let d :: r
d = Vector d r
u Vector d r -> Vector d r -> r
forall (f :: * -> *) a. (Metric f, Num a) => f a -> f a -> a
`dot` Vector d r
v
                               num :: r
num = Vector d r -> r
forall (f :: * -> *) a. (Metric f, Num a) => f a -> a
quadrance Vector d r
u r -> r -> r
forall a. Num a => a -> a -> a
* Vector d r -> r
forall (f :: * -> *) a. (Metric f, Num a) => f a -> a
quadrance Vector d r
v
                           in r
num r -> r -> Bool
forall a. Eq a => a -> a -> Bool
== r
0 Bool -> Bool -> Bool
|| r
num r -> r -> Bool
forall a. Eq a => a -> a -> Bool
== r
dr -> r -> r
forall a. Num a => a -> a -> a
*r
d
-- u `isScalarMultipleOf` v = isJust $ scalarMultiple u v
{-# SPECIALIZE
    isScalarMultipleOf :: (Eq r, Fractional r) => Vector 2 r -> Vector 2 r -> Bool  #-}
{-# SPECIALIZE
    isScalarMultipleOf :: (Eq r, Fractional r) => Vector 3 r -> Vector 3 r -> Bool  #-}

-- | scalarMultiple u v computes the scalar labmda s.t. v = lambda * u (if it exists)
scalarMultiple     :: (Eq r, Fractional r, Arity d)
                   => Vector d r -> Vector d r -> Maybe r
scalarMultiple :: Vector d r -> Vector d r -> Maybe r
scalarMultiple Vector d r
u Vector d r
v
      | Vector d r -> Bool
forall (d :: Nat) r. (Arity d, Eq r, Num r) => Vector d r -> Bool
allZero Vector d r
u Bool -> Bool -> Bool
|| Vector d r -> Bool
forall (d :: Nat) r. (Arity d, Eq r, Num r) => Vector d r -> Bool
allZero Vector d r
v = r -> Maybe r
forall a. a -> Maybe a
Just r
0
      | Bool
otherwise              = Vector d r -> Vector d r -> Maybe r
forall r (d :: Nat).
(Eq r, Fractional r, Arity d) =>
Vector d r -> Vector d r -> Maybe r
scalarMultiple' Vector d r
u Vector d r
v
{-# SPECIALIZE
    scalarMultiple :: (Eq r, Fractional r) => Vector 2 r -> Vector 2 r -> Maybe r #-}


-- -- | Helper function for computing the scalar multiple. The result is a pair
-- -- (b,mm), where b indicates if v is a scalar multiple of u, and mm is a Maybe
-- -- scalar multiple. If the result is Nothing, the scalar multiple is zero.
-- scalarMultiple'     :: (Eq r, Fractional r, GV.Arity d)
--                     => Vector d r -> Vector d r -> (Bool,Maybe r)
-- scalarMultiple' u v = F.foldr allLambda (True,Nothing) $ FV.zipWith f u v
--   where
--     f ui vi = (ui == 0 && vi == 0, ui / vi)
--     allLambda (True,_)      x               = x
--     allLambda (_, myLambda) (b,Nothing)     = (b,Just myLambda) -- no lambda yet
--     allLambda (_, myLambda) (b,Just lambda) = (myLambda == lambda && b, Just lambda)


allZero :: (Arity d, Eq r, Num r) => Vector d r -> Bool
allZero :: Vector d r -> Bool
allZero = (r -> Bool) -> Vector d r -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
F.all (r -> r -> Bool
forall a. Eq a => a -> a -> Bool
== r
0)
{-# SPECIALIZE allZero :: (Eq r, Num r) => Vector 2 r -> Bool #-}


data ScalarMultiple r = No | Maybe | Yes r deriving (ScalarMultiple r -> ScalarMultiple r -> Bool
(ScalarMultiple r -> ScalarMultiple r -> Bool)
-> (ScalarMultiple r -> ScalarMultiple r -> Bool)
-> Eq (ScalarMultiple r)
forall r. Eq r => ScalarMultiple r -> ScalarMultiple r -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ScalarMultiple r -> ScalarMultiple r -> Bool
$c/= :: forall r. Eq r => ScalarMultiple r -> ScalarMultiple r -> Bool
== :: ScalarMultiple r -> ScalarMultiple r -> Bool
$c== :: forall r. Eq r => ScalarMultiple r -> ScalarMultiple r -> Bool
Eq,Int -> ScalarMultiple r -> ShowS
[ScalarMultiple r] -> ShowS
ScalarMultiple r -> String
(Int -> ScalarMultiple r -> ShowS)
-> (ScalarMultiple r -> String)
-> ([ScalarMultiple r] -> ShowS)
-> Show (ScalarMultiple r)
forall r. Show r => Int -> ScalarMultiple r -> ShowS
forall r. Show r => [ScalarMultiple r] -> ShowS
forall r. Show r => ScalarMultiple r -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ScalarMultiple r] -> ShowS
$cshowList :: forall r. Show r => [ScalarMultiple r] -> ShowS
show :: ScalarMultiple r -> String
$cshow :: forall r. Show r => ScalarMultiple r -> String
showsPrec :: Int -> ScalarMultiple r -> ShowS
$cshowsPrec :: forall r. Show r => Int -> ScalarMultiple r -> ShowS
Show)

instance Eq r => Semigroup (ScalarMultiple r) where
  ScalarMultiple r
No      <> :: ScalarMultiple r -> ScalarMultiple r -> ScalarMultiple r
<> ScalarMultiple r
_       = ScalarMultiple r
forall r. ScalarMultiple r
No
  ScalarMultiple r
_       <> ScalarMultiple r
No      = ScalarMultiple r
forall r. ScalarMultiple r
No
  ScalarMultiple r
Maybe   <> ScalarMultiple r
x       = ScalarMultiple r
x
  ScalarMultiple r
x       <> ScalarMultiple r
Maybe   = ScalarMultiple r
x
  (Yes r
x) <> (Yes r
y)
     | r
x r -> r -> Bool
forall a. Eq a => a -> a -> Bool
== r
y               = r -> ScalarMultiple r
forall r. r -> ScalarMultiple r
Yes r
x
     | Bool
otherwise            = ScalarMultiple r
forall r. ScalarMultiple r
No


instance Eq r => Monoid (ScalarMultiple r) where
  mempty :: ScalarMultiple r
mempty = ScalarMultiple r
forall r. ScalarMultiple r
Maybe
  mappend :: ScalarMultiple r -> ScalarMultiple r -> ScalarMultiple r
mappend = ScalarMultiple r -> ScalarMultiple r -> ScalarMultiple r
forall a. Semigroup a => a -> a -> a
(<>)

-- | Actual implementation of scalarMultiple
scalarMultiple'      :: (Eq r, Fractional r, Arity d)
                     => Vector d r -> Vector d r -> Maybe r
scalarMultiple' :: Vector d r -> Vector d r -> Maybe r
scalarMultiple' Vector d r
u Vector d r
v = ScalarMultiple r -> Maybe r
forall a. ScalarMultiple a -> Maybe a
g (ScalarMultiple r -> Maybe r)
-> (Vector d (ScalarMultiple r) -> ScalarMultiple r)
-> Vector d (ScalarMultiple r)
-> Maybe r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ScalarMultiple r -> ScalarMultiple r -> ScalarMultiple r)
-> ScalarMultiple r
-> Vector d (ScalarMultiple r)
-> ScalarMultiple r
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
F.foldr ScalarMultiple r -> ScalarMultiple r -> ScalarMultiple r
forall a. Monoid a => a -> a -> a
mappend ScalarMultiple r
forall a. Monoid a => a
mempty (Vector d (ScalarMultiple r) -> Maybe r)
-> Vector d (ScalarMultiple r) -> Maybe r
forall a b. (a -> b) -> a -> b
$ (r -> r -> ScalarMultiple r)
-> Vector d r -> Vector d r -> Vector d (ScalarMultiple r)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 r -> r -> ScalarMultiple r
forall r. (Eq r, Fractional r) => r -> r -> ScalarMultiple r
f Vector d r
u Vector d r
v
  where
    f :: r -> r -> ScalarMultiple r
f r
0  r
0  = ScalarMultiple r
forall r. ScalarMultiple r
Maybe -- we don't know lambda yet, but it may still be a scalar mult.
    f r
_  r
0  = ScalarMultiple r
forall r. ScalarMultiple r
No      -- Not a scalar multiple
    f r
ui r
vi = r -> ScalarMultiple r
forall r. r -> ScalarMultiple r
Yes (r -> ScalarMultiple r) -> r -> ScalarMultiple r
forall a b. (a -> b) -> a -> b
$ r
ui r -> r -> r
forall a. Fractional a => a -> a -> a
/ r
vi -- can still be a scalar multiple

    g :: ScalarMultiple a -> Maybe a
g ScalarMultiple a
No      = Maybe a
forall a. Maybe a
Nothing
    g ScalarMultiple a
Maybe   = String -> Maybe a
forall a. HasCallStack => String -> a
error String
"scalarMultiple': found a Maybe, which means the vectors either have length zero, or one of them is all Zero!"
    g (Yes a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
{-# SPECIALIZE
    scalarMultiple' :: (Eq r, Fractional r) => Vector 2 r -> Vector 2 r -> Maybe r #-}


-- | Given two colinar vectors, u and v, test if they point in the same direction, i.e.
-- iff scalarMultiple' u v == Just lambda, with lambda > 0
--
-- pre: u and v are colinear, u and v are non-zero
sameDirection     :: (Eq r, Num r, Arity d) => Vector d r -> Vector d r -> Bool
sameDirection :: Vector d r -> Vector d r -> Bool
sameDirection Vector d r
u Vector d r
v = Vector d Bool -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (Vector d Bool -> Bool) -> Vector d Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (r -> r -> Bool) -> Vector d r -> Vector d r -> Vector d Bool
forall (v :: * -> *) a b c.
(Vector v a, Vector v b, Vector v c) =>
(a -> b -> c) -> v a -> v b -> v c
FV.zipWith (\r
ux r
vx -> r -> r
forall a. Num a => a -> a
signum r
ux r -> r -> Bool
forall a. Eq a => a -> a -> Bool
== r -> r
forall a. Num a => a -> a
signum r
vx) Vector d r
u Vector d r
v

-- sameDirectionProp      :: (Eq r, Fractional r, Arity d)
--                        => Vector d r -> Vector d r -> Bool
-- sameDirectionProp u v = sameDirection u v == maybe False ((/= (-1)) . signum) (scalarMultiple' u v)

--------------------------------------------------------------------------------
-- * Helper functions specific to two and three dimensional vectors

-- | Shorthand to access the first component
--
-- >>> Vector3 1 2 3 ^. xComponent
-- 1
-- >>> Vector2 1 2 & xComponent .~ 10
-- Vector2 10 2
xComponent :: (1 <= d, Arity d) => Lens' (Vector d r) r
xComponent :: Lens' (Vector d r) r
xComponent = C 0 -> Lens' (Vector d r) r
forall (proxy :: Nat -> *) (i :: Nat) (d :: Nat) r.
(Arity d, KnownNat i, (i + 1) <= d) =>
proxy i -> Lens' (Vector d r) r
element (C 0
forall (n :: Nat). C n
C :: C 0)
{-# INLINABLE xComponent #-}

-- | Shorthand to access the second component
--
-- >>> Vector3 1 2 3 ^. yComponent
-- 2
-- >>> Vector2 1 2 & yComponent .~ 10
-- Vector2 1 10
yComponent :: (2 <= d, Arity d) => Lens' (Vector d r) r
yComponent :: Lens' (Vector d r) r
yComponent = C 1 -> Lens' (Vector d r) r
forall (proxy :: Nat -> *) (i :: Nat) (d :: Nat) r.
(Arity d, KnownNat i, (i + 1) <= d) =>
proxy i -> Lens' (Vector d r) r
element (C 1
forall (n :: Nat). C n
C :: C 1)
{-# INLINABLE yComponent #-}

-- | Shorthand to access the third component
--
-- >>> Vector3 1 2 3 ^. zComponent
-- 3
-- >>> Vector3 1 2 3 & zComponent .~ 10
-- Vector3 1 2 10
zComponent :: (3 <= d, Arity d) => Lens' (Vector d r) r
zComponent :: Lens' (Vector d r) r
zComponent = C 2 -> Lens' (Vector d r) r
forall (proxy :: Nat -> *) (i :: Nat) (d :: Nat) r.
(Arity d, KnownNat i, (i + 1) <= d) =>
proxy i -> Lens' (Vector d r) r
element (C 2
forall (n :: Nat). C n
C :: C 2)
{-# INLINABLE zComponent #-}