colour-space 0.1.5.1 → 0.2.0.0

raw patch · 4 files changed

+346/−27 lines, 4 filesdep +QuickCheckdep +colour-spacedep +manifolds-coredep ~basedep ~colourdep ~manifoldsPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, colour-space, manifolds-core, random, tasty, tasty-quickcheck

Dependency ranges changed: base, colour, manifolds

API changes (from Hackage documentation)

Files

• colour-space.cabal +22/−2
• src/Data/Colour/Manifold.hs +151/−25
• src/Data/Colour/Manifold/Internal.hs +42/−0
• test/tasty/test.hs +131/−0

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                colour-space-version:             0.1.5.1+version:             0.2.0.0 synopsis:            Instances of the manifold-classes for colour types -- description:          homepage:            https://github.com/leftaroundabout/colour-space@@ -18,10 +18,12 @@  library   exposed-modules:     Data.Colour.Manifold+                       Data.Colour.Manifold.Internal   -- other-modules:          -- other-extensions:       build-depends:       base >=4.7 && <5-                     , manifolds >=0.4.5 && <0.6+                     , manifolds >=0.4.5 && <0.7+                     , manifolds-core                      , constrained-categories                      , linearmap-category >=0.3.5                      , linear@@ -29,7 +31,25 @@                      , semigroups                      , lens                      , call-stack+                     , QuickCheck                      , colour > 2 && < 3                      , JuicyPixels >= 3.1 && < 3.4   hs-source-dirs:      src   default-language:    Haskell2010++test-suite tasty+  main-is:         test.hs+  type:            exitcode-stdio-1.0+  hs-source-dirs:  test/tasty+  build-depends:   base, colour-space+                   , QuickCheck+                   , manifolds-core+                   , manifolds+                   , random+                   , colour+                   , vector-space+                   , constrained-categories+                   , tasty, tasty-quickcheck+  ghc-options: -threaded "-with-rtsopts -N4 -M2G"+  default-language:    Haskell2010+

