diff --git a/colour-space.cabal b/colour-space.cabal --- a/colour-space.cabal +++ b/colour-space.cabal @@ -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 diff --git a/src/Data/Colour/Manifold.hs b/src/Data/Colour/Manifold.hs --- a/src/Data/Colour/Manifold.hs +++ b/src/Data/Colour/Manifold.hs @@ -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