colour-space 0.1.0.0 → 0.1.1.0

raw patch · 2 files changed

+138/−9 lines, 2 filesdep +constrained-categoriesdep +lineardep +linearmap-categorydep ~basedep ~manifoldsPVP ok

version bump matches the API change (PVP)

Dependencies added: constrained-categories, linear, linearmap-category

Dependency ranges changed: base, manifolds

API changes (from Hackage documentation)

Files

• colour-space.cabal +6/−3
• src/Data/Colour/Manifold.hs +132/−6

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                colour-space-version:             0.1.0.0+version:             0.1.1.0 synopsis:            Instances of the manifold-classes for colour types -- description:          homepage:            https://github.com/leftaroundabout/colour-space@@ -20,8 +20,11 @@   exposed-modules:     Data.Colour.Manifold   -- other-modules:          -- other-extensions:    -  build-depends:       base >=4.7 && <4.9-                     , manifolds >=0.1.5 && <0.4+  build-depends:       base >=4.7 && <5+                     , manifolds >=0.3 && <0.3.1+                     , constrained-categories+                     , linearmap-category+                     , linear                      , vector-space                      , semigroups                      , colour > 2 && < 3

@@ -1,10 +1,13 @@ {-# LANGUAGE TypeFamilies      #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE TypeOperators     #-}  module Data.Colour.Manifold (Colour, QuantisedColour(..)) where -import Control.Applicative-import Control.Arrow+import Control.Applicative (empty)+import Control.Applicative.Constrained+import Control.Arrow.Constrained import Data.Semigroup  import Data.Manifold.PseudoAffine@@ -17,10 +20,31 @@ import Data.Colour.SRGB.Linear import Data.Colour +import Math.LinearMap.Category+import Linear.V3++import qualified Prelude as Hask+import Control.Category.Constrained.Prelude+ import Codec.Picture.Types -newtype ColourNeedle = ColourNeedle { getRGBNeedle :: RGB ℝ }+import Data.Coerce+import Data.Type.Coercion +newtype ColourNeedle = ColourNeedle { getRGBNeedle :: RGB ℝ } deriving (Show)++asV3Needle :: ColourNeedle -+> V3 ℝ+asV3Needle = LinearFunction $ \(ColourNeedle (RGB r g b)) -> V3 r g b++fromV3Needle :: V3 ℝ -+> ColourNeedle+fromV3Needle = LinearFunction $ \(V3 r g b) -> ColourNeedle $ RGB r g b++asV3Tensor :: (ColourNeedle⊗w) -+> (V3 ℝ⊗w)+asV3Tensor = LinearFunction $ \(Tensor (RGB r g b)) -> Tensor $ V3 r g b++fromV3Tensor :: (V3 ℝ⊗w) -+> (ColourNeedle⊗w)+fromV3Tensor = LinearFunction $ \(Tensor (V3 r g b)) -> Tensor $ RGB r g b+ withRGBNeedle :: (RGB Double -> RGB Double) -> ColourNeedle -> ColourNeedle withRGBNeedle f (ColourNeedle q) = ColourNeedle $ f q @@ -32,6 +56,96 @@   type Scalar ColourNeedle = ℝ   (*^)μ = withRGBNeedle $ fmap (μ*) +instance TensorSpace ColourNeedle where+  type TensorProduct ColourNeedle w = RGB w+  zeroTensor = Tensor (RGB zeroV zeroV zeroV)+  toFlatTensor = LinearFunction $ \(ColourNeedle (RGB r g b)) -> Tensor (RGB r g b)+  fromFlatTensor = LinearFunction $ \(Tensor (RGB r g b)) -> ColourNeedle (RGB r g b)+  addTensors (Tensor (RGB r g b)) (Tensor (RGB r' g' b'))+                = Tensor $ RGB (r^+^r') (g^+^g') (b^+^b')+  negateTensor = LinearFunction $ \(Tensor (RGB r g b))+                       -> Tensor (RGB (negateV r) (negateV g) (negateV b))+  scaleTensor = bilinearFunction $ \μ (Tensor (RGB r g b))+                       -> Tensor (RGB (μ*^r) (μ*^g) (μ*^b))+  tensorProduct = bilinearFunction $ \(ColourNeedle (RGB r g b)) w+                       -> Tensor (RGB (r*^w) (g*^w) (b*^w))+  transposeTensor = (fmapTensor $ fromV3Needle) . transposeTensor . asV3Tensor+  fmapTensor = bilinearFunction $ \f (Tensor (RGB r g b))+                   -> Tensor $ RGB (f $ r) (f $ g) (f $ b)+  fzipTensorWith = bilinearFunction $ \f (Tensor (RGB r g b), Tensor (RGB r' g' b'))+                   -> Tensor $ RGB (f $ (r,r')) (f $ (g,g')) (f $ (b,b'))+  coerceFmapTensorProduct _ Coercion = Coercion++instance LinearSpace ColourNeedle where+  type DualVector ColourNeedle = ColourNeedle+  linearId = LinearMap $ RGB (ColourNeedle $ RGB 1 0 0)+                             (ColourNeedle $ RGB 0 1 0)+                             (ColourNeedle $ RGB 0 0 1)+  coerceDoubleDual = Coercion+  blockVectSpan = LinearFunction $ \w -> Tensor $ RGB (LinearMap $ RGB w o o)+                                                      (LinearMap $ RGB o w o)+                                                      (LinearMap $ RGB o o w)+   where o = zeroV+  contractTensorMap = LinearFunction $ \(LinearMap (RGB (Tensor (RGB r _ _))+                                                        (Tensor (RGB _ g _))+                                                        (Tensor (RGB _ _ b))))+                        -> r ^+^ g ^+^ b+  contractMapTensor = LinearFunction $ \(Tensor (RGB (LinearMap (RGB r _ _))+                                                     (LinearMap (RGB _ g _))+                                                     (LinearMap (RGB _ _ b))))+                        -> r ^+^ g ^+^ b+  contractLinearMapAgainst = bilinearFunction $ \(LinearMap (RGB r g b)) f+                        -> channelRed (getRGBNeedle $ f $ r)+                         + channelGreen (getRGBNeedle $ f $ g)+                         + channelBlue (getRGBNeedle $ f $ b)+  applyDualVector = bilinearFunction $+         \(ColourNeedle (RGB r' g' b')) (ColourNeedle (RGB r g b))+            -> r'*r + g'*g + b'*b+  applyLinear = bilinearFunction $ \(LinearMap (RGB r' g' b')) (ColourNeedle (RGB r g b))+            -> r'^*r ^+^ g'^*g ^+^ b'^*b+  composeLinear = bilinearFunction $ \f (LinearMap (RGB r' g' b'))+            -> LinearMap $ RGB (f $ r') (f $ g') (f $ b')++instance SemiInner ColourNeedle where+  dualBasisCandidates = cartesianDualBasisCandidates+           [ColourNeedle (RGB 1 0 0), ColourNeedle (RGB 0 1 0), ColourNeedle (RGB 0 0 1)]+           (\(ColourNeedle (RGB r g b)) -> abs <$> [r,g,b])++instance FiniteDimensional ColourNeedle where+  data SubBasis ColourNeedle = ColourNeedleBasis+  entireBasis = ColourNeedleBasis+  enumerateSubBasis ColourNeedleBasis+          = ColourNeedle <$> [RGB 1 0 0, RGB 0 1 0, RGB 0 0 1]+  decomposeLinMap (LinearMap (RGB r g b)) = (ColourNeedleBasis, ([r,g,b]++))+  decomposeLinMapWithin ColourNeedleBasis (LinearMap (RGB r g b)) = pure ([r,g,b]++)+  recomposeSB ColourNeedleBasis [] = (ColourNeedle $ RGB 0 0 0, [])+  recomposeSB ColourNeedleBasis [r] = (ColourNeedle $ RGB r 0 0, [])+  recomposeSB ColourNeedleBasis [r,g] = (ColourNeedle $ RGB r g 0, [])+  recomposeSB ColourNeedleBasis (r:g:b:l) = (ColourNeedle $ RGB r g b, l)+  recomposeSBTensor ColourNeedleBasis sbw l+          = let (r,l') = recomposeSB sbw l+                (g,l'') = recomposeSB sbw l'+                (b,l''') = recomposeSB sbw l''+            in (Tensor $ RGB r g b, l''')+  recomposeLinMap ColourNeedleBasis [] = (LinearMap $ RGB zeroV zeroV zeroV, [])+  recomposeLinMap ColourNeedleBasis [r] = (LinearMap $ RGB r zeroV zeroV, [])+  recomposeLinMap ColourNeedleBasis [r,g] = (LinearMap $ RGB r g zeroV, [])+  recomposeLinMap ColourNeedleBasis (r:g:b:l) = (LinearMap $ RGB r g b, l)+  recomposeContraLinMap f l = LinearMap $ RGB (f $ fmap (channelRed . getRGBNeedle) l)+                                              (f $ fmap (channelGreen . getRGBNeedle) l)+                                              (f $ fmap (channelBlue . getRGBNeedle) l)+  recomposeContraLinMapTensor fw mv = LinearMap $+       (\c -> fromLinearMap $ recomposeContraLinMap fw+                $ fmap (\(Tensor q) -> c q) mv)+                       <$> RGB channelRed channelGreen channelBlue+  uncanonicallyFromDual = id+  uncanonicallyToDual = id++fromLinearMap :: (LSpace u, Scalar u ~ s) => LinearMap s (DualVector u) w -> Tensor s u w+fromLinearMap = coerce++  + instance Semimanifold ColourNeedle where   type Needle ColourNeedle = ColourNeedle   fromInterior = id; toInterior = pure@@ -50,13 +164,19 @@ type LtdCol = RGB (CD¹ ℝ⁰)  bijectToLtd :: ℝ -> CD¹ ℝ⁰-bijectToLtd y = CD¹ ( ( y - 1 + sqrt(1+y^2) ) / (2*y) ) Origin+bijectToLtd 0 = CD¹ 0.5 Origin+bijectToLtd y+  | ψ > 0.5    = CD¹ 1 Origin+  | ψ > -0.5   = CD¹ ( 0.5 - ψ ) Origin+  | otherwise  = CD¹ 0 Origin+ where ψ = (1 - sqrt(1+y^2)) / (2*y) -- y = (x - 1/2) / (x*(1 - x)) -- y * x * (1 - x) = x - 1/2 -- y * x² - (1 - y) * x - 1/2 = 0 -- y * x² + (y - 1) * x - 1/2 = 0 -- x = (1 - y ± sqrt( (1-y)² + 2*y ) ) / (-2*y)---   = (y - 1 +! sqrt( 1 + y² ) ) / (2*y)+--   = (y - 1 +! sqrt( 1 + y² ) ) / (2*y)  -- unstable for y ≈ 0+--   = 1/2 - (1 - sqrt( 1 + y² ) ) / (2*y)  bijectFromLtd :: CD¹ ℝ⁰ -> Option ℝ bijectFromLtd (CD¹ x Origin)@@ -75,8 +195,14 @@   c .-~. ζ = (^-^ζ) <$> toInterior c  instance Geodesic (Colour ℝ) where-  geodesicBetween a b = pure $ \(D¹ q) -> blend ((q+1)/2) b a+  geodesicBetween a b = return $ \(D¹ q) -> blend ((q+1)/2) b a +instance Geodesic ColourNeedle where+  geodesicBetween (ColourNeedle (RGB r g b)) (ColourNeedle (RGB r' g' b'))+                 = return $ \(D¹ q) -> let η' = (q+1)/2 in ColourNeedle+                                        $ RGB (lerp r r' η')+                                              (lerp g g' η')+                                              (lerp b b' η')  class QuantisedColour c where   quantiseColour :: Colour ℝ -> c