colour-space 0.1.4.0 → 0.1.5.0
raw patch · 2 files changed
+129/−5 lines, 2 filesdep +call-stackdep +lensdep ~linearmap-categorydep ~manifolds
Dependencies added: call-stack, lens
Dependency ranges changed: linearmap-category, manifolds
Files
- colour-space.cabal +6/−4
- src/Data/Colour/Manifold.hs +123/−1
colour-space.cabal view
@@ -2,14 +2,14 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: colour-space-version: 0.1.4.0+version: 0.1.5.0 synopsis: Instances of the manifold-classes for colour types -- description: homepage: https://github.com/leftaroundabout/colour-space license: GPL-3 license-file: LICENSE author: Justus Sagemüller-maintainer: (@) jsagemue $ uni-koeln.de+maintainer: (@) jsag $ hvl.no -- copyright: category: Data, Maths, Graphics build-type: Simple@@ -21,12 +21,14 @@ -- other-modules: -- other-extensions: build-depends: base >=4.7 && <5- , manifolds >=0.4.3 && <0.5+ , manifolds >=0.4.5 && <0.6 , constrained-categories- , linearmap-category+ , linearmap-category >=0.3.5 , linear , vector-space , semigroups+ , lens+ , call-stack , colour > 2 && < 3 , JuicyPixels >= 3.1 && < 3.4 hs-source-dirs: src
src/Data/Colour/Manifold.hs view
@@ -4,8 +4,20 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UnicodeSyntax #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE Rank2Types #-} -module Data.Colour.Manifold (Colour, QuantisedColour(..)) where+module Data.Colour.Manifold (+ -- * Full colour space+ Colour, QuantisedColour(..)+ -- * 2D/1D projected colour space+ , ColourMap, planarColourMap, colourCurve, colourMapPlane, spectralSwing+ , ColourPlane, cpCold, cpNeutral, cpHot, spanColourPlane + -- * Mapping data to colours+ , ColourMappable(..)+ -- * Predefined colour maps+ , SimpleColourMap, blackBlueYellowRed, brightVsRed, redVsBlue+ ) where import Data.Functor (($>)) import Control.Applicative (empty)@@ -20,6 +32,7 @@ import Data.VectorSpace import Data.AffineSpace import Data.AdditiveGroup+import Data.Manifold.Shade (Shade(..), Shade'(..), rangeWithinVertices) import Data.Colour.SRGB (toSRGB, toSRGB24) import Data.Colour.SRGB.Linear@@ -27,6 +40,7 @@ import Data.Colour.Names import Math.LinearMap.Category+import Linear.V2 import Linear.V3 import qualified Prelude as Hask@@ -36,7 +50,11 @@ import Data.Coerce import Data.Type.Coercion+import Data.CallStack +import Control.Lens++ newtype ColourNeedle = ColourNeedle { getRGBNeedle :: RGB ℝ } deriving (Eq, Show) asV3Needle :: ColourNeedle -+> V3 ℝ@@ -276,3 +294,107 @@ quantiseColour c = PixelRGB8 r g b where RGB r g b = toSRGB24 c ++-- | A two-dimensional, smoothly varying colour palette.+data ColourMap x = ColourMap {+ _cmPlane :: ColourPlane+ , _cmSpectSwing :: ℝ+ }++planarColourMap :: ColourPlane -> ColourMap x+planarColourMap = (`ColourMap`0)++colourCurve :: ColourPlane -> ℝ -> ColourMap ℝ+colourCurve = ColourMap++spectralSwing :: (Needle x ~ ℝ) => Traversal' (ColourMap x) ℝ+spectralSwing = lens _cmSpectSwing (\cm sw' -> cm{_cmSpectSwing = sw'})++colourMapPlane :: Traversal' (ColourMap x) ColourPlane+colourMapPlane = lens _cmPlane (\cm pl' -> cm{_cmPlane = pl'})++data ColourPlane = ColourPlane {+ _cpCold :: Colour ℝ+ , _cpNeutral :: Interior (Colour ℝ)+ , _cpHot :: Colour ℝ+ }+makeLenses ''ColourPlane++spanColourPlane :: Interior (Colour ℝ) -- ^ Neutral colour+ -> (Colour ℝ, Colour ℝ) -- ^ Extreme “cold” / “hot” colours+ -> ColourPlane+spanColourPlane neutral (cold,hot) = ColourPlane cold neutral hot++class Geodesic x => ColourMappable x where+ type ColourMapped x :: *+ type MappingVertex x :: *+ mapToColourWith :: HasCallStack+ => ColourMap (MappingVertex x)+ -> Interior (MappingVertex x)+ -> (MappingVertex x, MappingVertex x)+ -> x+ -> ColourMapped x++instance ColourMappable ℝ where+ type ColourMapped ℝ = Colour ℝ+ type MappingVertex ℝ = ℝ+ mapToColourWith (ColourMap (ColourPlane coldC neutralC hotC) swing)+ neutralP (coldP, hotP)+ = (\(Shade c _) -> fromInterior c)+ . shFn+ . \x -> let φ = 2*(x-neutralP)/(hotP-coldP)+ in Shade ( (1 - φ)/2 + (φ^2 - 1)*exp swing/2+ , (φ + 1)/2 + (φ^2 - 1)*exp swing/2 )+ (spanNorm [(256,0), (0,256)])+ :: Shade (ℝ,ℝ)+ where Just shFn = rangeWithinVertices ((0,0), neutralC)+ [((1,0), coldC), ((0,1), hotC)]++instance ColourMappable (ℝ,ℝ) where+ type ColourMapped (ℝ,ℝ) = Colour ℝ+ type MappingVertex (ℝ,ℝ) = (ℝ,ℝ)+ mapToColourWith (ColourMap cp swing)+ (xN,yN) ((xCold,yCold), (xHot,yHot))+ = mapToColourWith (ColourMap cp swing) (V2 xN yN) (V2 xCold yCold, V2 xHot yHot)+ . \(x,y) -> (V2 x y)++instance ColourMappable ℝ² where+ type ColourMapped ℝ² = Colour ℝ+ type MappingVertex ℝ² = ℝ²+ mapToColourWith (ColourMap (ColourPlane coldC neutralC hotC) swing)+ neutralP (coldP, hotP)+ = (\(Shade c _) -> fromInterior c)+ . shFn+ . \xy -> Shade xy quantisationNorm+ where Just shFn = rangeWithinVertices (neutralP, neutralC)+ [(coldP, coldC), (hotP, hotC)]+ quantisationNorm = scaleNorm 256 . dualNorm+ $ spanVariance [coldP^-^neutralP, hotP^-^neutralP]+++class ColourMappable x => HasSimpleColourMaps x where+ simpleColourMap :: ColourPlane -> ℝ -> ColourMap x+ simpleColourMap = const . planarColourMap++instance HasSimpleColourMaps ℝ where+ simpleColourMap = colourCurve++instance HasSimpleColourMaps (ℝ,ℝ)+instance HasSimpleColourMaps ℝ²++type SimpleColourMap = ∀ x . HasSimpleColourMaps x => ColourMap x++blackBlueYellowRed :: SimpleColourMap+blackBlueYellowRed+ = simpleColourMap (spanColourPlane neutralc (darkblue,goldenrod)) 1+ where Just neutralc = toInterior (dimgrey :: Colour ℝ)++redVsBlue :: SimpleColourMap+redVsBlue+ = simpleColourMap (spanColourPlane neutralc (rgb 0.9 0 0.2, rgb 0.1 0.3 1)) (-1/2)+ where neutralc = ColourNeedle $ RGB (-1.2) (-0.5) (-1.5)++brightVsRed :: SimpleColourMap+brightVsRed+ = simpleColourMap (spanColourPlane neutralc (white, orangered)) 1+ where Just neutralc = toInterior (darkgrey :: Colour ℝ)