@@ -1,11 +1,17 @@-{-# LANGUAGE TypeFamilies        #-}-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE TypeOperators       #-}-{-# LANGUAGE UnicodeSyntax       #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell     #-}-{-# LANGUAGE Rank2Types          #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE UnicodeSyntax        #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE Rank2Types           #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE DeriveAnyClass       #-}+{-# LANGUAGE EmptyCase            #-}+{-# LANGUAGE CPP                  #-}  module Data.Colour.Manifold (          -- * Full colour space@@ -19,6 +25,8 @@          , SimpleColourMap, blackBlueYellowRed, brightVsRed, redVsBlue          ) where +import Data.Colour.Manifold.Internal+ import Data.Functor (($>)) import Control.Applicative (empty) import Control.Applicative.Constrained@@ -26,16 +34,23 @@ import Data.Semigroup  import Data.Manifold.PseudoAffine+import Math.Manifold.Core.PseudoAffine (GenericNeedle(..)) import Data.Manifold.Types import Data.Manifold.Atlas import Data.Manifold.Riemannian import Data.VectorSpace+import Data.Basis import Data.AffineSpace import Data.AdditiveGroup-import Data.Manifold.Shade (Shade(..), Shade'(..), rangeWithinVertices)-+import Data.Manifold.Shade (Shade(..), Shade'(..)+                           , rangeWithinVertices+                           )+#if MIN_VERSION_manifolds(0,6,0)+import Data.Manifold.WithBoundary+#endif import Data.Colour.SRGB (toSRGB, toSRGB24) import Data.Colour.SRGB.Linear+import Data.Colour.RGBSpace.HSL (hslView, hsl) import Data.Colour hiding (AffineSpace) import Data.Colour.Names @@ -48,21 +63,20 @@  import Codec.Picture.Types +import qualified Test.QuickCheck as QC+ import Data.Coerce import Data.Type.Coercion import Data.CallStack  import Control.Lens+import GHC.Generics +instance QC.Arbitrary ColourNeedle where+  arbitrary = ColourNeedle <$> (+                   RGB <$> QC.arbitrary <*> QC.arbitrary <*> QC.arbitrary ) -newtype ColourNeedle = ColourNeedle { getRGBNeedle :: RGB ℝ } deriving (Eq, 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 @@ -86,7 +100,10 @@ instance TensorSpace ColourNeedle where   type TensorProduct ColourNeedle w = RGB w   scalarSpaceWitness = ScalarSpaceWitness-  linearManifoldWitness = LinearManifoldWitness BoundarylessWitness+  linearManifoldWitness = LinearManifoldWitness+#if !MIN_VERSION_manifolds(0,6,0)+        BoundarylessWitness+#endif   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)@@ -152,6 +169,7 @@   composeLinear = bilinearFunction $ \f (LinearMap (RGB r' g' b'))             -> LinearMap $ RGB (f +$ r') (f +$ g') (f +$ b')    where f+$x = getLinearFunction (getLinearFunction applyLinear f) x+  useTupleLinearSpaceComponents _ = undefined  instance SemiInner ColourNeedle where   dualBasisCandidates = cartesianDualBasisCandidates@@ -184,6 +202,7 @@   recomposeContraLinMap f l = LinearMap $ RGB (f $ fmap (channelRed . getRGBNeedle) l)                                               (f $ fmap (channelGreen . getRGBNeedle) l)                                               (f $ fmap (channelBlue . getRGBNeedle) l)+  tensorEquality (Tensor t) (Tensor τ) = t == τ   recomposeContraLinMapTensor = rclmt dualSpaceWitness    where rclmt :: ∀ u w f . ( Hask.Functor f                             , FiniteDimensional u, LinearSpace w@@ -213,17 +232,46 @@  instance Semimanifold ColourNeedle where   type Needle ColourNeedle = ColourNeedle+#if MIN_VERSION_manifolds(0,6,0)+  (.+~^) = (^+^)+#else   fromInterior = id; toInterior = pure   translateP = pure (^+^)+#endif  instance PseudoAffine ColourNeedle where-  ColourNeedle q .-~. ColourNeedle s = pure . ColourNeedle $ liftA2 (-) q s+  ColourNeedle q .-~! ColourNeedle s = ColourNeedle $ liftA2 (-) q s+  q .-~. s = pure (q.-~!s)  instance Atlas ColourNeedle where   type ChartIndex ColourNeedle = ()+#if !MIN_VERSION_manifolds(0,6,0)   interiorChartReferencePoint _ () = zeroV+#else+  chartReferencePoint () = zeroV+#endif   lookupAtlas _ = () +#if MIN_VERSION_manifolds(0,6,0)+instance SemimanifoldWithBoundary ColourNeedle where+  type Interior ColourNeedle = ColourNeedle+  type Boundary ColourNeedle = EmptyMfd ℝ⁰+  type HalfNeedle ColourNeedle = ℝay+  smfdWBoundWitness = OpenManifoldWitness+  (|+^) b = case b of {}+  _ .+^| b = case b of {}+  fromBoundary b = case b of {}+  fromInterior = id++instance PseudoAffineWithBoundary ColourNeedle where+  _ !-| b = case b of {}+  (.--!) = (.-~!)++instance ProjectableBoundary ColourNeedle where+  projectToBoundary _ b = case b of {}+  marginFromBoundary b _ = case b of {}+#endif+ instance AffineSpace ColourNeedle where   type Diff ColourNeedle = ColourNeedle   (.-.) = (.-~!)@@ -252,22 +300,95 @@ --   = (y - 1 +! sqrt( 1 + y² ) ) / (2*y)  -- unstable for y ≈ 0 --   = 1/2 - (1 - sqrt( 1 + y² ) ) / (2*y) -bijectFromLtd :: CD¹ ℝ⁰ -> Maybe ℝ+bijectFromLtd :: CD¹ ℝ⁰ -> Either S⁰ ℝ bijectFromLtd (CD¹ x Origin)-    | x>0 && x<1  = return $ (x - 0.5) / (x*(1 - x))-    | otherwise   = empty+    | x<=1e-9     = Left NegativeHalfSphere+    | x>=1-1e-9   = Left PositiveHalfSphere+    | otherwise   = return $ (x - 0.5) / (x*(1 - x)) +++#if MIN_VERSION_manifolds(0,6,0)+instance AdditiveMonoid ColourHalfNeedle+instance HalfSpace ColourHalfNeedle+#endif++#if MIN_VERSION_manifolds(0,6,0)+instance QC.Arbitrary ColourBoundary where+  arbitrary = ColourBoundarySphere <$> QC.arbitrary++instance SemimanifoldWithBoundary ColourBoundary where+  type Boundary ColourBoundary = EmptyMfd ℝ⁰+  type Interior ColourBoundary = ColourBoundary+  type HalfNeedle ColourBoundary = ℝay+  smfdWBoundWitness = OpenManifoldWitness+  needleIsOpenMfd q = q+  b|+^_ = case b of {}+  _.+^|b = case b of {}+  fromInterior = id+  fromBoundary b = case b of {}+#endif++instance Hask.Foldable RGB where+  foldMap f (RGB r g b) = f r `mappend` f g `mappend` f b++projectRGBToColourBoundary :: RGB ℝ -> ColourBoundary+projectRGBToColourBoundary c = ColourBoundarySphere $ S²Polar ϑ φ+ where (h,_,l) = hslView c+       φ = h*2*pi/360 - pi+       ϑ = l * pi++#if MIN_VERSION_manifolds(0,6,0)+instance SemimanifoldWithBoundary (Colour ℝ) where+  type Boundary (Colour ℝ) = ColourBoundary+  type HalfNeedle (Colour ℝ) = ColourHalfNeedle+  smfdWBoundWitness = undefined -- SmfdWBoundWitness+  needleIsOpenMfd q = q+  fromBoundary (ColourBoundarySphere (S²Polar ϑ φ))+        = fromRGB $ hsl ((φ+pi)*360/(2*pi)) 1 (ϑ/pi)+  b |+^ ColourHalfNeedle (Cℝay d Origin) δb+        = fromRGB $ hsl ((φ+pi)*360/(2*pi)) (1/(d+1)) (0.5 + (ϑ/pi-0.5)/(d+1))+   where ColourBoundarySphere (S²Polar ϑ φ) = b.+~^δb+  c .+^| ColourNeedle dc+    | η>1        = Left (projectRGBToColourBoundary $ (+).(/η) <$> dc <*> rgb, η - 1)+    | otherwise  = case separateInterior . fromRGB $ (+)<$>dc<*>rgb of+                     Right c' -> Right c'+                     Left c'b -> error $ show (η, (+)<$>dc<*>rgb)+   where rgb = toRGB c+         η = maximum $ (\m d -> if d>0 then if m<1 then d/(1-m) else huge+                                 else if d<0 then -d/m+                                 else 0)+                      <$> rgb <*> dc+         huge = 1e12+  separateInterior c = case toin $ toLtdRGB c of+           Left _ -> Left . projectRGBToColourBoundary $ toRGB c+           Right ci -> Right $ ColourNeedle ci+   where rgb = toRGB c+         toin (RGB r g b) = liftA3 RGB (bijectFromLtd r) (bijectFromLtd g) (bijectFromLtd b)+#else instance Semimanifold (Colour ℝ) where-  type Interior (Colour ℝ) = ColourNeedle   type Needle (Colour ℝ) = ColourNeedle+#endif+  type Interior (Colour ℝ) = ColourNeedle   fromInterior (ColourNeedle q) = fromLtdRGB $ fmap bijectToLtd q-  toInterior = fmap ColourNeedle . toin . toLtdRGB+  toInterior = fmap ColourNeedle . eitherToMaybe . toin . toLtdRGB    where toin (RGB r g b) = liftA3 RGB (bijectFromLtd r) (bijectFromLtd g) (bijectFromLtd b)+#if !MIN_VERSION_manifolds(0,6,0)   translateP = pure (^+^)+#endif +#if MIN_VERSION_manifolds(0,6,0)+instance PseudoAffineWithBoundary (Colour ℝ) where+  c .--! d = ColourNeedle $ (-) <$> toRGB c <*> toRGB d+#else instance PseudoAffine (Colour ℝ) where   c .-~. ζ = liftA2 (^-^) (toInterior c) (toInterior ζ)+#endif +eitherToMaybe :: Either a b -> Maybe b+eitherToMaybe (Left _) = Nothing+eitherToMaybe (Right x) = Just x+ instance Geodesic (Colour ℝ) where   geodesicBetween a b = return $ \(D¹ q) -> blend ((q+1)/2) b a @@ -281,8 +402,10 @@ instance Atlas (Colour ℝ) where   type ChartIndex (Colour ℝ) = ()   chartReferencePoint () = grey+#if !MIN_VERSION_manifolds(0,6,0)   interiorChartReferencePoint = \_ () -> intGrey    where Just intGrey = toInterior (grey :: Colour ℝ)+#endif   lookupAtlas _ = ()  class QuantisedColour c where@@ -315,6 +438,9 @@ colourMapPlane :: Traversal' (ColourMap x) ColourPlane colourMapPlane = lens _cmPlane (\cm pl' -> cm{_cmPlane = pl'}) +fromRGB :: Fractional a => RGB a -> Colour a+fromRGB (RGB r g b) = rgb r g b+ data ColourPlane = ColourPlane {         _cpCold :: Colour ℝ       , _cpNeutral :: Interior (Colour ℝ)@@ -350,7 +476,7 @@                             (spanNorm [(256,0), (0,256)])                                      :: Shade (ℝ,ℝ)    where Just shFn = rangeWithinVertices ((0,0), neutralC)-                                        [((1,0), coldC), ((0,1), hotC)]+                                        [((1,0) :: (ℝ,ℝ), coldC), ((0,1), hotC)]  instance ColourMappable (ℝ,ℝ) where   type ColourMapped (ℝ,ℝ) = Colour ℝ

@@ -0,0 +1,42 @@+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE UnicodeSyntax        #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE Rank2Types           #-}+{-# LANGUAGE DeriveGeneric        #-}+{-# LANGUAGE DeriveAnyClass       #-}+{-# LANGUAGE EmptyCase            #-}+{-# LANGUAGE CPP                  #-}++module Data.Colour.Manifold.Internal where++import Data.Colour.SRGB.Linear+import Data.Manifold.Types+import Math.LinearMap.Category+import Linear.V3+import GHC.Generics++newtype ColourNeedle = ColourNeedle { getRGBNeedle :: RGB ℝ } deriving (Eq, 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+++newtype ColourBoundary = ColourBoundarySphere {+   getColourBounarySphere :: S² -- ^ Corresponds to an inflated version of the HSL bicone+  }+ deriving (Generic, Semimanifold, PseudoAffine, Eq, Show)++data ColourHalfNeedle = ColourHalfNeedle {+         colourBoundaryDistance :: !ℝay+       , colourBoundaryTangent :: !(Needle ColourBoundary)+       }+   deriving (Generic)

@@ -0,0 +1,131 @@+-- |+-- Module      : test+-- Copyright   : (c) Justus Sagemüller 2022+-- License     : GPL v3+-- +-- Maintainer  : (@) jsag $ hvl.no+-- Stability   : experimental+-- Portability : portable+-- ++{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE UnicodeSyntax       #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE DerivingStrategies  #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE CPP                 #-}++import Math.Manifold.Core.PseudoAffine+import Data.Manifold.Types+import Data.Manifold.WithBoundary+import Data.VectorSpace+import Data.Semigroup++import Data.Colour.Manifold+import Data.Colour.Manifold.Internal+import Data.Colour+import Data.Colour.SRGB.Linear++import Test.Tasty+import Test.Tasty.QuickCheck+import qualified Test.QuickCheck as QC+import System.Random (Random)+import Text.Printf++main :: IO ()+main = do+  putStrLn "here"+  defaultMain $ testGroup "Tests"+   [ testGroup "Sanity checks"+    [ testProperty "Self equality"+     $ \(c :: Colour ℝ) -> c ≈≈≈ c+    , testProperty "Equality nontriviality"+     . QC.expectFailure $ \(c :: Colour ℝ) d -> c ≈≈≈ d+    ]+   , testGroup "Manifold laws"+    [ testProperty "Zero displacement"+     $ \(c :: Colour ℝ) -> case toInterior c of+          Nothing -> undefined+          Just ci -> case c .+^| zeroV of+            Right c' -> c'≈≈≈ci+    , testProperty "Boundary retrieval"+     $ \ce -> separateInterior (fromBoundary ce :: Colour ℝ) ≈≈≈ Left ce+    , testProperty "Interior retrieval"+     $ \ci -> separateInterior (fromInterior ci :: Colour ℝ) ≈≈≈ Right ci+    , testProperty "Difference re-addition"+     $ \(c :: Colour ℝ) d+         -> let Just v = c.--.d+            in QC.counterexample (printf "v = %s\n" (show v)) $ case d .+^| v of+                   Left (cb, η) -> QC.property (abs η < 1e-6) .&&. fromBoundary cb ≈≈≈ c+                   Right ci     -> fromInterior ci ≈≈≈ c+    , testProperty "Displacement re-subtraction"+     $ \(c :: Colour ℝ) v+         -> case c .+^| v of+              Left (db, η) -> let w = fromBoundary db.--!c+                                  μ = v<.>w+                                  λ = v<.>v+                              in QC.property (μ>=0 && μ<=λ)+                                     .&&. v^*(μ/λ) ≈≈≈ w+                                     .&&. w^*(1+η) ≈≈≈ v+              Right di     -> fromInterior di.--!c ≈≈≈ v+    ]+   ]+++infix 4 ≈≈, ≈≈≈++class NearEq a where+  (≈≈) :: a -> a -> Bool++instance NearEq ℝ where+  n ≈≈ m+   | abs n<=1, m<=1  = abs (n-m) < 1e-9+   | otherwise       = abs (n-m) < 1e-9 * (abs n + abs n)+instance (NearEq a, NearEq b) => NearEq (a,b) where+  (x,y) ≈≈ (ξ,υ) = x≈≈ξ && y≈≈υ+instance (NearEq a, NearEq b, NearEq c) => NearEq (a,b,c) where+  (x,y,z) ≈≈ (ξ,υ,ζ) = x≈≈ξ && y≈≈υ && z≈≈ζ+instance NearEq a => NearEq (RGB a) where+  RGB r g b ≈≈ RGB ρ γ β = r≈≈ρ && g≈≈γ && b≈≈β+instance NearEq a => NearEq (Maybe a) where+  Just p ≈≈ Just q = p≈≈q+  Nothing ≈≈ Nothing = True+  _ ≈≈ _ = False+instance (NearEq a, NearEq b) => NearEq (Either a b) where+  Left p ≈≈ Left q = p≈≈q+  Right p ≈≈ Right q = p≈≈q+  _ ≈≈ _ = False+instance NearEq D¹ where+  D¹ p ≈≈ D¹ q = abs (p-q) < 1e-9+instance NearEq S² where+  p ≈≈ q = magnitude (p.-~.q) < 1e-9++instance (NearEq a, Fractional a) => NearEq (Colour a) where+  c ≈≈ ζ = toRGB c ≈≈ toRGB ζ+instance NearEq ColourNeedle where+  ColourNeedle v ≈≈ ColourNeedle w = v ≈≈ w+instance (Fractional a, Random a) => QC.Arbitrary (Colour a) where+  arbitrary = rgb <$> QC.choose (0,1) <*> QC.choose (0,1) <*> QC.choose (0,1)+instance NearEq ColourBoundary where+  ColourBoundarySphere v ≈≈ ColourBoundarySphere w = v ≈≈ w++(≈≈≈) :: (NearEq a, Eq a, Show a)+      => a -> a -> QC.Property+p≈≈≈q+ | p≈≈q       = QC.property True+ | otherwise  = p===q+++++instance InnerSpace ColourNeedle where+  ColourNeedle c <.> ColourNeedle d = pr+pg+pb+   where RGB pr pg pb = (*)<$>c<*>d