colour-space 0.1.1.0 → 0.1.2.0
raw patch · 2 files changed
+64/−20 lines, 2 filesdep ~manifoldsPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: manifolds
API changes (from Hackage documentation)
- Data.Colour.Manifold: instance Data.Manifold.PseudoAffine.PseudoAffine (Data.Colour.Internal.Colour Data.Manifold.Types.Primitive.ℝ)
- Data.Colour.Manifold: instance Data.Manifold.PseudoAffine.PseudoAffine Data.Colour.Manifold.ColourNeedle
- Data.Colour.Manifold: instance Data.Manifold.PseudoAffine.Semimanifold (Data.Colour.Internal.Colour Data.Manifold.Types.Primitive.ℝ)
- Data.Colour.Manifold: instance Data.Manifold.PseudoAffine.Semimanifold Data.Colour.Manifold.ColourNeedle
- Data.Colour.Manifold: instance Data.Manifold.Riemannian.Geodesic (Data.Colour.Internal.Colour Data.Manifold.Types.Primitive.ℝ)
+ Data.Colour.Manifold: instance Data.AffineSpace.AffineSpace Data.Colour.Manifold.ColourNeedle
+ Data.Colour.Manifold: instance Data.Manifold.Riemannian.Geodesic (Data.Colour.Internal.Colour Math.Manifold.Core.Types.ℝ)
+ Data.Colour.Manifold: instance Math.Manifold.Core.PseudoAffine.PseudoAffine (Data.Colour.Internal.Colour Math.Manifold.Core.Types.ℝ)
+ Data.Colour.Manifold: instance Math.Manifold.Core.PseudoAffine.PseudoAffine Data.Colour.Manifold.ColourNeedle
+ Data.Colour.Manifold: instance Math.Manifold.Core.PseudoAffine.Semimanifold (Data.Colour.Internal.Colour Math.Manifold.Core.Types.ℝ)
+ Data.Colour.Manifold: instance Math.Manifold.Core.PseudoAffine.Semimanifold Data.Colour.Manifold.ColourNeedle
Files
- colour-space.cabal +2/−2
- src/Data/Colour/Manifold.hs +62/−18
colour-space.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: colour-space-version: 0.1.1.0+version: 0.1.2.0 synopsis: Instances of the manifold-classes for colour types -- description: homepage: https://github.com/leftaroundabout/colour-space@@ -21,7 +21,7 @@ -- other-modules: -- other-extensions: build-depends: base >=4.7 && <5- , manifolds >=0.3 && <0.3.1+ , manifolds >=0.3.1 && <0.4 , constrained-categories , linearmap-category , linear
src/Data/Colour/Manifold.hs view
@@ -1,7 +1,9 @@-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE ScopedTypeVariables #-} module Data.Colour.Manifold (Colour, QuantisedColour(..)) where @@ -14,11 +16,12 @@ import Data.Manifold.Types import Data.Manifold.Riemannian import Data.VectorSpace+import Data.AffineSpace import Data.AdditiveGroup import Data.Colour.SRGB (toSRGB, toSRGB24) import Data.Colour.SRGB.Linear-import Data.Colour+import Data.Colour hiding (AffineSpace) import Math.LinearMap.Category import Linear.V3@@ -45,6 +48,9 @@ fromV3Tensor :: (V3 ℝ⊗w) -+> (ColourNeedle⊗w) fromV3Tensor = LinearFunction $ \(Tensor (V3 r g b)) -> Tensor $ RGB r g b +fromV3LinMap :: (V3 ℝ+>w) -+> (ColourNeedle+>w)+fromV3LinMap = LinearFunction $ \(LinearMap (V3 r g b)) -> LinearMap $ RGB r g b+ withRGBNeedle :: (RGB Double -> RGB Double) -> ColourNeedle -> ColourNeedle withRGBNeedle f (ColourNeedle q) = ColourNeedle $ f q @@ -58,6 +64,8 @@ instance TensorSpace ColourNeedle where type TensorProduct ColourNeedle w = RGB w+ scalarSpaceWitness = ScalarSpaceWitness+ linearManifoldWitness = LinearManifoldWitness BoundarylessWitness 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)@@ -69,7 +77,8 @@ -> 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+ transposeTensor = (getLinearFunction 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'))@@ -81,11 +90,16 @@ linearId = LinearMap $ RGB (ColourNeedle $ RGB 1 0 0) (ColourNeedle $ RGB 0 1 0) (ColourNeedle $ RGB 0 0 1)+ tensorId = ti dualSpaceWitness (asTensor $ id)+ where ti :: ∀ w . (TensorSpace w, Scalar w ~ ℝ)+ => DualSpaceWitness w -> Tensor ℝ (DualVector w) w+ -> Tensor ℝ ColourNeedle w+>Tensor ℝ ColourNeedle w+ ti DualSpaceWitness wid = LinearMap $ RGB+ (fmap (LinearFunction $ \w -> Tensor $ RGB w zeroV zeroV) $ wid)+ (fmap (LinearFunction $ \w -> Tensor $ RGB zeroV w zeroV) $ wid)+ (fmap (LinearFunction $ \w -> Tensor $ RGB zeroV zeroV w) $ wid) 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+ dualSpaceWitness = DualSpaceWitness contractTensorMap = LinearFunction $ \(LinearMap (RGB (Tensor (RGB r _ _)) (Tensor (RGB _ g _)) (Tensor (RGB _ _ b))))@@ -103,13 +117,24 @@ -> r'*r + g'*g + b'*b applyLinear = bilinearFunction $ \(LinearMap (RGB r' g' b')) (ColourNeedle (RGB r g b)) -> r'^*r ^+^ g'^*g ^+^ b'^*b+ applyTensorFunctional = bilinearFunction+ $ \(LinearMap (RGB r' g' b')) (Tensor (RGB r g b))+ -> r'<.>^r + g'<.>^g + b'<.>^b+ applyTensorLinMap = bilinearFunction+ $ \(LinearMap (RGB r' g' b')) (Tensor (RGB r g b))+ -> (r'+$r) ^+^ (g'+$g) ^+^ (b'+$b)+ where f+$x = getLinearFunction (getLinearFunction applyLinear $ fromTensor $ f) x composeLinear = bilinearFunction $ \f (LinearMap (RGB r' g' b'))- -> LinearMap $ RGB (f $ r') (f $ g') (f $ b')+ -> LinearMap $ RGB (f +$ r') (f +$ g') (f +$ b')+ where f+$x = getLinearFunction (getLinearFunction applyLinear f) x 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])+ tensorDualBasisCandidates = map (second $ getLinearFunction asV3Tensor)+ >>> tensorDualBasisCandidates+ >>> map (fmap $ second $ getLinearFunction fromV3LinMap) instance FiniteDimensional ColourNeedle where data SubBasis ColourNeedle = ColourNeedleBasis@@ -134,15 +159,30 @@ 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)+ recomposeContraLinMapTensor = rclmt dualSpaceWitness+ where rclmt :: ∀ u w f . ( Hask.Functor f+ , FiniteDimensional u, LinearSpace w+ , Scalar u ~ ℝ, Scalar w ~ ℝ )+ => DualSpaceWitness u+ -> (f ℝ -> w) -> f (ColourNeedle+>DualVector u)+ -> (ColourNeedle⊗u)+>w+ rclmt DualSpaceWitness fw mv = LinearMap $+ (\c -> fromLinearMap $ recomposeContraLinMap fw+ $ fmap (\(LinearMap 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+fromLinearMap :: ∀ s u v w . (LinearSpace u, Scalar u ~ s)+ => LinearMap s (DualVector u) w -> Tensor s u w+fromLinearMap = case dualSpaceWitness :: DualSpaceWitness u of+ DualSpaceWitness -> coerce+asTensor :: ∀ s u v w . (LinearSpace u, Scalar u ~ s)+ => LinearMap s u w -> Tensor s (DualVector u) w+asTensor = coerce+fromTensor :: ∀ s u v w . (LinearSpace u, Scalar u ~ s)+ => Tensor s (DualVector u) w -> LinearMap s u w+fromTensor = coerce @@ -154,6 +194,10 @@ instance PseudoAffine ColourNeedle where ColourNeedle q .-~. ColourNeedle s = pure . ColourNeedle $ liftA2 (-) q s +instance AffineSpace ColourNeedle where+ type Diff ColourNeedle = ColourNeedle+ (.-.) = (.-~!)+ (.+^) = (.+~^) fromLtdRGB :: LtdCol -> Colour ℝ fromLtdRGB = fmap (\(CD¹ h Origin) -> h) >>> \(RGB r g b) -> rgb r g b@@ -178,7 +222,7 @@ -- = (y - 1 +! sqrt( 1 + y² ) ) / (2*y) -- unstable for y ≈ 0 -- = 1/2 - (1 - sqrt( 1 + y² ) ) / (2*y) -bijectFromLtd :: CD¹ ℝ⁰ -> Option ℝ+bijectFromLtd :: CD¹ ℝ⁰ -> Maybe ℝ bijectFromLtd (CD¹ x Origin) | x>0 && x<1 = return $ (x - 0.5) / (x*(1 - x)) | otherwise = empty@@ -192,7 +236,7 @@ translateP = pure (^+^) instance PseudoAffine (Colour ℝ) where- c .-~. ζ = (^-^ζ) <$> toInterior c+ c .-~. ζ = liftA2 (^-^) (toInterior c) (toInterior ζ) instance Geodesic (Colour ℝ) where geodesicBetween a b = return $ \(D¹ q) -> blend ((q+1)/2) b a