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.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 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,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