module Graphics.Rasterific.Linear
( V1( .. )
, V2( .. )
, V3( .. )
, V4( .. )
, R1( .. )
, R2( .. )
, Additive( .. )
, Epsilon( .. )
, Metric( .. )
, (^*)
, (^/)
, normalize
) where
#ifdef EXTERNAL_LINEAR
import Linear
#else
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative( Applicative, pure, (<$>), (<*>) )
import Data.Monoid( mappend )
import Data.Foldable( Foldable( .. ) )
import Data.Traversable( Traversable( .. ) )
#endif
import Graphics.Rasterific.MiniLens
infixl 6 ^+^, ^-^
infixl 7 ^*, ^/
data V2 a = V2 !a !a
deriving (Eq, Show)
data V3 a = V3 !a !a !a
deriving (Eq, Show)
data V4 a = V4 !a !a !a !a
deriving (Eq, Show)
class R1 t where
_x :: Lens' (t a) a
class R2 t where
_y :: Lens' (t a) a
instance R1 V1 where
_x = lens (\(V1 a) -> a) (\_ -> V1)
instance R1 V2 where
_x = lens (\(V2 x _) -> x) (\(V2 _ y) x -> V2 x y)
instance R2 V2 where
_y = lens (\(V2 _ y) -> y) (\(V2 x _) y -> V2 x y)
instance R1 V3 where
_x = lens (\(V3 x _ _) -> x) (\(V3 _ y z) x -> V3 x y z)
instance R2 V3 where
_y = lens (\(V3 _ y _) -> y) (\(V3 x _ z) y -> V3 x y z)
instance R1 V4 where
_x = lens (\(V4 x _ _ _) -> x) (\(V4 _ y z w) x -> V4 x y z w)
instance R2 V4 where
_y = lens (\(V4 _ y _ _) -> y) (\(V4 x _ z w) y -> V4 x y z w)
newtype V1 a = V1 a
deriving (Eq, Show, Num)
instance Functor V1 where
fmap f (V1 a) = V1 $ f a
instance Functor V2 where
fmap f (V2 a b) = V2 (f a) (f b)
instance Functor V3 where
fmap f (V3 a b c) = V3 (f a) (f b) (f c)
instance Functor V4 where
fmap f (V4 a b c d) = V4 (f a) (f b) (f c) (f d)
instance Foldable V3 where
foldMap f (V3 a b c) = f a `mappend` f b `mappend` f c
instance Traversable V3 where
traverse f (V3 a b c) = V3 <$> f a <*> f b <*> f c
instance Foldable V2 where
foldMap f (V2 a b) = f a `mappend` f b
instance Traversable V2 where
traverse f (V2 a b) = V2 <$> f a <*> f b
instance Foldable V4 where
foldMap f (V4 a b c d) = f a `mappend` f b `mappend` f c `mappend` f d
instance Traversable V4 where
traverse f (V4 a b c d) = V4 <$> f a <*> f b <*> f c <*> f d
instance Foldable V1 where
foldMap f (V1 a) = f a
instance Traversable V1 where
traverse f (V1 a) = V1 <$> f a
instance Num a => Num (V2 a) where
(V2 a b) + (V2 a' b') = V2 (a + a') (b + b')
(V2 a b) (V2 a' b') = V2 (a a') (b b')
(V2 a b) * (V2 a' b') = V2 (a * a') (b * b')
negate (V2 a b) = V2 (negate a) (negate b)
abs (V2 a b) = V2 (abs a) (abs b)
signum (V2 a b) = V2 (signum a) (signum b)
fromInteger = pure . fromInteger
instance Num a => Num (V3 a) where
(V3 a b c) + (V3 a' b' c') = V3 (a + a') (b + b') (c + c')
(V3 a b c) (V3 a' b' c') = V3 (a a') (b b') (c c')
(V3 a b c) * (V3 a' b' c') = V3 (a * a') (b * b') (c * c')
negate (V3 a b c) = V3 (negate a) (negate b) (negate c)
abs (V3 a b c) = V3 (abs a) (abs b) (abs c)
signum (V3 a b c) = V3 (signum a) (signum b) (signum c)
fromInteger = pure . fromInteger
instance Num a => Num (V4 a) where
(V4 a b c d) + (V4 a' b' c' d') = V4 (a + a') (b + b') (c + c') (d + d')
(V4 a b c d) (V4 a' b' c' d') = V4 (a a') (b b') (c c') (d d')
(V4 a b c d) * (V4 a' b' c' d') = V4 (a * a') (b * b') (c * c') (d * d')
negate (V4 a b c d) = V4 (negate a) (negate b) (negate c) (negate d)
abs (V4 a b c d) = V4 (abs a) (abs b) (abs c) (abs d)
signum (V4 a b c d) = V4 (signum a) (signum b) (signum c) (signum d)
fromInteger = pure . fromInteger
instance Applicative V4 where
pure a = V4 a a a a
(V4 f1 f2 f3 f4) <*> (V4 a b c d) = V4 (f1 a) (f2 b) (f3 c) (f4 d)
instance Applicative V3 where
pure a = V3 a a a
(V3 f1 f2 f3) <*> (V3 a b c) = V3 (f1 a) (f2 b) (f3 c)
instance Applicative V2 where
pure a = V2 a a
(V2 f1 f2) <*> (V2 a b) = V2 (f1 a) (f2 b)
instance Applicative V1 where
pure = V1
(V1 f) <*> (V1 v) = V1 $ f v
class Functor f => Additive f where
zero :: Num a => f a
(^+^) :: Num a => f a -> f a -> f a
(^-^) :: Num a => f a -> f a -> f a
lerp :: Num a => a -> f a -> f a -> f a
class Num a => Epsilon a where
nearZero :: a -> Bool
instance Epsilon Float where
nearZero a = abs a <= 1e-6
instance Epsilon Double where
nearZero a = abs a <= 1e-12
instance Epsilon a => Epsilon (V4 a) where
nearZero = nearZero . quadrance
instance Epsilon a => Epsilon (V3 a) where
nearZero = nearZero . quadrance
instance Epsilon a => Epsilon (V2 a) where
nearZero = nearZero . quadrance
instance Epsilon a => Epsilon (V1 a) where
nearZero (V1 a) = nearZero a
instance Additive V4 where
zero = V4 0 0 0 0
(V4 a b c d) ^+^ (V4 a' b' c' d') = V4 (a + a') (b + b') (c + c') (d + d')
(V4 a b c d) ^-^ (V4 a' b' c' d') = V4 (a a') (b b') (c + c') (d + d')
lerp alpha u v = u ^* alpha ^+^ v ^* (1 alpha)
instance Additive V3 where
zero = V3 0 0 0
(V3 a b c) ^+^ (V3 a' b' c') = V3 (a + a') (b + b') (c + c')
(V3 a b c) ^-^ (V3 a' b' c') = V3 (a a') (b b') (c + c')
lerp alpha u v = u ^* alpha ^+^ v ^* (1 alpha)
instance Additive V2 where
zero = V2 0 0
(V2 a b) ^+^ (V2 a' b') = V2 (a + a') (b + b')
(V2 a b) ^-^ (V2 a' b') = V2 (a a') (b b')
lerp alpha u v = u ^* alpha ^+^ v ^* (1 alpha)
instance Additive V1 where
zero = V1 0
(V1 a) ^+^ (V1 a') = V1 (a + a')
(V1 a) ^-^ (V1 a') = V1 (a a')
lerp alpha u v = u ^* alpha ^+^ v ^* (1 alpha)
class Additive f => Metric f where
dot :: Num a => f a -> f a -> a
quadrance :: Num a => f a -> a
quadrance v = dot v v
qd :: Num a => f a -> f a -> a
qd f g = quadrance (f ^-^ g)
distance :: Floating a => f a -> f a -> a
distance f g = norm (f ^-^ g)
norm :: Floating a => f a -> a
norm v = sqrt (quadrance v)
signorm :: Floating a => f a -> f a
signorm v = fmap (/ m) v where
m = norm v
instance Metric V4 where
dot (V4 a b c d) (V4 a' b' c' d') = a * a' + b * b' + c * c' + d * d'
quadrance (V4 a b c d) = a * a + b * b + c * c + d * d
norm v = sqrt (quadrance v)
instance Metric V3 where
dot (V3 a b c) (V3 a' b' c') = a * a' + b * b' + c * c'
quadrance (V3 a b c) = a * a + b * b + c * c
norm v = sqrt (quadrance v)
instance Metric V2 where
dot (V2 a b) (V2 a' b') = a * a' + b * b'
quadrance (V2 a b) = a * a + b * b
norm v = sqrt (quadrance v)
(^*) :: (Functor f, Num a) => f a -> a -> f a
(^*) f n = fmap (* n) f
(^/) :: (Functor f, Floating a) => f a -> a -> f a
(^/) f n = fmap (/ n) f
normalize :: (Floating a, Metric f, Epsilon a) => f a -> f a
normalize v = if nearZero l || nearZero (1l) then v
else fmap (/ sqrt l) v
where l = quadrance v
#endif