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

7.69

/Color/src/Graphics/Color/Adaptation/Internal.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- |
-- Module      : Graphics.Color.Adaptation.Internal
-- Copyright   : (c) Alexey Kuleshevich 2019-2025
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <lehins@yandex.ru>
-- Stability   : experimental
-- Portability : non-portable
--
module Graphics.Color.Adaptation.Internal
  ( ChromaticAdaptation(..)
  , Adaptation(..)
  , chromaticAdaptation
  , convertWith
  , convertElevatedWith
  , convertNoAdaptation
  ) where

import Graphics.Color.Space.Internal
import Graphics.Color.Space.RGB.Internal
import Data.Kind


class (Illuminant it, Illuminant ir, Elevator e, RealFloat e) =>
      ChromaticAdaptation (t :: k) (it :: kt) (ir :: kr) e
  where
  data Adaptation t it ir e :: Type
  adaptColorXYZ :: Adaptation t it ir e -> Color (XYZ it) e -> Color (XYZ ir) e

-- | This performs no adaptation, but only when illuminants are exactly the same
data ExactNoAdaptation

instance (Illuminant i, Elevator e, RealFloat e) =>
         ChromaticAdaptation ExactNoAdaptation i i e where
  data Adaptation ExactNoAdaptation i i e = ExactNoAdaptation
  adaptColorXYZ _ = id

-- | This performs no adaptation, but only when illuminants are almost the same.
data ApproximateNoAdaptation

instance (Illuminant it, Illuminant ir, Elevator e, RealFloat e, Temperature it ~ Temperature ir) =>
         ChromaticAdaptation ApproximateNoAdaptation it ir e where
  data Adaptation ApproximateNoAdaptation it ir e = ApproximateNoAdaptation
  adaptColorXYZ _ (ColorXYZ x y z) = ColorXYZ x y z

chromaticAdaptation ::
     ChromaticAdaptation t it ir e
  => Adaptation t it ir e
  -> Gamut cs it e
  -> Gamut cs ir e
chromaticAdaptation adaptation g = Gamut redPrimary greenPrimary bluePrimary
  where
    applyMatrix primary =
      PrimaryChromaticity
        (Chromaticity (fromColorXYZ (convertWith adaptation (primaryTristimulus primary))))
    redPrimary = applyMatrix (gamutRedPrimary g)
    greenPrimary = applyMatrix (gamutGreenPrimary g)
    bluePrimary = applyMatrix (gamutBluePrimary g)


