lehins / Color / 179

Committed 14 Jan 2025 06:40AM UTC coverage: 71.106%. Remained the same

Build # 179

Build Type

push

github

Committed by

web-flow

Commit Message

Merge pull request #18 from lehins/fix-coveralls

Make casing consistent and ensure coveralls are uploaded

Run Details

2050 of 2883 relevant lines covered (71.11%)

1.37 hits per line

Source File
Press 'n' to go to next uncovered line, 'b' for previous

39.06

/Color/src/Graphics/Color/Algebra.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- |
-- Module      : Graphics.Color.Algebra
-- Copyright   : (c) Alexey Kuleshevich 2019-2025
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Algebra
  ( -- * 2D
    V2(..)
    -- * 3D
  , V3(..)
  , showV3
  , dotProduct
  , M3x3(..)
  , showM3x3
  , detM3x3
  , invertM3x3
  , multM3x3byV3
  , multM3x3byM3x3
  , multM3x3byV3d
  , transposeM3x3
  , module Graphics.Color.Algebra.Elevator
  -- * Helpers
  , showsType
  , asProxy
  ) where

import Data.Typeable
import Foreign.Ptr
import Foreign.Storable
import Graphics.Color.Algebra.Elevator
#if MIN_VERSION_base(4,10,0) && !MIN_VERSION_base(4,18,0)
import Control.Applicative (liftA2)
#endif


--------
-- V2 --
--------

-- | A 2D vector with @x@ and @y@ coordinates.
data V2 a = V2 !a !a
  deriving (Eq, Ord)

instance Elevator a => Show (V2 a) where
  showsPrec _ (V2 x y) =
    ('[' :) . toShowS x . (',' :) . toShowS y . (" ]" ++)