convertWith ::
     (ChromaticAdaptation t i' i e, ColorSpace cs' i' e, ColorSpace cs i e)
  => Adaptation t i' i e
  -> Color cs' e
  -> Color cs e
convertWith = convertElevatedWith
{-# INLINE convertWith #-}

convertElevatedWith ::
     (ChromaticAdaptation t i' i a, ColorSpace cs' i' e', ColorSpace cs i e)
  => Adaptation t i' i a
  -> Color cs' e'
  -> Color cs e
convertElevatedWith adaptation = fromColorXYZ . adaptColorXYZ adaptation . toColorXYZ
{-# INLINE[2] convertElevatedWith #-}

-- | Convert a color from one color space into another one with the same illuminant, thus
-- not requiring a chromatic adaptation.
--
-- @since 0.1.0
convertNoAdaptation ::
     forall cs' e' cs e i. (ColorSpace cs' i e', ColorSpace cs i e)
  => Color cs' e'
  -> Color cs e
convertNoAdaptation = fromColorXYZ . (toColorXYZ :: Color cs' e' -> Color (XYZ i) Double)
{-# INLINE convertNoAdaptation #-}

convertNoAdaptationFloat ::
     forall cs' e' cs e i. (ColorSpace cs' i e', ColorSpace cs i e)
  => Color cs' e'
  -> Color cs e
convertNoAdaptationFloat = fromColorXYZ . (toColorXYZ :: Color cs' e' -> Color (XYZ i) Float)
{-# INLINE convertNoAdaptationFloat #-}

{-# RULES
"convertElevatedWith (Float)"[~2] forall (a :: Adaptation t i i Float) . convertElevatedWith a = convertNoAdaptationFloat
"convertElevatedWith (Double)"[~2] forall (a :: Adaptation t i i Double) . convertElevatedWith a = convertNoAdaptation
  #-}


-- toword8 <$> (fromColorXYZ (chromaticAdaptationXYZ (vonKriesAdaptationMatrix :: VonKriesAdaptationMatrix Bradford D50a D65 Double) (toColorXYZ (ColorLAB 76.022 (-0.366) 27.636 :: Color (LAB D50a) Double) :: Color XYZ Double)) :: Color SRGB Double)

1	{-# LANGUAGE FlexibleInstances #-}
2	{-# LANGUAGE DataKinds #-}
3	{-# LANGUAGE MultiParamTypeClasses #-}
4	{-# LANGUAGE PolyKinds #-}
5	{-# LANGUAGE ScopedTypeVariables #-}
6	{-# LANGUAGE TypeFamilies #-}
7	{-# LANGUAGE TypeOperators #-}
8	-- \|
9	-- Module : Graphics.Color.Adaptation.Internal
10	-- Copyright : (c) Alexey Kuleshevich 2019-2025
11	-- License : BSD3
12	-- Maintainer : Alexey Kuleshevich <lehins@yandex.ru>
13	-- Stability : experimental
14	-- Portability : non-portable
15	--
16	module Graphics.Color.Adaptation.Internal
17	( ChromaticAdaptation(..)
18	, Adaptation(..)
19	, chromaticAdaptation
20	, convertWith
21	, convertElevatedWith
22	, convertNoAdaptation
23	) where
24
25	import Graphics.Color.Space.Internal
26	import Graphics.Color.Space.RGB.Internal
27	import Data.Kind
28
29
30	class (Illuminant it, Illuminant ir, Elevator e, RealFloat e) =>
31	ChromaticAdaptation (t :: k) (it :: kt) (ir :: kr) e
32	where
33	data Adaptation t it ir e :: Type
34	adaptColorXYZ :: Adaptation t it ir e -> Color (XYZ it) e -> Color (XYZ ir) e
35
36	-- \| This performs no adaptation, but only when illuminants are exactly the same
37	data ExactNoAdaptation
38
39	instance (Illuminant i, Elevator e, RealFloat e) =>
40	ChromaticAdaptation ExactNoAdaptation i i e where
41	data Adaptation ExactNoAdaptation i i e = ExactNoAdaptation
42	adaptColorXYZ _ = id	×
43
44	-- \| This performs no adaptation, but only when illuminants are almost the same.
45	data ApproximateNoAdaptation
46
47	instance (Illuminant it, Illuminant ir, Elevator e, RealFloat e, Temperature it ~ Temperature ir) =>
48	ChromaticAdaptation ApproximateNoAdaptation it ir e where
49	data Adaptation ApproximateNoAdaptation it ir e = ApproximateNoAdaptation
50	adaptColorXYZ _ (ColorXYZ x y z) = ColorXYZ x y z	×
51
52	chromaticAdaptation ::
53	ChromaticAdaptation t it ir e
54	=> Adaptation t it ir e
55	-> Gamut cs it e
56	-> Gamut cs ir e
57	chromaticAdaptation adaptation g = Gamut redPrimary greenPrimary bluePrimary	×
58	where
59	applyMatrix primary =	×
60	PrimaryChromaticity	×
61	(Chromaticity (fromColorXYZ (convertWith adaptation (primaryTristimulus primary))))	×
62	redPrimary = applyMatrix (gamutRedPrimary g)	×
63	greenPrimary = applyMatrix (gamutGreenPrimary g)	×
64	bluePrimary = applyMatrix (gamutBluePrimary g)	×
65
66
67	convertWith ::
68	(ChromaticAdaptation t i' i e, ColorSpace cs' i' e, ColorSpace cs i e)
69	=> Adaptation t i' i e
70	-> Color cs' e
71	-> Color cs e
72	convertWith = convertElevatedWith	×
73	{-# INLINE convertWith #-}
74
75	convertElevatedWith ::
76	(ChromaticAdaptation t i' i a, ColorSpace cs' i' e', ColorSpace cs i e)
77	=> Adaptation t i' i a
78	-> Color cs' e'
79	-> Color cs e
80	convertElevatedWith adaptation = fromColorXYZ . adaptColorXYZ adaptation . toColorXYZ	2✔
81	{-# INLINE[2] convertElevatedWith #-}
82
83	-- \| Convert a color from one color space into another one with the same illuminant, thus
84	-- not requiring a chromatic adaptation.
85	--
86	-- @since 0.1.0
87	convertNoAdaptation ::
88	forall cs' e' cs e i. (ColorSpace cs' i e', ColorSpace cs i e)
89	=> Color cs' e'
90	-> Color cs e
91	convertNoAdaptation = fromColorXYZ . (toColorXYZ :: Color cs' e' -> Color (XYZ i) Double)	×
92	{-# INLINE convertNoAdaptation #-}
93
94	convertNoAdaptationFloat ::
95	forall cs' e' cs e i. (ColorSpace cs' i e', ColorSpace cs i e)
96	=> Color cs' e'
97	-> Color cs e
98	convertNoAdaptationFloat = fromColorXYZ . (toColorXYZ :: Color cs' e' -> Color (XYZ i) Float)	×
99	{-# INLINE convertNoAdaptationFloat #-}
100
101	{-# RULES
102	"convertElevatedWith (Float)"[~2] forall (a :: Adaptation t i i Float) . convertElevatedWith a = convertNoAdaptationFloat
103	"convertElevatedWith (Double)"[~2] forall (a :: Adaptation t i i Double) . convertElevatedWith a = convertNoAdaptation
104	#-}
105
106
107	-- toword8 <$> (fromColorXYZ (chromaticAdaptationXYZ (vonKriesAdaptationMatrix :: VonKriesAdaptationMatrix Bradford D50a D65 Double) (toColorXYZ (ColorLAB 76.022 (-0.366) 27.636 :: Color (LAB D50a) Double) :: Color XYZ Double)) :: Color SRGB Double)

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