instance Functor V2 where
  fmap f (V2 x y) = V2 (f x) (f y)
  {-# INLINE fmap #-}


zipWithV2 :: (a -> b -> c) -> V2 a -> V2 b -> V2 c
zipWithV2 f (V2 x1 y1) (V2 x2 y2) = V2 (f x1 x2) (f y1 y2)
{-# INLINE zipWithV2 #-}

instance Applicative V2 where
  pure x = V2 x x
  {-# INLINE pure #-}
  (<*>) (V2 fx1 fy1) (V2 x2 y2) = V2 (fx1 x2) (fy1 y2)
  {-# INLINE (<*>) #-}
#if MIN_VERSION_base(4,10,0)
  liftA2 = zipWithV2
  {-# INLINE liftA2 #-}
#endif

instance Foldable V2 where
  foldr f acc (V2 x y) = f x (f y acc)
  {-# INLINE foldr #-}

instance Traversable V2 where
  traverse f (V2 x y) = V2 <$> f x <*> f y
  {-# INLINE traverse #-}

instance Num a => Num (V2 a) where
  (+)         = zipWithV2 (+)
  {-# INLINE (+) #-}
  (-)         = zipWithV2 (-)
  {-# INLINE (-) #-}
  (*)         = zipWithV2 (*)
  {-# INLINE (*) #-}
  abs         = fmap abs
  {-# INLINE abs #-}
  signum      = fmap signum
  {-# INLINE signum #-}
  fromInteger = pure . fromInteger
  {-# INLINE fromInteger #-}


instance Fractional a => Fractional (V2 a) where
  (/)          = zipWithV2 (/)
  {-# INLINE (/) #-}
  recip        = fmap recip
  {-# INLINE recip #-}
  fromRational = pure . fromRational
  {-# INLINE fromRational #-}


instance Floating a => Floating (V2 a) where
  pi      = pure pi
  {-# INLINE pi #-}
  exp     = fmap exp
  {-# INLINE exp #-}
  log     = fmap log
  {-# INLINE log #-}
  sin     = fmap sin
  {-# INLINE sin #-}
  cos     = fmap cos
  {-# INLINE cos #-}
  asin    = fmap asin
  {-# INLINE asin #-}
  atan    = fmap atan
  {-# INLINE atan #-}
  acos    = fmap acos
  {-# INLINE acos #-}
  sinh    = fmap sinh
  {-# INLINE sinh #-}
  cosh    = fmap cosh
  {-# INLINE cosh #-}
  asinh   = fmap asinh
  {-# INLINE asinh #-}
  atanh   = fmap atanh
  {-# INLINE atanh #-}
  acosh   = fmap acosh
  {-# INLINE acosh #-}


instance Storable e => Storable (V2 e) where
  sizeOf _ = 2 * sizeOf (undefined :: e)
  {-# INLINE sizeOf #-}
  alignment _ = alignment (undefined :: e)
  {-# INLINE alignment #-}
  peek p =
    let q = castPtr p
     in V2 <$> peek q <*> peekElemOff q 1
  {-# INLINE peek #-}
  poke p (V2 v0 v1) =
    let q = castPtr p
     in poke q v0 >> pokeElemOff q 1 v1
  {-# INLINE poke #-}


--------
-- V3 --
--------

-- | A 3D vector with @x@, @y@ and @z@ coordinates.
data V3 a = V3 !a !a !a
  deriving (Eq, Ord)

instance Elevator a => Show (V3 a) where
  showsPrec _ (V3 x y z) =
    ('[' :) . toShowS x . (',' :) . toShowS y . (',' :) . toShowS z . (" ]" ++)

showV3 :: Show a => V3 a -> String
showV3 (V3 x y z) = concat ["[ ", show x, ", ", show y, ", ", show z, " ]"]

-- | Mulitply a 1x3 vector by a 3x1 vector, i.e. dot product.
--
-- @since 0.1.0
dotProduct :: Num a => V3 a -> V3 a -> a
dotProduct (V3 u0 u1 u2) (V3 v0 v1 v2) = u0 * v0 + u1 * v1 + u2 * v2
{-# INLINE dotProduct #-}


zipWithV3 :: (a -> b -> c) -> V3 a -> V3 b -> V3 c
zipWithV3 f (V3 x1 y1 z1) (V3 x2 y2 z2) = V3 (f x1 x2) (f y1 y2) (f z1 z2)
{-# INLINE zipWithV3 #-}

instance Functor V3 where
  fmap f (V3 x y z) = V3 (f x) (f y) (f z)
  {-# INLINE fmap #-}

instance Applicative V3 where
  pure x = V3 x x x
  {-# INLINE pure #-}
  (<*>) (V3 fx1 fy1 fz1) (V3 x2 y2 z2) = V3 (fx1 x2) (fy1 y2) (fz1 z2)
  {-# INLINE (<*>) #-}
#if MIN_VERSION_base(4,10,0)
  liftA2 = zipWithV3
  {-# INLINE liftA2 #-}
#endif

instance Foldable V3 where
  foldr f acc (V3 x y z) = f x (f y (f z acc))
  {-# INLINE foldr #-}

instance Traversable V3 where
  traverse f (V3 x y z) = V3 <$> f x <*> f y <*> f z
  {-# INLINE traverse #-}

instance Num a => Num (V3 a) where
  (+)         = zipWithV3 (+)
  {-# INLINE (+) #-}
  (-)         = zipWithV3 (-)
  {-# INLINE (-) #-}
  (*)         = zipWithV3 (*)
  {-# INLINE (*) #-}
  abs         = fmap abs
  {-# INLINE abs #-}
  signum      = fmap signum
  {-# INLINE signum #-}
  fromInteger = pure . fromInteger
  {-# INLINE fromInteger #-}


instance Fractional a => Fractional (V3 a) where
  (/)          = zipWithV3 (/)
  {-# INLINE (/) #-}
  recip        = fmap recip
  {-# INLINE recip #-}
  fromRational = pure . fromRational
  {-# INLINE fromRational #-}


instance Floating a => Floating (V3 a) where
  pi      = pure pi
  {-# INLINE pi #-}
  exp     = fmap exp
  {-# INLINE exp #-}
  log     = fmap log
  {-# INLINE log #-}
  sin     = fmap sin
  {-# INLINE sin #-}
  cos     = fmap cos
  {-# INLINE cos #-}
  asin    = fmap asin
  {-# INLINE asin #-}
  atan    = fmap atan
  {-# INLINE atan #-}
  acos    = fmap acos
  {-# INLINE acos #-}
  sinh    = fmap sinh
  {-# INLINE sinh #-}
  cosh    = fmap cosh
  {-# INLINE cosh #-}
  asinh   = fmap asinh
  {-# INLINE asinh #-}
  atanh   = fmap atanh
  {-# INLINE atanh #-}
  acosh   = fmap acosh
  {-# INLINE acosh #-}


instance Storable e => Storable (V3 e) where
  sizeOf _ = 3 * sizeOf (undefined :: e)
  {-# INLINE sizeOf #-}
  alignment _ = alignment (undefined :: e)
  {-# INLINE alignment #-}
  peek p = do
    let q = castPtr p
    v0 <- peek q
    v1 <- peekElemOff q 1
    v2 <- peekElemOff q 2
    return $! V3 v0 v1 v2

  {-# INLINE peek #-}
  poke p (V3 v0 v1 v2) = do
    let q = castPtr p
    poke q v0
    pokeElemOff q 1 v1
    pokeElemOff q 2 v2
  {-# INLINE poke #-}

----------
-- M3x3 --
----------



-- | A 3x3 Matrix
data M3x3 a = M3x3
  { m3x3row0 :: {-# UNPACK #-}!(V3 a)
  , m3x3row1 :: {-# UNPACK #-}!(V3 a)
  , m3x3row2 :: {-# UNPACK #-}!(V3 a)
  } deriving (Eq)

instance Elevator a => Show (M3x3 a) where
  showsPrec _ (M3x3 v0 v1 v2) =
    ("[ " ++) . shows v0 . ("\n, " ++) . shows v1 . ("\n, " ++) . shows v2 . (" ]" ++)


showM3x3 :: Show a => M3x3 a -> String
showM3x3 (M3x3 v0 v1 v2) =
  concat ["[ ", showV3 v0, "\n, ", showV3 v1, "\n, ", showV3 v2, " ]"]


-- | Mulitply a 3x3 matrix by a 3x1 vector, while getting a vector back.
--
-- @since 0.1.0
multM3x3byV3 :: Num a => M3x3 a -> V3 a -> V3 a
multM3x3byV3 (M3x3 (V3 a b c)
                   (V3 d e f)
                   (V3 g h i)) (V3 v0 v1 v2) = V3 (a * v0 + b * v1 + c * v2)
                                                  (d * v0 + e * v1 + f * v2)
                                                  (g * v0 + h * v1 + i * v2)
{-# INLINE multM3x3byV3 #-}


multM3x3byM3x3 :: Num a => M3x3 a -> M3x3 a -> M3x3 a
multM3x3byM3x3 m1 m2 =
  M3x3
  (V3 (a1 * a2 + b1 * d2 + c1 * g2) (a1 * b2 + b1 * e2 + c1 * h2) (a1 * c2 + b1 * f2 + c1 * i2))
  (V3 (d1 * a2 + e1 * d2 + f1 * g2) (d1 * b2 + e1 * e2 + f1 * h2) (d1 * c2 + e1 * f2 + f1 * i2))
  (V3 (g1 * a2 + h1 * d2 + i1 * g2) (g1 * b2 + h1 * e2 + i1 * h2) (g1 * c2 + h1 * f2 + i1 * i2))
  where
    M3x3 (V3 a1 b1 c1)
         (V3 d1 e1 f1)
         (V3 g1 h1 i1) = m1
    M3x3 (V3 a2 b2 c2)
         (V3 d2 e2 f2)
         (V3 g2 h2 i2) = m2
{-# INLINE multM3x3byM3x3 #-}

-- | Multiply a 3x3 matrix by another 3x3 diagonal matrix represented by a 1x3 vector
multM3x3byV3d :: Num a => M3x3 a -> V3 a -> M3x3 a
multM3x3byV3d m1 m2 =
  M3x3
  (V3 (a1 * a2) (b1 * e2) (c1 * i2))
  (V3 (d1 * a2) (e1 * e2) (f1 * i2))
  (V3 (g1 * a2) (h1 * e2) (i1 * i2))
  where
    M3x3 (V3 a1 b1 c1)
         (V3 d1 e1 f1)
         (V3 g1 h1 i1) = m1
    V3 a2 e2 i2 = m2
{-# INLINE multM3x3byV3d #-}


-- | Invert a 3x3 matrix.
--
-- @since 0.1.0
invertM3x3 :: Fractional a => M3x3 a -> M3x3 a
invertM3x3 (M3x3 (V3 a b c)
                 (V3 d e f)
                 (V3 g h i)) =
  M3x3 (V3 (a' / det) (d' / det) (g' / det))
       (V3 (b' / det) (e' / det) (h' / det))
       (V3 (c' / det) (f' / det) (i' / det))
  where
    !a' =   e*i - f*h
    !b' = -(d*i - f*g)
    !c' =   d*h - e*g
    !d' = -(b*i - c*h)
    !e' =   a*i - c*g
    !f' = -(a*h - b*g)
    !g' =   b*f - c*e
    !h' = -(a*f - c*d)
    !i' =   a*e - b*d
    !det = a*a' + b*b' + c*c'
{-# INLINE invertM3x3 #-}


-- | Compute a determinant of a 3x3 matrix.
--
-- @since 0.1.0
detM3x3 :: Num a => M3x3 a -> a
detM3x3 (M3x3 (V3 i00 i01 i02)
              (V3 i10 i11 i12)
              (V3 i20 i21 i22)) = i00 * (i11 * i22 - i12 * i21) +
                                  i01 * (i12 * i20 - i10 * i22) +
                                  i02 * (i10 * i21 - i11 * i20)
{-# INLINE detM3x3 #-}


transposeM3x3 :: M3x3 a -> M3x3 a
transposeM3x3 (M3x3 (V3 i00 i01 i02)
                    (V3 i10 i11 i12)
                    (V3 i20 i21 i22)) = M3x3 (V3 i00 i10 i20)
                                             (V3 i01 i11 i21)
                                             (V3 i02 i12 i22)
{-# INLINE transposeM3x3 #-}



pureM3x3 :: a -> M3x3 a
pureM3x3 x = M3x3 (pure x) (pure x) (pure x)
{-# INLINE pureM3x3 #-}

mapM3x3 :: (a -> a) -> M3x3 a -> M3x3 a
mapM3x3 f (M3x3 v0 v1 v2) = M3x3 (fmap f v0) (fmap f v1) (fmap f v2)
{-# INLINE mapM3x3 #-}

zipWithM3x3 :: (a -> b -> c) -> M3x3 a -> M3x3 b -> M3x3 c
zipWithM3x3 f (M3x3 v10 v11 v12) (M3x3 v20 v21 v22) =
  M3x3 (zipWithV3 f v10 v20) (zipWithV3 f v11 v21) (zipWithV3 f v12 v22)
{-# INLINE zipWithM3x3 #-}


instance Functor M3x3 where
  fmap f (M3x3 v0 v1 v2) = M3x3 (fmap f v0) (fmap f v1) (fmap f v2)
  {-# INLINE fmap #-}

instance Applicative M3x3 where
  pure x = M3x3 (pure x) (pure x) (pure x)
  {-# INLINE pure #-}
  (<*>) (M3x3 fx1 fy1 fz1) (M3x3 x2 y2 z2) = M3x3 (fx1 <*> x2) (fy1 <*> y2) (fz1 <*> z2)
  {-# INLINE (<*>) #-}
#if MIN_VERSION_base(4,10,0)
  liftA2 = zipWithM3x3
  {-# INLINE liftA2 #-}
#endif

instance Foldable M3x3 where
  foldr f acc (M3x3 x y z) = foldr f (foldr f (foldr f acc z) y) x
  {-# INLINE foldr #-}

instance Traversable M3x3 where
  traverse f (M3x3 x y z) = M3x3 <$> traverse f x <*> traverse f y <*> traverse f z
  {-# INLINE traverse #-}


instance Num a => Num (M3x3 a) where
  (+)         = zipWithM3x3 (+)
  {-# INLINE (+) #-}
  (-)         = zipWithM3x3 (-)
  {-# INLINE (-) #-}
  (*)         = zipWithM3x3 (*)
  {-# INLINE (*) #-}
  abs         = mapM3x3 abs
  {-# INLINE abs #-}
  signum      = mapM3x3 signum
  {-# INLINE signum #-}
  fromInteger = pureM3x3 . fromInteger
  {-# INLINE fromInteger #-}


instance Fractional a => Fractional (M3x3 a) where
  (/)          = zipWithM3x3 (/)
  {-# INLINE (/) #-}
  recip        = mapM3x3 recip
  {-# INLINE recip #-}
  fromRational = pureM3x3 . fromRational
  {-# INLINE fromRational #-}


instance Floating a => Floating (M3x3 a) where
  pi      = pureM3x3 pi
  {-# INLINE pi #-}
  exp     = mapM3x3 exp
  {-# INLINE exp #-}
  log     = mapM3x3 log
  {-# INLINE log #-}
  sin     = mapM3x3 sin
  {-# INLINE sin #-}
  cos     = mapM3x3 cos
  {-# INLINE cos #-}
  asin    = mapM3x3 asin
  {-# INLINE asin #-}
  atan    = mapM3x3 atan
  {-# INLINE atan #-}
  acos    = mapM3x3 acos
  {-# INLINE acos #-}
  sinh    = mapM3x3 sinh
  {-# INLINE sinh #-}
  cosh    = mapM3x3 cosh
  {-# INLINE cosh #-}
  asinh   = mapM3x3 asinh
  {-# INLINE asinh #-}
  atanh   = mapM3x3 atanh
  {-# INLINE atanh #-}
  acosh   = mapM3x3 acosh
  {-# INLINE acosh #-}



showsType :: Typeable t => proxy t -> ShowS
showsType = showsTypeRep . typeRep

asProxy :: p -> (Proxy p -> t) -> t
asProxy _ f = f (Proxy :: Proxy a)

1	{-# LANGUAGE CPP #-}
2	{-# LANGUAGE PolyKinds #-}
3	{-# LANGUAGE BangPatterns #-}
4	{-# LANGUAGE ScopedTypeVariables #-}
5	-- \|
6	-- Module : Graphics.Color.Algebra
7	-- Copyright : (c) Alexey Kuleshevich 2019-2025
8	-- License : BSD3
9	-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>
10	-- Stability : experimental
11	-- Portability : non-portable
12	--
13	module Graphics.Color.Algebra
14	( -- * 2D
15	V2(..)
16	-- * 3D
17	, V3(..)
18	, showV3
19	, dotProduct
20	, M3x3(..)
21	, showM3x3
22	, detM3x3
23	, invertM3x3
24	, multM3x3byV3
25	, multM3x3byM3x3
26	, multM3x3byV3d
27	, transposeM3x3
28	, module Graphics.Color.Algebra.Elevator
29	-- * Helpers
30	, showsType
31	, asProxy
32	) where
33
34	import Data.Typeable
35	import Foreign.Ptr
36	import Foreign.Storable
37	import Graphics.Color.Algebra.Elevator
38	#if MIN_VERSION_base(4,10,0) && !MIN_VERSION_base(4,18,0)
39	import Control.Applicative (liftA2)
40	#endif
41
42
43	--------
44	-- V2 --
45	--------
46
47	-- \| A 2D vector with @x@ and @y@ coordinates.
48	data V2 a = V2 !a !a
49	deriving (Eq, Ord)	×
50
51	instance Elevator a => Show (V2 a) where	×
52	showsPrec _ (V2 x y) =	×
53	('[' :) . toShowS x . (',' :) . toShowS y . (" ]" ++)	×
54
55	instance Functor V2 where	×
56	fmap f (V2 x y) = V2 (f x) (f y)	2✔
57	{-# INLINE fmap #-}
58
59
60	zipWithV2 :: (a -> b -> c) -> V2 a -> V2 b -> V2 c
61	zipWithV2 f (V2 x1 y1) (V2 x2 y2) = V2 (f x1 x2) (f y1 y2)	2✔
62	{-# INLINE zipWithV2 #-}
63
64	instance Applicative V2 where	×
65	pure x = V2 x x	2✔
66	{-# INLINE pure #-}
67	(<*>) (V2 fx1 fy1) (V2 x2 y2) = V2 (fx1 x2) (fy1 y2)	×
68	{-# INLINE (<*>) #-}
69	#if MIN_VERSION_base(4,10,0)
70	liftA2 = zipWithV2	×
71	{-# INLINE liftA2 #-}
72	#endif
73
74	instance Foldable V2 where	×
75	foldr f acc (V2 x y) = f x (f y acc)	1✔
76	{-# INLINE foldr #-}
77
78	instance Traversable V2 where	×
79	traverse f (V2 x y) = V2 <$> f x <*> f y	×
80	{-# INLINE traverse #-}
81
82	instance Num a => Num (V2 a) where	×
83	(+) = zipWithV2 (+)	2✔
84	{-# INLINE (+) #-}
85	(-) = zipWithV2 (-)	×
86	{-# INLINE (-) #-}
87	() = zipWithV2 ()	×
88	{-# INLINE (*) #-}
89	abs = fmap abs	×
90	{-# INLINE abs #-}
91	signum = fmap signum	×
92	{-# INLINE signum #-}
93	fromInteger = pure . fromInteger	2✔
94	{-# INLINE fromInteger #-}
95
96
97	instance Fractional a => Fractional (V2 a) where
98	(/) = zipWithV2 (/)	×
99	{-# INLINE (/) #-}
100	recip = fmap recip	×
101	{-# INLINE recip #-}
102	fromRational = pure . fromRational	×
103	{-# INLINE fromRational #-}
104
105
106	instance Floating a => Floating (V2 a) where	×
107	pi = pure pi	×
108	{-# INLINE pi #-}
109	exp = fmap exp	×
110	{-# INLINE exp #-}
111	log = fmap log	×
112	{-# INLINE log #-}
113	sin = fmap sin	×
114	{-# INLINE sin #-}
115	cos = fmap cos	×
116	{-# INLINE cos #-}
117	asin = fmap asin	×
118	{-# INLINE asin #-}
119	atan = fmap atan	×
120	{-# INLINE atan #-}
121	acos = fmap acos	×
122	{-# INLINE acos #-}
123	sinh = fmap sinh	×
124	{-# INLINE sinh #-}
125	cosh = fmap cosh	×
126	{-# INLINE cosh #-}
127	asinh = fmap asinh	×
128	{-# INLINE asinh #-}
129	atanh = fmap atanh	×
130	{-# INLINE atanh #-}
131	acosh = fmap acosh	×
132	{-# INLINE acosh #-}
133
134
135	instance Storable e => Storable (V2 e) where	2✔
136	sizeOf _ = 2 * sizeOf (undefined :: e)	1✔
137	{-# INLINE sizeOf #-}
138	alignment _ = alignment (undefined :: e)	1✔
139	{-# INLINE alignment #-}
140	peek p =	2✔
141	let q = castPtr p	2✔
142	in V2 <$> peek q <*> peekElemOff q 1	2✔
143	{-# INLINE peek #-}
144	poke p (V2 v0 v1) =	2✔
145	let q = castPtr p	2✔
146	in poke q v0 >> pokeElemOff q 1 v1	2✔
147	{-# INLINE poke #-}
148
149
150	--------
151	-- V3 --
152	--------
153
154	-- \| A 3D vector with @x@, @y@ and @z@ coordinates.
155	data V3 a = V3 !a !a !a
156	deriving (Eq, Ord)	×
157
158	instance Elevator a => Show (V3 a) where	×
159	showsPrec _ (V3 x y z) =	×
160	('[' :) . toShowS x . (',' :) . toShowS y . (',' :) . toShowS z . (" ]" ++)	×
161
162	showV3 :: Show a => V3 a -> String
163	showV3 (V3 x y z) = concat ["[ ", show x, ", ", show y, ", ", show z, " ]"]	×
164
165	-- \| Mulitply a 1x3 vector by a 3x1 vector, i.e. dot product.
166	--
167	-- @since 0.1.0
168	dotProduct :: Num a => V3 a -> V3 a -> a
169	dotProduct (V3 u0 u1 u2) (V3 v0 v1 v2) = u0 * v0 + u1 * v1 + u2 * v2	2✔
170	{-# INLINE dotProduct #-}
171
172
173	zipWithV3 :: (a -> b -> c) -> V3 a -> V3 b -> V3 c
174	zipWithV3 f (V3 x1 y1 z1) (V3 x2 y2 z2) = V3 (f x1 x2) (f y1 y2) (f z1 z2)	2✔
175	{-# INLINE zipWithV3 #-}
176
177	instance Functor V3 where	×
178	fmap f (V3 x y z) = V3 (f x) (f y) (f z)	2✔
179	{-# INLINE fmap #-}
180
181	instance Applicative V3 where	×
182	pure x = V3 x x x	2✔
183	{-# INLINE pure #-}
184	(<*>) (V3 fx1 fy1 fz1) (V3 x2 y2 z2) = V3 (fx1 x2) (fy1 y2) (fz1 z2)	×
185	{-# INLINE (<*>) #-}
186	#if MIN_VERSION_base(4,10,0)
187	liftA2 = zipWithV3	×
188	{-# INLINE liftA2 #-}
189	#endif
190
191	instance Foldable V3 where	×
192	foldr f acc (V3 x y z) = f x (f y (f z acc))	2✔
193	{-# INLINE foldr #-}
194
195	instance Traversable V3 where	×
196	traverse f (V3 x y z) = V3 <$> f x <> f y <> f z	×
197	{-# INLINE traverse #-}
198
199	instance Num a => Num (V3 a) where	×
200	(+) = zipWithV3 (+)	2✔
201	{-# INLINE (+) #-}
202	(-) = zipWithV3 (-)	×
203	{-# INLINE (-) #-}
204	() = zipWithV3 ()	×
205	{-# INLINE (*) #-}
206	abs = fmap abs	×
207	{-# INLINE abs #-}
208	signum = fmap signum	×
209	{-# INLINE signum #-}
210	fromInteger = pure . fromInteger	2✔
211	{-# INLINE fromInteger #-}
212
213
214	instance Fractional a => Fractional (V3 a) where
215	(/) = zipWithV3 (/)	2✔
216	{-# INLINE (/) #-}
217	recip = fmap recip	×
218	{-# INLINE recip #-}
219	fromRational = pure . fromRational	×
220	{-# INLINE fromRational #-}
221
222
223	instance Floating a => Floating (V3 a) where	×
224	pi = pure pi	×
225	{-# INLINE pi #-}
226	exp = fmap exp	×
227	{-# INLINE exp #-}
228	log = fmap log	×
229	{-# INLINE log #-}
230	sin = fmap sin	×
231	{-# INLINE sin #-}
232	cos = fmap cos	×
233	{-# INLINE cos #-}
234	asin = fmap asin	×
235	{-# INLINE asin #-}
236	atan = fmap atan	×
237	{-# INLINE atan #-}
238	acos = fmap acos	×
239	{-# INLINE acos #-}
240	sinh = fmap sinh	×
241	{-# INLINE sinh #-}
242	cosh = fmap cosh	×
243	{-# INLINE cosh #-}
244	asinh = fmap asinh	×
245	{-# INLINE asinh #-}
246	atanh = fmap atanh	×
247	{-# INLINE atanh #-}
248	acosh = fmap acosh	×
249	{-# INLINE acosh #-}
250
251
252	instance Storable e => Storable (V3 e) where	2✔
253	sizeOf _ = 3 * sizeOf (undefined :: e)	1✔
254	{-# INLINE sizeOf #-}
255	alignment _ = alignment (undefined :: e)	1✔
256	{-# INLINE alignment #-}
257	peek p = do	2✔
258	let q = castPtr p	2✔
259	v0 <- peek q	2✔
260	v1 <- peekElemOff q 1	2✔
261	v2 <- peekElemOff q 2	2✔
262	return $! V3 v0 v1 v2	2✔
263
264	{-# INLINE peek #-}
265	poke p (V3 v0 v1 v2) = do	2✔
266	let q = castPtr p	2✔
267	poke q v0	2✔
268	pokeElemOff q 1 v1	2✔
269	pokeElemOff q 2 v2	2✔
270	{-# INLINE poke #-}
271
272	----------
273	-- M3x3 --
274	----------
275
276
277
278	-- \| A 3x3 Matrix
279	data M3x3 a = M3x3
280	{ m3x3row0 :: {-# UNPACK #-}!(V3 a)	×
281	, m3x3row1 :: {-# UNPACK #-}!(V3 a)	2✔
282	, m3x3row2 :: {-# UNPACK #-}!(V3 a)	×
283	} deriving (Eq)	×
284
285	instance Elevator a => Show (M3x3 a) where	×
286	showsPrec _ (M3x3 v0 v1 v2) =	×
287	("[ " ++) . shows v0 . ("\n, " ++) . shows v1 . ("\n, " ++) . shows v2 . (" ]" ++)	×
288
289
290	showM3x3 :: Show a => M3x3 a -> String
291	showM3x3 (M3x3 v0 v1 v2) =	×
292	concat ["[ ", showV3 v0, "\n, ", showV3 v1, "\n, ", showV3 v2, " ]"]	×
293
294
295	-- \| Mulitply a 3x3 matrix by a 3x1 vector, while getting a vector back.
296	--
297	-- @since 0.1.0
298	multM3x3byV3 :: Num a => M3x3 a -> V3 a -> V3 a
299	multM3x3byV3 (M3x3 (V3 a b c)	2✔
300	(V3 d e f)
301	(V3 g h i)) (V3 v0 v1 v2) = V3 (a * v0 + b * v1 + c * v2)	2✔
302	(d * v0 + e * v1 + f * v2)	2✔
303	(g * v0 + h * v1 + i * v2)	2✔
304	{-# INLINE multM3x3byV3 #-}
305
306
307	multM3x3byM3x3 :: Num a => M3x3 a -> M3x3 a -> M3x3 a
308	multM3x3byM3x3 m1 m2 =	2✔
309	M3x3	2✔
310	(V3 (a1 * a2 + b1 * d2 + c1 * g2) (a1 * b2 + b1 * e2 + c1 * h2) (a1 * c2 + b1 * f2 + c1 * i2))	2✔
311	(V3 (d1 * a2 + e1 * d2 + f1 * g2) (d1 * b2 + e1 * e2 + f1 * h2) (d1 * c2 + e1 * f2 + f1 * i2))	2✔
312	(V3 (g1 * a2 + h1 * d2 + i1 * g2) (g1 * b2 + h1 * e2 + i1 * h2) (g1 * c2 + h1 * f2 + i1 * i2))	2✔
313	where
314	M3x3 (V3 a1 b1 c1)
315	(V3 d1 e1 f1)
316	(V3 g1 h1 i1) = m1	2✔
317	M3x3 (V3 a2 b2 c2)
318	(V3 d2 e2 f2)
319	(V3 g2 h2 i2) = m2	2✔
320	{-# INLINE multM3x3byM3x3 #-}
321
322	-- \| Multiply a 3x3 matrix by another 3x3 diagonal matrix represented by a 1x3 vector
323	multM3x3byV3d :: Num a => M3x3 a -> V3 a -> M3x3 a
324	multM3x3byV3d m1 m2 =	2✔
325	M3x3	2✔
326	(V3 (a1 * a2) (b1 * e2) (c1 * i2))	2✔
327	(V3 (d1 * a2) (e1 * e2) (f1 * i2))	2✔
328	(V3 (g1 * a2) (h1 * e2) (i1 * i2))	2✔
329	where
330	M3x3 (V3 a1 b1 c1)
331	(V3 d1 e1 f1)
332	(V3 g1 h1 i1) = m1	2✔
333	V3 a2 e2 i2 = m2	2✔
334	{-# INLINE multM3x3byV3d #-}
335
336
337	-- \| Invert a 3x3 matrix.
338	--
339	-- @since 0.1.0
340	invertM3x3 :: Fractional a => M3x3 a -> M3x3 a
341	invertM3x3 (M3x3 (V3 a b c)	2✔
342	(V3 d e f)
343	(V3 g h i)) =
344	M3x3 (V3 (a' / det) (d' / det) (g' / det))	2✔
345	(V3 (b' / det) (e' / det) (h' / det))	2✔
346	(V3 (c' / det) (f' / det) (i' / det))	2✔
347	where
348	!a' = ei - fh	2✔
349	!b' = -(di - fg)	2✔
350	!c' = dh - eg	2✔
351	!d' = -(bi - ch)	2✔
352	!e' = ai - cg	2✔
353	!f' = -(ah - bg)	2✔
354	!g' = bf - ce	2✔
355	!h' = -(af - cd)	2✔
356	!i' = ae - bd	2✔
357	!det = aa' + bb' + c*c'	2✔
358	{-# INLINE invertM3x3 #-}
359
360
361	-- \| Compute a determinant of a 3x3 matrix.
362	--
363	-- @since 0.1.0
364	detM3x3 :: Num a => M3x3 a -> a
365	detM3x3 (M3x3 (V3 i00 i01 i02)	×
366	(V3 i10 i11 i12)
367	(V3 i20 i21 i22)) = i00 * (i11 * i22 - i12 * i21) +	×
368	i01 * (i12 * i20 - i10 * i22) +	×
369	i02 * (i10 * i21 - i11 * i20)	×
370	{-# INLINE detM3x3 #-}
371
372
373	transposeM3x3 :: M3x3 a -> M3x3 a
374	transposeM3x3 (M3x3 (V3 i00 i01 i02)	×
375	(V3 i10 i11 i12)
376	(V3 i20 i21 i22)) = M3x3 (V3 i00 i10 i20)	×
377	(V3 i01 i11 i21)	×
378	(V3 i02 i12 i22)	×
379	{-# INLINE transposeM3x3 #-}
380
381
382
383	pureM3x3 :: a -> M3x3 a
384	pureM3x3 x = M3x3 (pure x) (pure x) (pure x)	×
385	{-# INLINE pureM3x3 #-}
386
387	mapM3x3 :: (a -> a) -> M3x3 a -> M3x3 a
388	mapM3x3 f (M3x3 v0 v1 v2) = M3x3 (fmap f v0) (fmap f v1) (fmap f v2)	×
389	{-# INLINE mapM3x3 #-}
390
391	zipWithM3x3 :: (a -> b -> c) -> M3x3 a -> M3x3 b -> M3x3 c
392	zipWithM3x3 f (M3x3 v10 v11 v12) (M3x3 v20 v21 v22) =	2✔
393	M3x3 (zipWithV3 f v10 v20) (zipWithV3 f v11 v21) (zipWithV3 f v12 v22)	2✔
394	{-# INLINE zipWithM3x3 #-}
395
396
397	instance Functor M3x3 where	×
398	fmap f (M3x3 v0 v1 v2) = M3x3 (fmap f v0) (fmap f v1) (fmap f v2)	2✔
399	{-# INLINE fmap #-}
400
401	instance Applicative M3x3 where	×
402	pure x = M3x3 (pure x) (pure x) (pure x)	×
403	{-# INLINE pure #-}
404	(<>) (M3x3 fx1 fy1 fz1) (M3x3 x2 y2 z2) = M3x3 (fx1 <> x2) (fy1 <> y2) (fz1 <> z2)	×
405	{-# INLINE (<*>) #-}
406	#if MIN_VERSION_base(4,10,0)
407	liftA2 = zipWithM3x3	×
408	{-# INLINE liftA2 #-}
409	#endif
410
411	instance Foldable M3x3 where	×
412	foldr f acc (M3x3 x y z) = foldr f (foldr f (foldr f acc z) y) x	×
413	{-# INLINE foldr #-}
414
415	instance Traversable M3x3 where	×
416	traverse f (M3x3 x y z) = M3x3 <$> traverse f x <> traverse f y <> traverse f z	×
417	{-# INLINE traverse #-}
418
419
420	instance Num a => Num (M3x3 a) where	×
421	(+) = zipWithM3x3 (+)	×
422	{-# INLINE (+) #-}
423	(-) = zipWithM3x3 (-)	×
424	{-# INLINE (-) #-}
425	() = zipWithM3x3 ()	2✔
426	{-# INLINE (*) #-}
427	abs = mapM3x3 abs	×
428	{-# INLINE abs #-}
429	signum = mapM3x3 signum	×
430	{-# INLINE signum #-}
431	fromInteger = pureM3x3 . fromInteger	×
432	{-# INLINE fromInteger #-}
433
434
435	instance Fractional a => Fractional (M3x3 a) where
436	(/) = zipWithM3x3 (/)	×
437	{-# INLINE (/) #-}
438	recip = mapM3x3 recip	×
439	{-# INLINE recip #-}
440	fromRational = pureM3x3 . fromRational	×
441	{-# INLINE fromRational #-}
442
443
444	instance Floating a => Floating (M3x3 a) where	×
445	pi = pureM3x3 pi	×
446	{-# INLINE pi #-}
447	exp = mapM3x3 exp	×
448	{-# INLINE exp #-}
449	log = mapM3x3 log	×
450	{-# INLINE log #-}
451	sin = mapM3x3 sin	×
452	{-# INLINE sin #-}
453	cos = mapM3x3 cos	×
454	{-# INLINE cos #-}
455	asin = mapM3x3 asin	×
456	{-# INLINE asin #-}
457	atan = mapM3x3 atan	×
458	{-# INLINE atan #-}
459	acos = mapM3x3 acos	×
460	{-# INLINE acos #-}
461	sinh = mapM3x3 sinh	×
462	{-# INLINE sinh #-}
463	cosh = mapM3x3 cosh	×
464	{-# INLINE cosh #-}
465	asinh = mapM3x3 asinh	×
466	{-# INLINE asinh #-}
467	atanh = mapM3x3 atanh	×
468	{-# INLINE atanh #-}
469	acosh = mapM3x3 acosh	×
470	{-# INLINE acosh #-}
471
472
473
474	showsType :: Typeable t => proxy t -> ShowS
475	showsType = showsTypeRep . typeRep	2✔
476
477	asProxy :: p -> (Proxy p -> t) -> t
478	asProxy _ f = f (Proxy :: Proxy a)	×

lehins / Color / 179

Source File Press 'n' to go to next uncovered line, 'b' for previous

Source File
Press 'n' to go to next uncovered line, 'b' for previous