{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE UndecidableInstances  #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE UnicodeSyntax         #-}
{-# LANGUAGE InstanceSigs          #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE Rank2Types            #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DeriveAnyClass        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE EmptyCase             #-}
{-# LANGUAGE CPP                   #-}

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.Colour.Manifold.Internal

import Data.Functor (($>))
import Control.Applicative (empty)
import Control.Applicative.Constrained
import Control.Arrow.Constrained
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
                           )
#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

import Math.LinearMap.Category
#if MIN_VERSION_linearmap_category(0,5,0)
import Math.LinearMap.Coercion
#endif
#if MIN_VERSION_linearmap_category(0,6,0)
import Math.VectorSpace.DimensionAware
#endif
import Linear.V2
import Linear.V3

import qualified Prelude as Hask
import Control.Category.Constrained.Prelude

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 :: Gen ColourNeedle
arbitrary = RGB ℝ -> ColourNeedle
ColourNeedle forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> (
                   forall a. a -> a -> a -> RGB a
RGB forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall a. Arbitrary a => Gen a
QC.arbitrary forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Applicative f r t, ObjectMorphism r a b,
 ObjectMorphism t (f a) (f b), Object t (t (f a) (f b)),
 ObjectPair r (r a b) a, ObjectPair t (f (r a b)) (f a), Object r a,
 Object r b) =>
t (f (r a b)) (t (f a) (f b))
<*> forall a. Arbitrary a => Gen a
QC.arbitrary forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Applicative f r t, ObjectMorphism r a b,
 ObjectMorphism t (f a) (f b), Object t (t (f a) (f b)),
 ObjectPair r (r a b) a, ObjectPair t (f (r a b)) (f a), Object r a,
 Object r b) =>
t (f (r a b)) (t (f a) (f b))
<*> forall a. Arbitrary a => Gen a
QC.arbitrary )


asV3Tensor :: (ColourNeedle⊗w) -+> (V3 ℝ⊗w)
asV3Tensor :: forall w. (ColourNeedle ⊗ w) -+> (V3 ℝ ⊗ w)
asV3Tensor = forall s v w. (v -> w) -> LinearFunction s v w
LinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \(Tensor (RGB w
r w
g w
b)) -> forall s v w. TensorProduct v w -> Tensor s v w
Tensor forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> V3 a
V3 w
r w
g w
b

fromV3Tensor :: (V3 ℝ⊗w) -+> (ColourNeedle⊗w)
fromV3Tensor :: forall w. (V3 ℝ ⊗ w) -+> (ColourNeedle ⊗ w)
fromV3Tensor = forall s v w. (v -> w) -> LinearFunction s v w
LinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \(Tensor (V3 w
r w
g w
b)) -> forall s v w. TensorProduct v w -> Tensor s v w
Tensor forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB w
r w
g w
b

fromV3LinMap :: (V3 ℝ+>w) -+> (ColourNeedle+>w)
fromV3LinMap :: forall w. (V3 ℝ +> w) -+> (ColourNeedle +> w)
fromV3LinMap = forall s v w. (v -> w) -> LinearFunction s v w
LinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \(LinearMap (V3 w
r w
g w
b)) -> forall s v w. TensorProduct (DualVector v) w -> LinearMap s v w
LinearMap forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB w
r w
g w
b

withRGBNeedle :: (RGB Double -> RGB Double) -> ColourNeedle -> ColourNeedle
withRGBNeedle :: (RGB ℝ -> RGB ℝ) -> ColourNeedle -> ColourNeedle
withRGBNeedle RGB ℝ -> RGB ℝ
f (ColourNeedle RGB ℝ
q) = RGB ℝ -> ColourNeedle
ColourNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ RGB ℝ -> RGB ℝ
f RGB ℝ
q

instance AdditiveGroup ColourNeedle where
  zeroV :: ColourNeedle
zeroV = RGB ℝ -> ColourNeedle
ColourNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB ℝ
0 ℝ
0 ℝ
0
  negateV :: ColourNeedle -> ColourNeedle
negateV = (RGB ℝ -> RGB ℝ) -> ColourNeedle -> ColourNeedle
withRGBNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap forall a. Num a => a -> a
negate
  ColourNeedle RGB ℝ
q ^+^ :: ColourNeedle -> ColourNeedle -> ColourNeedle
^+^ ColourNeedle RGB ℝ
s = RGB ℝ -> ColourNeedle
ColourNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) c b a.
(Applicative f r t, Object r c, ObjectMorphism r b c,
 Object t (f c), ObjectMorphism t (f b) (f c), ObjectPair r a b,
 ObjectPair t (f a) (f b)) =>
r a (r b c) -> t (f a) (t (f b) (f c))
liftA2 forall a. Num a => a -> a -> a
(+) RGB ℝ
q RGB ℝ
s
instance VectorSpace ColourNeedle where
  type Scalar ColourNeedle = ℝ
  *^ :: Scalar ColourNeedle -> ColourNeedle -> ColourNeedle
(*^)Scalar ColourNeedle
μ = (RGB ℝ -> RGB ℝ) -> ColourNeedle -> ColourNeedle
withRGBNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (Scalar ColourNeedle
μforall a. Num a => a -> a -> a
*)

#if MIN_VERSION_linearmap_category(0,6,0)
instance DimensionAware ColourNeedle where
  type StaticDimension ColourNeedle = 'Just 3
  dimensionalityWitness = IsStaticDimensional
instance 3`Dimensional`ColourNeedle where
  unsafeFromArrayWithOffset
     i = unsafeFromArrayWithOffset i >>> \(V3 r g b) -> ColourNeedle (RGB r g b)
  unsafeWriteArrayWithOffset ar i (ColourNeedle (RGB r g b))
     = unsafeWriteArrayWithOffset ar i $ V3 r g b
#endif
  

instance TensorSpace ColourNeedle where
  type TensorProduct ColourNeedle w = RGB w
  scalarSpaceWitness :: ScalarSpaceWitness ColourNeedle
scalarSpaceWitness = forall v.
(Num' (Scalar v), Scalar (Scalar v) ~ Scalar v) =>
ScalarSpaceWitness v
ScalarSpaceWitness
  linearManifoldWitness :: LinearManifoldWitness ColourNeedle
linearManifoldWitness = forall v.
(Needle v ~ v, AffineSpace v, Diff v ~ v) =>
LinearManifoldWitness v
LinearManifoldWitness
#if !MIN_VERSION_manifolds(0,6,0)
        BoundarylessWitness
#endif
  zeroTensor :: forall w.
(TensorSpace w, Scalar w ~ Scalar ColourNeedle) =>
ColourNeedle ⊗ w
zeroTensor = forall s v w. TensorProduct v w -> Tensor s v w
Tensor (forall a. a -> a -> a -> RGB a
RGB forall v. AdditiveGroup v => v
zeroV forall v. AdditiveGroup v => v
zeroV forall v. AdditiveGroup v => v
zeroV)
  toFlatTensor :: ColourNeedle -+> (ColourNeedle ⊗ Scalar ColourNeedle)
toFlatTensor = forall s v w. (v -> w) -> LinearFunction s v w
LinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \(ColourNeedle (RGB ℝ
r ℝ
g ℝ
b)) -> forall s v w. TensorProduct v w -> Tensor s v w
Tensor (forall a. a -> a -> a -> RGB a
RGB ℝ
r ℝ
g ℝ
b)
  fromFlatTensor :: (ColourNeedle ⊗ Scalar ColourNeedle) -+> ColourNeedle
fromFlatTensor = forall s v w. (v -> w) -> LinearFunction s v w
LinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \(Tensor (RGB ℝ
r ℝ
g ℝ
b)) -> RGB ℝ -> ColourNeedle
ColourNeedle (forall a. a -> a -> a -> RGB a
RGB ℝ
r ℝ
g ℝ
b)
  addTensors :: forall w.
(TensorSpace w, Scalar w ~ Scalar ColourNeedle) =>
(ColourNeedle ⊗ w) -> (ColourNeedle ⊗ w) -> ColourNeedle ⊗ w
addTensors (Tensor (RGB w
r w
g w
b)) (Tensor (RGB w
r' w
g' w
b'))
                = forall s v w. TensorProduct v w -> Tensor s v w
Tensor forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB (w
rforall v. AdditiveGroup v => v -> v -> v
^+^w
r') (w
gforall v. AdditiveGroup v => v -> v -> v
^+^w
g') (w
bforall v. AdditiveGroup v => v -> v -> v
^+^w
b')
  subtractTensors :: forall w.
(TensorSpace ColourNeedle, TensorSpace w,
 Scalar w ~ Scalar ColourNeedle) =>
(ColourNeedle ⊗ w) -> (ColourNeedle ⊗ w) -> ColourNeedle ⊗ w
subtractTensors (Tensor (RGB w
r w
g w
b)) (Tensor (RGB w
r' w
g' w
b'))
                = forall s v w. TensorProduct v w -> Tensor s v w
Tensor forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB (w
rforall v. AdditiveGroup v => v -> v -> v
^-^w
r') (w
gforall v. AdditiveGroup v => v -> v -> v
^-^w
g') (w
bforall v. AdditiveGroup v => v -> v -> v
^-^w
b')
  negateTensor :: forall w.
(TensorSpace w, Scalar w ~ Scalar ColourNeedle) =>
(ColourNeedle ⊗ w) -+> (ColourNeedle ⊗ w)
negateTensor = forall s v w. (v -> w) -> LinearFunction s v w
LinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \(Tensor (RGB w
r w
g w
b))
                       -> forall s v w. TensorProduct v w -> Tensor s v w
Tensor (forall a. a -> a -> a -> RGB a
RGB (forall v. AdditiveGroup v => v -> v
negateV w
r) (forall v. AdditiveGroup v => v -> v
negateV w
g) (forall v. AdditiveGroup v => v -> v
negateV w
b))
  scaleTensor :: forall w.
(TensorSpace w, Scalar w ~ Scalar ColourNeedle) =>
Bilinear
  (Scalar ColourNeedle) (ColourNeedle ⊗ w) (ColourNeedle ⊗ w)
scaleTensor = forall v w y. (v -> w -> y) -> Bilinear v w y
bilinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \ℝ
μ (Tensor (RGB w
r w
g w
b))
                       -> forall s v w. TensorProduct v w -> Tensor s v w
Tensor (forall a. a -> a -> a -> RGB a
RGB (ℝ
μforall v. VectorSpace v => Scalar v -> v -> v
*^w
r) (ℝ
μforall v. VectorSpace v => Scalar v -> v -> v
*^w
g) (ℝ
μforall v. VectorSpace v => Scalar v -> v -> v
*^w
b))
  tensorProduct :: forall w.
(TensorSpace w, Scalar w ~ Scalar ColourNeedle) =>
Bilinear ColourNeedle w (ColourNeedle ⊗ w)
tensorProduct = forall v w y. (v -> w -> y) -> Bilinear v w y
bilinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \(ColourNeedle (RGB ℝ
r ℝ
g ℝ
b)) w
w
                       -> forall s v w. TensorProduct v w -> Tensor s v w
Tensor (forall a. a -> a -> a -> RGB a
RGB (ℝ
rforall v. VectorSpace v => Scalar v -> v -> v
*^w
w) (ℝ
gforall v. VectorSpace v => Scalar v -> v -> v
*^w
w) (ℝ
bforall v. VectorSpace v => Scalar v -> v -> v
*^w
w))
  transposeTensor :: forall w.
(TensorSpace w, Scalar w ~ Scalar ColourNeedle) =>
(ColourNeedle ⊗ w) -+> (w ⊗ ColourNeedle)
transposeTensor = (forall s v w. LinearFunction s v w -> v -> w
getLinearFunction forall v w x.
(TensorSpace v, TensorSpace w, TensorSpace x, Scalar w ~ Scalar v,
 Scalar x ~ Scalar v) =>
Bilinear (w -+> x) (v ⊗ w) (v ⊗ x)
fmapTensor V3 ℝ -+> ColourNeedle
fromV3Needle)
                      forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall v w.
(TensorSpace v, TensorSpace w, Scalar w ~ Scalar v) =>
(v ⊗ w) -+> (w ⊗ v)
transposeTensor forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall w. (ColourNeedle ⊗ w) -+> (V3 ℝ ⊗ w)
asV3Tensor
  fmapTensor :: forall w x.
(TensorSpace w, TensorSpace x, Scalar w ~ Scalar ColourNeedle,
 Scalar x ~ Scalar ColourNeedle) =>
Bilinear (w -+> x) (ColourNeedle ⊗ w) (ColourNeedle ⊗ x)
fmapTensor = forall v w y. (v -> w -> y) -> Bilinear v w y
bilinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \LinearFunction ℝ w x
f (Tensor (RGB w
r w
g w
b))
                   -> forall s v w. TensorProduct v w -> Tensor s v w
Tensor forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB (LinearFunction ℝ w x
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ w
r) (LinearFunction ℝ w x
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ w
g) (LinearFunction ℝ w x
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ w
b)
  fzipTensorWith :: forall u w x.
(TensorSpace u, TensorSpace w, TensorSpace x,
 Scalar u ~ Scalar ColourNeedle, Scalar w ~ Scalar ColourNeedle,
 Scalar x ~ Scalar ColourNeedle) =>
Bilinear
  ((w, x) -+> u)
  (ColourNeedle ⊗ w, ColourNeedle ⊗ x)
  (ColourNeedle ⊗ u)
fzipTensorWith = forall v w y. (v -> w -> y) -> Bilinear v w y
bilinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \LinearFunction ℝ (w, x) u
f (Tensor (RGB w
r w
g w
b), Tensor (RGB x
r' x
g' x
b'))
                   -> forall s v w. TensorProduct v w -> Tensor s v w
Tensor forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB (LinearFunction ℝ (w, x) u
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (w
r,x
r')) (LinearFunction ℝ (w, x) u
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (w
g,x
g')) (LinearFunction ℝ (w, x) u
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (w
b,x
b'))
#if MIN_VERSION_linearmap_category(0,6,0)
  coerceFmapTensorProduct _ VSCCoercion = Coercion
#elif MIN_VERSION_linearmap_category(0,5,0)
  coerceFmapTensorProduct :: forall (p :: * -> *) a b.
Functor p =>
p ColourNeedle
-> VSCCoercion a b
-> VSCCoercion
     (TensorProduct ColourNeedle a) (TensorProduct ColourNeedle b)
coerceFmapTensorProduct p ColourNeedle
_ VSCCoercion a b
VSCCoercion = forall a b. Coercible a b => VSCCoercion a b
VSCCoercion
#else
  coerceFmapTensorProduct _ Coercion = Coercion
#endif
  wellDefinedTensor :: forall w.
(TensorSpace w, Scalar w ~ Scalar ColourNeedle) =>
(ColourNeedle ⊗ w) -> Maybe (ColourNeedle ⊗ w)
wellDefinedTensor t :: ColourNeedle ⊗ w
t@(Tensor (RGB w
r w
g w
b))
    = forall v. TensorSpace v => v -> Maybe v
wellDefinedVector w
r forall (k :: * -> * -> *) (m :: * -> *) b a.
(WellPointed k, Monad m k, ObjectPair k b (UnitObject k),
 ObjectPair k (m b) (UnitObject k),
 ObjectPair k (UnitObject k) (m b), ObjectPair k b a,
 ObjectPair k a b, Object k (m (a, b)), ObjectPair k (m a) (m b),
 ObjectPoint k (m a)) =>
m a -> k (m b) (m b)
>> forall v. TensorSpace v => v -> Maybe v
wellDefinedVector w
g forall (k :: * -> * -> *) (m :: * -> *) b a.
(WellPointed k, Monad m k, ObjectPair k b (UnitObject k),
 ObjectPair k (m b) (UnitObject k),
 ObjectPair k (UnitObject k) (m b), ObjectPair k b a,
 ObjectPair k a b, Object k (m (a, b)), ObjectPair k (m a) (m b),
 ObjectPoint k (m a)) =>
m a -> k (m b) (m b)
>> forall v. TensorSpace v => v -> Maybe v
wellDefinedVector w
b forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ColourNeedle ⊗ w
t
#if MIN_VERSION_linearmap_category(0,6,0)
  tensorUnsafeFromArrayWithOffset i
    = arr fromV3Tensor . tensorUnsafeFromArrayWithOffset i
  tensorUnsafeWriteArrayWithOffset ar i
    = tensorUnsafeWriteArrayWithOffset ar i . arr asV3Tensor
#endif

instance LinearSpace ColourNeedle where
  type DualVector ColourNeedle = ColourNeedle
  linearId :: ColourNeedle +> ColourNeedle
linearId = forall s v w. TensorProduct (DualVector v) w -> LinearMap s v w
LinearMap forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB (RGB ℝ -> ColourNeedle
ColourNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB ℝ
1 ℝ
0 ℝ
0)
                             (RGB ℝ -> ColourNeedle
ColourNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB ℝ
0 ℝ
1 ℝ
0)
                             (RGB ℝ -> ColourNeedle
ColourNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB ℝ
0 ℝ
0 ℝ
1)
  tensorId :: forall w.
(LinearSpace w, Scalar w ~ Scalar ColourNeedle) =>
(ColourNeedle ⊗ w) +> (ColourNeedle ⊗ w)
tensorId = forall w.
(LinearSpace w, Scalar w ~ ℝ) =>
DualSpaceWitness w
-> Tensor ℝ ColourNeedle w +> Tensor ℝ ColourNeedle w
ti forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness
   where ti :: ∀ w . (LinearSpace w, Scalar w ~ ℝ)
               => DualSpaceWitness w
                 -> Tensor ℝ ColourNeedle w+>Tensor ℝ ColourNeedle w
         ti :: forall w.
(LinearSpace w, Scalar w ~ ℝ) =>
DualSpaceWitness w
-> Tensor ℝ ColourNeedle w +> Tensor ℝ ColourNeedle w
ti DualSpaceWitness w
DualSpaceWitness
           = let wid :: Tensor ℝ (DualVector w) w
wid = forall s u v w.
(LinearSpace u, Scalar u ~ s) =>
LinearMap s u w -> Tensor s (DualVector u) w
asTensor forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id :: Tensor ℝ (DualVector w) w
             in forall s v w. TensorProduct (DualVector v) w -> LinearMap s v w
LinearMap forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB
                  (forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall s v w. (v -> w) -> LinearFunction s v w
LinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \w
w -> forall s v w. TensorProduct v w -> Tensor s v w
Tensor forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB w
w forall v. AdditiveGroup v => v
zeroV forall v. AdditiveGroup v => v
zeroV) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Tensor ℝ (DualVector w) w
wid)
                  (forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall s v w. (v -> w) -> LinearFunction s v w
LinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \w
w -> forall s v w. TensorProduct v w -> Tensor s v w
Tensor forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB forall v. AdditiveGroup v => v
zeroV w
w forall v. AdditiveGroup v => v
zeroV) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Tensor ℝ (DualVector w) w
wid)
                  (forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall s v w. (v -> w) -> LinearFunction s v w
LinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \w
w -> forall s v w. TensorProduct v w -> Tensor s v w
Tensor forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB forall v. AdditiveGroup v => v
zeroV forall v. AdditiveGroup v => v
zeroV w
w) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Tensor ℝ (DualVector w) w
wid)
#if MIN_VERSION_linearmap_category(0,5,0)
  coerceDoubleDual :: VSCCoercion ColourNeedle (DualVector (DualVector ColourNeedle))
coerceDoubleDual = forall a b. Coercible a b => VSCCoercion a b
VSCCoercion
#else
  coerceDoubleDual = Coercion
#endif
  dualSpaceWitness :: DualSpaceWitness ColourNeedle
dualSpaceWitness = forall v.
(LinearSpace (Scalar v), DualVector (Scalar v) ~ Scalar v,
 LinearSpace (DualVector v), Scalar (DualVector v) ~ Scalar v,
 DualVector (DualVector v) ~ v) =>
DualSpaceWitness v
DualSpaceWitness
  contractTensorMap :: forall w.
(TensorSpace w, Scalar w ~ Scalar ColourNeedle) =>
(ColourNeedle +> (ColourNeedle ⊗ w)) -+> w
contractTensorMap = forall s v w. (v -> w) -> LinearFunction s v w
LinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \(LinearMap (RGB (Tensor (RGB w
r w
_ w
_))
                                                        (Tensor (RGB w
_ w
g w
_))
                                                        (Tensor (RGB w
_ w
_ w
b))))
                        -> w
r forall v. AdditiveGroup v => v -> v -> v
^+^ w
g forall v. AdditiveGroup v => v -> v -> v
^+^ w
b
  contractMapTensor :: forall w.
(TensorSpace w, Scalar w ~ Scalar ColourNeedle) =>
(ColourNeedle ⊗ (ColourNeedle +> w)) -+> w
contractMapTensor = forall s v w. (v -> w) -> LinearFunction s v w
LinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \(Tensor (RGB (LinearMap (RGB w
r w
_ w
_))
                                                     (LinearMap (RGB w
_ w
g w
_))
                                                     (LinearMap (RGB w
_ w
_ w
b))))
                        -> w
r forall v. AdditiveGroup v => v -> v -> v
^+^ w
g forall v. AdditiveGroup v => v -> v -> v
^+^ w
b
  contractLinearMapAgainst :: forall w.
(LinearSpace w, Scalar w ~ Scalar ColourNeedle) =>
Bilinear
  (ColourNeedle +> w) (w -+> ColourNeedle) (Scalar ColourNeedle)
contractLinearMapAgainst = forall v w y. (v -> w -> y) -> Bilinear v w y
bilinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \(LinearMap (RGB w
r w
g w
b)) LinearFunction ℝ w ColourNeedle
f
                        -> forall a. RGB a -> a
channelRed (ColourNeedle -> RGB ℝ
getRGBNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ LinearFunction ℝ w ColourNeedle
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ w
r)
                         forall a. Num a => a -> a -> a
+ forall a. RGB a -> a
channelGreen (ColourNeedle -> RGB ℝ
getRGBNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ LinearFunction ℝ w ColourNeedle
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ w
g)
                         forall a. Num a => a -> a -> a
+ forall a. RGB a -> a
channelBlue (ColourNeedle -> RGB ℝ
getRGBNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ LinearFunction ℝ w ColourNeedle
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ w
b)
  applyDualVector :: LinearSpace ColourNeedle =>
Bilinear
  (DualVector ColourNeedle) ColourNeedle (Scalar ColourNeedle)
applyDualVector = forall v w y. (v -> w -> y) -> Bilinear v w y
bilinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$
         \(ColourNeedle (RGB ℝ
r' ℝ
g' ℝ
b')) (ColourNeedle (RGB ℝ
r ℝ
g ℝ
b))
            -> ℝ
r'forall a. Num a => a -> a -> a
*ℝ
r forall a. Num a => a -> a -> a
+ ℝ
g'forall a. Num a => a -> a -> a
*ℝ
g forall a. Num a => a -> a -> a
+ ℝ
b'forall a. Num a => a -> a -> a
*ℝ
b
  applyLinear :: forall w.
(TensorSpace w, Scalar w ~ Scalar ColourNeedle) =>
Bilinear (ColourNeedle +> w) ColourNeedle w
applyLinear = forall v w y. (v -> w -> y) -> Bilinear v w y
bilinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \(LinearMap (RGB w
r' w
g' w
b')) (ColourNeedle (RGB ℝ
r ℝ
g ℝ
b))
            -> w
r'forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^*ℝ
r forall v. AdditiveGroup v => v -> v -> v
^+^ w
g'forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^*ℝ
g forall v. AdditiveGroup v => v -> v -> v
^+^ w
b'forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^*ℝ
b
  applyTensorFunctional :: forall u.
(LinearSpace u, Scalar u ~ Scalar ColourNeedle) =>
Bilinear
  (DualVector (ColourNeedle ⊗ u))
  (ColourNeedle ⊗ u)
  (Scalar ColourNeedle)
applyTensorFunctional = forall v w y. (v -> w -> y) -> Bilinear v w y
bilinearFunction
            forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \(LinearMap (RGB DualVector u
r' DualVector u
g' DualVector u
b')) (Tensor (RGB u
r u
g u
b))
                   -> DualVector u
r'forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^u
r forall a. Num a => a -> a -> a
+ DualVector u
g'forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^u
g forall a. Num a => a -> a -> a
+ DualVector u
b'forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^u
b
  applyTensorLinMap :: ∀ u w . ( LinearSpace u, Scalar u ~ ℝ
                               , TensorSpace w, Scalar w ~ ℝ )
    => LinearFunction ℝ (LinearMap ℝ (Tensor ℝ ColourNeedle u) w)
                        (LinearFunction ℝ (Tensor ℝ ColourNeedle u) w)
  applyTensorLinMap :: forall u w.
(LinearSpace u, Scalar u ~ ℝ, TensorSpace w, Scalar w ~ ℝ) =>
LinearFunction
  ℝ
  (LinearMap ℝ (Tensor ℝ ColourNeedle u) w)
  (LinearFunction ℝ (Tensor ℝ ColourNeedle u) w)
applyTensorLinMap = case forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness @u of
    DualSpaceWitness u
DualSpaceWitness -> forall v w y. (v -> w -> y) -> Bilinear v w y
bilinearFunction
            forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \(LinearMap (RGB Tensor ℝ (DualVector u) w
r' Tensor ℝ (DualVector u) w
g' Tensor ℝ (DualVector u) w
b')) (Tensor (RGB u
r u
g u
b))
                -> (Tensor ℝ (DualVector u) w
r'forall {w} {v}.
(Scalar w ~ Scalar v, LinearSpace v, TensorSpace w) =>
Tensor (Scalar v) (DualVector v) w -> v -> w
+$u
r) forall v. AdditiveGroup v => v -> v -> v
^+^ (Tensor ℝ (DualVector u) w
g'forall {w} {v}.
(Scalar w ~ Scalar v, LinearSpace v, TensorSpace w) =>
Tensor (Scalar v) (DualVector v) w -> v -> w
+$u
g) forall v. AdditiveGroup v => v -> v -> v
^+^ (Tensor ℝ (DualVector u) w
b'forall {w} {v}.
(Scalar w ~ Scalar v, LinearSpace v, TensorSpace w) =>
Tensor (Scalar v) (DualVector v) w -> v -> w
+$u
b)
   where Tensor (Scalar v) (DualVector v) w
f+$ :: Tensor (Scalar v) (DualVector v) w -> v -> w
+$v
x = forall s v w. LinearFunction s v w -> v -> w
getLinearFunction (forall s v w. LinearFunction s v w -> v -> w
getLinearFunction forall v w.
(LinearSpace v, TensorSpace w, Scalar w ~ Scalar v) =>
Bilinear (v +> w) v w
applyLinear forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall s u v w.
(LinearSpace u, Scalar u ~ s) =>
Tensor s (DualVector u) w -> LinearMap s u w
fromTensor forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Tensor (Scalar v) (DualVector v) w
f) v
x
  composeLinear :: forall w x.
(LinearSpace w, TensorSpace x, Scalar w ~ Scalar ColourNeedle,
 Scalar x ~ Scalar ColourNeedle) =>
Bilinear (w +> x) (ColourNeedle +> w) (ColourNeedle +> x)
composeLinear = forall v w y. (v -> w -> y) -> Bilinear v w y
bilinearFunction forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \LinearMap ℝ w x
f (LinearMap (RGB w
r' w
g' w
b'))
            -> forall s v w. TensorProduct (DualVector v) w -> LinearMap s v w
LinearMap forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB (LinearMap ℝ w x
f forall {w} {v}.
(Scalar w ~ Scalar v, LinearSpace v, TensorSpace w) =>
LinearMap (Scalar v) v w -> v -> w
+$ w
r') (LinearMap ℝ w x
f forall {w} {v}.
(Scalar w ~ Scalar v, LinearSpace v, TensorSpace w) =>
LinearMap (Scalar v) v w -> v -> w
+$ w
g') (LinearMap ℝ w x
f forall {w} {v}.
(Scalar w ~ Scalar v, LinearSpace v, TensorSpace w) =>
LinearMap (Scalar v) v w -> v -> w
+$ w
b')
   where LinearMap (Scalar v) v w
f+$ :: LinearMap (Scalar v) v w -> v -> w
+$v
x = forall s v w. LinearFunction s v w -> v -> w
getLinearFunction (forall s v w. LinearFunction s v w -> v -> w
getLinearFunction forall v w.
(LinearSpace v, TensorSpace w, Scalar w ~ Scalar v) =>
Bilinear (v +> w) v w
applyLinear LinearMap (Scalar v) v w
f) v
x
  useTupleLinearSpaceComponents :: forall x y φ.
(ColourNeedle ~ (x, y)) =>
((LinearSpace x, LinearSpace y, Scalar x ~ Scalar y) => φ) -> φ
useTupleLinearSpaceComponents (LinearSpace x, LinearSpace y, Scalar x ~ Scalar y) => φ
_ = forall a. HasCallStack => a
undefined

instance SemiInner ColourNeedle where
  dualBasisCandidates :: [(Int, ColourNeedle)] -> Forest (Int, DualVector ColourNeedle)
dualBasisCandidates = forall v.
[DualVector v]
-> (v -> [ℝ]) -> [(Int, v)] -> Forest (Int, DualVector v)
cartesianDualBasisCandidates
           [RGB ℝ -> ColourNeedle
ColourNeedle (forall a. a -> a -> a -> RGB a
RGB ℝ
1 ℝ
0 ℝ
0), RGB ℝ -> ColourNeedle
ColourNeedle (forall a. a -> a -> a -> RGB a
RGB ℝ
0 ℝ
1 ℝ
0), RGB ℝ -> ColourNeedle
ColourNeedle (forall a. a -> a -> a -> RGB a
RGB ℝ
0 ℝ
0 ℝ
1)]
           (\(ColourNeedle (RGB ℝ
r ℝ
g ℝ
b)) -> forall a. Num a => a -> a
abs forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> [ℝ
r,ℝ
g,ℝ
b])
  tensorDualBasisCandidates :: forall w.
(SemiInner w, Scalar w ~ Scalar ColourNeedle) =>
[(Int, ColourNeedle ⊗ w)]
-> Forest (Int, DualVector (ColourNeedle ⊗ w))
tensorDualBasisCandidates = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) d b c.
(Morphism a, ObjectPair a d b, ObjectPair a d c) =>
a b c -> a (d, b) (d, c)
second forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall s v w. LinearFunction s v w -> v -> w
getLinearFunction forall w. (ColourNeedle ⊗ w) -+> (V3 ℝ ⊗ w)
asV3Tensor)
                           forall (k :: * -> * -> *) a b c.
(Category k, Object k a, Object k b, Object k c) =>
k a b -> k b c -> k a c
>>> forall v w.
(SemiInner v, SemiInner w, Scalar w ~ Scalar v) =>
[(Int, v ⊗ w)] -> Forest (Int, DualVector (v ⊗ w))
tensorDualBasisCandidates
                           forall (k :: * -> * -> *) a b c.
(Category k, Object k a, Object k b, Object k c) =>
k a b -> k b c -> k a c
>>> forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (a :: * -> * -> *) d b c.
(Morphism a, ObjectPair a d b, ObjectPair a d c) =>
a b c -> a (d, b) (d, c)
second forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall s v w. LinearFunction s v w -> v -> w
getLinearFunction forall w. (V3 ℝ +> w) -+> (ColourNeedle +> w)
fromV3LinMap)

instance FiniteDimensional ColourNeedle where
  data SubBasis ColourNeedle = ColourNeedleBasis
  entireBasis :: SubBasis ColourNeedle
entireBasis = SubBasis ColourNeedle
ColourNeedleBasis
  enumerateSubBasis :: SubBasis ColourNeedle -> [ColourNeedle]
enumerateSubBasis SubBasis ColourNeedle
R:SubBasisColourNeedle
ColourNeedleBasis
          = RGB ℝ -> ColourNeedle
ColourNeedle forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> [forall a. a -> a -> a -> RGB a
RGB ℝ
1 ℝ
0 ℝ
0, forall a. a -> a -> a -> RGB a
RGB ℝ
0 ℝ
1 ℝ
0, forall a. a -> a -> a -> RGB a
RGB ℝ
0 ℝ
0 ℝ
1]
  decomposeLinMap :: forall w.
(LSpace w, Scalar w ~ Scalar ColourNeedle) =>
(ColourNeedle +> w) -> (SubBasis ColourNeedle, DList w)
decomposeLinMap (LinearMap (RGB w
r w
g w
b)) = (SubBasis ColourNeedle
ColourNeedleBasis, ([w
r,w
g,w
b]forall a. [a] -> [a] -> [a]
++))
  decomposeLinMapWithin :: forall w.
(LSpace w, Scalar w ~ Scalar ColourNeedle) =>
SubBasis ColourNeedle
-> (ColourNeedle +> w)
-> Either (SubBasis ColourNeedle, DList w) (DList w)
decomposeLinMapWithin SubBasis ColourNeedle
R:SubBasisColourNeedle
ColourNeedleBasis (LinearMap (RGB w
r w
g w
b)) = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure ([w
r,w
g,w
b]forall a. [a] -> [a] -> [a]
++)
  recomposeSB :: SubBasis ColourNeedle
-> [Scalar ColourNeedle] -> (ColourNeedle, [Scalar ColourNeedle])
recomposeSB SubBasis ColourNeedle
R:SubBasisColourNeedle
ColourNeedleBasis [] = (RGB ℝ -> ColourNeedle
ColourNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB ℝ
0 ℝ
0 ℝ
0, [])
  recomposeSB SubBasis ColourNeedle
R:SubBasisColourNeedle
ColourNeedleBasis [Scalar ColourNeedle
r] = (RGB ℝ -> ColourNeedle
ColourNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB Scalar ColourNeedle
r ℝ
0 ℝ
0, [])
  recomposeSB SubBasis ColourNeedle
R:SubBasisColourNeedle
ColourNeedleBasis [Scalar ColourNeedle
r,Scalar ColourNeedle
g] = (RGB ℝ -> ColourNeedle
ColourNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB Scalar ColourNeedle
r Scalar ColourNeedle
g ℝ
0, [])
  recomposeSB SubBasis ColourNeedle
R:SubBasisColourNeedle
ColourNeedleBasis (Scalar ColourNeedle
r:Scalar ColourNeedle
g:Scalar ColourNeedle
b:[Scalar ColourNeedle]
l) = (RGB ℝ -> ColourNeedle
ColourNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB Scalar ColourNeedle
r Scalar ColourNeedle
g Scalar ColourNeedle
b, [Scalar ColourNeedle]
l)
  recomposeSBTensor :: forall w.
(FiniteDimensional w, Scalar w ~ Scalar ColourNeedle) =>
SubBasis ColourNeedle
-> SubBasis w
-> [Scalar ColourNeedle]
-> (ColourNeedle ⊗ w, [Scalar ColourNeedle])
recomposeSBTensor SubBasis ColourNeedle
R:SubBasisColourNeedle
ColourNeedleBasis SubBasis w
sbw [Scalar ColourNeedle]
l
          = let (w
r,[Scalar w]
l') = forall v.
FiniteDimensional v =>
SubBasis v -> [Scalar v] -> (v, [Scalar v])
recomposeSB SubBasis w
sbw [Scalar ColourNeedle]
l
                (w
g,[Scalar w]
l'') = forall v.
FiniteDimensional v =>
SubBasis v -> [Scalar v] -> (v, [Scalar v])
recomposeSB SubBasis w
sbw [Scalar w]
l'
                (w
b,[Scalar w]
l''') = forall v.
FiniteDimensional v =>
SubBasis v -> [Scalar v] -> (v, [Scalar v])
recomposeSB SubBasis w
sbw [Scalar w]
l''
            in (forall s v w. TensorProduct v w -> Tensor s v w
Tensor forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB w
r w
g w
b, [Scalar w]
l''')
  recomposeLinMap :: forall w.
(LSpace w, Scalar w ~ Scalar ColourNeedle) =>
SubBasis ColourNeedle -> [w] -> (ColourNeedle +> w, [w])
recomposeLinMap SubBasis ColourNeedle
R:SubBasisColourNeedle
ColourNeedleBasis [] = (forall s v w. TensorProduct (DualVector v) w -> LinearMap s v w
LinearMap forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB forall v. AdditiveGroup v => v
zeroV forall v. AdditiveGroup v => v
zeroV forall v. AdditiveGroup v => v
zeroV, [])
  recomposeLinMap SubBasis ColourNeedle
R:SubBasisColourNeedle
ColourNeedleBasis [w
r] = (forall s v w. TensorProduct (DualVector v) w -> LinearMap s v w
LinearMap forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB w
r forall v. AdditiveGroup v => v
zeroV forall v. AdditiveGroup v => v
zeroV, [])
  recomposeLinMap SubBasis ColourNeedle
R:SubBasisColourNeedle
ColourNeedleBasis [w
r,w
g] = (forall s v w. TensorProduct (DualVector v) w -> LinearMap s v w
LinearMap forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB w
r w
g forall v. AdditiveGroup v => v
zeroV, [])
  recomposeLinMap SubBasis ColourNeedle
R:SubBasisColourNeedle
ColourNeedleBasis (w
r:w
g:w
b:[w]
l) = (forall s v w. TensorProduct (DualVector v) w -> LinearMap s v w
LinearMap forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB w
r w
g w
b, [w]
l)
  recomposeContraLinMap :: forall w (f :: * -> *).
(LinearSpace w, Scalar w ~ Scalar ColourNeedle, Functor f) =>
(f (Scalar w) -> w)
-> f (DualVector ColourNeedle) -> ColourNeedle +> w
recomposeContraLinMap f (Scalar w) -> w
f f (DualVector ColourNeedle)
l = forall s v w. TensorProduct (DualVector v) w -> LinearMap s v w
LinearMap forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB (f (Scalar w) -> w
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall a. RGB a -> a
channelRed forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. ColourNeedle -> RGB ℝ
getRGBNeedle) f (DualVector ColourNeedle)
l)
                                              (f (Scalar w) -> w
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall a. RGB a -> a
channelGreen forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. ColourNeedle -> RGB ℝ
getRGBNeedle) f (DualVector ColourNeedle)
l)
                                              (f (Scalar w) -> w
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (forall a. RGB a -> a
channelBlue forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. ColourNeedle -> RGB ℝ
getRGBNeedle) f (DualVector ColourNeedle)
l)
  tensorEquality :: forall w.
(TensorSpace w, Eq w, Scalar w ~ Scalar ColourNeedle) =>
(ColourNeedle ⊗ w) -> (ColourNeedle ⊗ w) -> Bool
tensorEquality (Tensor TensorProduct ColourNeedle w
t) (Tensor TensorProduct ColourNeedle w
τ) = TensorProduct ColourNeedle w
t forall a. Eq a => a -> a -> Bool
== TensorProduct ColourNeedle w
τ
  recomposeContraLinMapTensor :: forall u w (f :: * -> *).
(FiniteDimensional u, LinearSpace w,
 Scalar u ~ Scalar ColourNeedle, Scalar w ~ Scalar ColourNeedle,
 Functor f) =>
(f (Scalar w) -> w)
-> f (ColourNeedle +> DualVector u) -> (ColourNeedle ⊗ u) +> w
recomposeContraLinMapTensor = forall u w (f :: * -> *).
(Functor f, FiniteDimensional u, LinearSpace w, Scalar u ~ ℝ,
 Scalar w ~ ℝ) =>
DualSpaceWitness u
-> (f ℝ -> w)
-> f (ColourNeedle +> DualVector u)
-> (ColourNeedle ⊗ u) +> w
rclmt forall v. LinearSpace v => DualSpaceWitness v
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 :: forall u w (f :: * -> *).
(Functor f, FiniteDimensional u, LinearSpace w, Scalar u ~ ℝ,
 Scalar w ~ ℝ) =>
DualSpaceWitness u
-> (f ℝ -> w)
-> f (ColourNeedle +> DualVector u)
-> (ColourNeedle ⊗ u) +> w
rclmt DualSpaceWitness u
DualSpaceWitness f ℝ -> w
fw f (ColourNeedle +> DualVector u)
mv = forall s v w. TensorProduct (DualVector v) w -> LinearMap s v w
LinearMap forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$
           (\TensorProduct (DualVector ColourNeedle) (DualVector u)
-> DualVector (DualVector (DualVector u))
c -> forall s u v w.
(LinearSpace u, Scalar u ~ s) =>
LinearMap s (DualVector u) w -> Tensor s u w
fromLinearMap forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall v w (f :: * -> *).
(FiniteDimensional v, LinearSpace w, Scalar w ~ Scalar v,
 Functor f) =>
(f (Scalar w) -> w) -> f (DualVector v) -> v +> w
recomposeContraLinMap f ℝ -> w
fw
                forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (\(LinearMap TensorProduct (DualVector ColourNeedle) (DualVector u)
q) -> TensorProduct (DualVector ColourNeedle) (DualVector u)
-> DualVector (DualVector (DualVector u))
c TensorProduct (DualVector ColourNeedle) (DualVector u)
q) f (ColourNeedle +> DualVector u)
mv)
                       forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall a. a -> a -> a -> RGB a
RGB forall a. RGB a -> a
channelRed forall a. RGB a -> a
channelGreen forall a. RGB a -> a
channelBlue
  uncanonicallyFromDual :: DualVector ColourNeedle -+> ColourNeedle
uncanonicallyFromDual = forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id
  uncanonicallyToDual :: ColourNeedle -+> DualVector ColourNeedle
uncanonicallyToDual = forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id

#if !MIN_VERSION_linearmap_category(0,6,0)
fromLinearMap :: ∀ s u v w . (LinearSpace u, Scalar u ~ s)
                 => LinearMap s (DualVector u) w -> Tensor s u w
fromLinearMap :: forall s u v w.
(LinearSpace u, Scalar u ~ s) =>
LinearMap s (DualVector u) w -> Tensor s u w
fromLinearMap = case forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualSpaceWitness u of
    DualSpaceWitness u
DualSpaceWitness -> coerce :: forall a b. Coercible a b => a -> b
coerce
asTensor :: ∀ s u v w . (LinearSpace u, Scalar u ~ s)
                 => LinearMap s u w -> Tensor s (DualVector u) w
asTensor :: forall s u v w.
(LinearSpace u, Scalar u ~ s) =>
LinearMap s u w -> Tensor s (DualVector u) w
asTensor = coerce :: forall a b. Coercible a b => a -> b
coerce
fromTensor :: ∀ s u v w . (LinearSpace u, Scalar u ~ s)
                 => Tensor s (DualVector u) w -> LinearMap s u w
fromTensor :: forall s u v w.
(LinearSpace u, Scalar u ~ s) =>
Tensor s (DualVector u) w -> LinearMap s u w
fromTensor = coerce :: forall a b. Coercible a b => a -> b
coerce
#endif

  

instance Semimanifold ColourNeedle where
  type Needle ColourNeedle = ColourNeedle
#if MIN_VERSION_manifolds(0,6,0)
  .+~^ :: ColourNeedle -> Needle ColourNeedle -> ColourNeedle
(.+~^) = forall v. AdditiveGroup v => v -> v -> v
(^+^)
#else
  fromInterior = id; toInterior = pure
  translateP = pure (^+^)
#endif

instance PseudoAffine ColourNeedle where
  ColourNeedle RGB ℝ
q .-~! :: HasCallStack => ColourNeedle -> ColourNeedle -> Needle ColourNeedle
.-~! ColourNeedle RGB ℝ
s = RGB ℝ -> ColourNeedle
ColourNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) c b a.
(Applicative f r t, Object r c, ObjectMorphism r b c,
 Object t (f c), ObjectMorphism t (f b) (f c), ObjectPair r a b,
 ObjectPair t (f a) (f b)) =>
r a (r b c) -> t (f a) (t (f b) (f c))
liftA2 (-) RGB ℝ
q RGB ℝ
s
  ColourNeedle
q .-~. :: ColourNeedle -> ColourNeedle -> Maybe (Needle ColourNeedle)
.-~. ColourNeedle
s = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure (ColourNeedle
qforall x. (PseudoAffine x, HasCallStack) => x -> x -> Needle x
.-~!ColourNeedle
s)

instance Atlas ColourNeedle where
  type ChartIndex ColourNeedle = ()
#if !MIN_VERSION_manifolds(0,6,0)
  interiorChartReferencePoint _ () = zeroV
#else
  chartReferencePoint :: ChartIndex ColourNeedle -> ColourNeedle
chartReferencePoint () = forall v. AdditiveGroup v => v
zeroV
#endif
  lookupAtlas :: ColourNeedle -> ChartIndex ColourNeedle
lookupAtlas ColourNeedle
_ = ()

#if MIN_VERSION_manifolds(0,6,0)
instance SemimanifoldWithBoundary ColourNeedle where
  type Interior ColourNeedle = ColourNeedle
  type Boundary ColourNeedle = EmptyMfd ℝ⁰
  type HalfNeedle ColourNeedle = ℝay
  smfdWBoundWitness :: SmfdWBoundWitness ColourNeedle
smfdWBoundWitness = forall m. OpenManifold m => SmfdWBoundWitness m
OpenManifoldWitness
  |+^ :: Boundary ColourNeedle -> HalfNeedle ColourNeedle -> ColourNeedle
(|+^) Boundary ColourNeedle
b = case Boundary ColourNeedle
b of {}
  ColourNeedle
_ .+^| :: ColourNeedle
-> Needle (Interior ColourNeedle)
-> Either
     (Boundary ColourNeedle, Scalar (Needle (Interior ColourNeedle)))
     (Interior ColourNeedle)
.+^| Needle (Interior ColourNeedle)
b = case Needle (Interior ColourNeedle)
b of {}
  fromBoundary :: Boundary ColourNeedle -> ColourNeedle
fromBoundary Boundary ColourNeedle
b = case Boundary ColourNeedle
b of {}
  fromInterior :: Interior ColourNeedle -> ColourNeedle
fromInterior = forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id

instance PseudoAffineWithBoundary ColourNeedle where
  ColourNeedle
_ !-| :: ColourNeedle -> Boundary ColourNeedle -> HalfNeedle ColourNeedle
!-| Boundary ColourNeedle
b = case Boundary ColourNeedle
b of {}
  .--! :: ColourNeedle -> ColourNeedle -> Needle (Interior ColourNeedle)
(.--!) = forall x. (PseudoAffine x, HasCallStack) => x -> x -> Needle x
(.-~!)

instance ProjectableBoundary ColourNeedle where
  projectToBoundary :: ColourNeedle
-> Boundary ColourNeedle
-> Maybe
     (Needle (Boundary ColourNeedle),
      Scalar (Needle (Interior ColourNeedle)))
projectToBoundary ColourNeedle
_ Boundary ColourNeedle
b = case Boundary ColourNeedle
b of {}
  marginFromBoundary :: Boundary ColourNeedle
-> Scalar (Needle (Interior ColourNeedle)) -> ColourNeedle
marginFromBoundary Boundary ColourNeedle
b Scalar (Needle (Interior ColourNeedle))
_ = case Boundary ColourNeedle
b of {}
#endif

instance AffineSpace ColourNeedle where
  type Diff ColourNeedle = ColourNeedle
  .-. :: ColourNeedle -> ColourNeedle -> Diff ColourNeedle
(.-.) = forall x. (PseudoAffine x, HasCallStack) => x -> x -> Needle x
(.-~!)
  .+^ :: ColourNeedle -> Diff ColourNeedle -> ColourNeedle
(.+^) = forall x. Semimanifold x => x -> Needle x -> x
(.+~^)

fromLtdRGB :: LtdCol -> Colour ℝ
fromLtdRGB :: RGB (CD¹ (ZeroDim ℝ)) -> Colour ℝ
fromLtdRGB = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap (\(CD¹ Scalar (Needle (ZeroDim ℝ))
h ZeroDim ℝ
Origin) -> Scalar (Needle (ZeroDim ℝ))
h) forall (k :: * -> * -> *) a b c.
(Category k, Object k a, Object k b, Object k c) =>
k a b -> k b c -> k a c
>>> \(RGB ℝ
r ℝ
g ℝ
b) -> forall a. Fractional a => a -> a -> a -> Colour a
rgb ℝ
r ℝ
g ℝ
b

toLtdRGB :: Colour ℝ -> LtdCol
toLtdRGB :: Colour ℝ -> RGB (CD¹ (ZeroDim ℝ))
toLtdRGB = forall a. Fractional a => Colour a -> RGB a
toRGB forall (k :: * -> * -> *) a b c.
(Category k, Object k a, Object k b, Object k c) =>
k a b -> k b c -> k a c
>>> forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap ((forall x. Scalar (Needle x) -> x -> CD¹ x
`CD¹`forall s. ZeroDim s
Origin) forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. Ord a => a -> a -> a
min ℝ
1 forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. Ord a => a -> a -> a
max ℝ
0)

type LtdCol = RGB (CD¹ ℝ⁰)

bijectToLtd :: ℝ -> CD¹ ℝ⁰
bijectToLtd :: ℝ -> CD¹ (ZeroDim ℝ)
bijectToLtd ℝ
0 = forall x. Scalar (Needle x) -> x -> CD¹ x
CD¹ ℝ
0.5 forall s. ZeroDim s
Origin
bijectToLtd ℝ
y
  | ℝ
ψ forall a. Ord a => a -> a -> Bool
> ℝ
0.5    = forall x. Scalar (Needle x) -> x -> CD¹ x
CD¹ ℝ
1 forall s. ZeroDim s
Origin
  | ℝ
ψ forall a. Ord a => a -> a -> Bool
> -ℝ
0.5   = forall x. Scalar (Needle x) -> x -> CD¹ x
CD¹ ( ℝ
0.5 forall a. Num a => a -> a -> a
- ℝ
ψ ) forall s. ZeroDim s
Origin
  | Bool
otherwise  = forall x. Scalar (Needle x) -> x -> CD¹ x
CD¹ ℝ
0 forall s. ZeroDim s
Origin
 where ψ :: ℝ
ψ = (ℝ
1 forall a. Num a => a -> a -> a
- forall a. Floating a => a -> a
sqrt(ℝ
1forall a. Num a => a -> a -> a
+ℝ
yforall a b. (Num a, Integral b) => a -> b -> a
^Integer
2)) forall a. Fractional a => a -> a -> a
/ (ℝ
2forall a. Num a => a -> a -> a
*ℝ
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)  -- unstable for y ≈ 0
--   = 1/2 - (1 - sqrt( 1 + y² ) ) / (2*y)

bijectFromLtd :: CD¹ ℝ⁰ -> Either S⁰ ℝ
bijectFromLtd :: CD¹ (ZeroDim ℝ) -> Either S⁰ ℝ
bijectFromLtd (CD¹ Scalar (Needle (ZeroDim ℝ))
x ZeroDim ℝ
Origin)
    | Scalar (Needle (ZeroDim ℝ))
xforall a. Ord a => a -> a -> Bool
<=ℝ
1e-9     = forall a b. a -> Either a b
Left forall r. S⁰_ r
NegativeHalfSphere
    | Scalar (Needle (ZeroDim ℝ))
xforall a. Ord a => a -> a -> Bool
>=ℝ
1forall a. Num a => a -> a -> a
-ℝ
1e-9   = forall a b. a -> Either a b
Left forall r. S⁰_ r
PositiveHalfSphere
    | Bool
otherwise   = forall (m :: * -> *) a. Monad m (->) => a -> m a
return forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (Scalar (Needle (ZeroDim ℝ))
x forall a. Num a => a -> a -> a
- ℝ
0.5) forall a. Fractional a => a -> a -> a
/ (Scalar (Needle (ZeroDim ℝ))
xforall a. Num a => a -> a -> a
*(ℝ
1 forall a. Num a => a -> a -> a
- Scalar (Needle (ZeroDim ℝ))
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 :: Gen ColourBoundary
arbitrary = S²_ ℝ -> ColourBoundary
ColourBoundarySphere forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall a. Arbitrary a => Gen a
QC.arbitrary

instance SemimanifoldWithBoundary ColourBoundary where
  type Boundary ColourBoundary = EmptyMfd ℝ⁰
  type Interior ColourBoundary = ColourBoundary
  type HalfNeedle ColourBoundary = ℝay
  smfdWBoundWitness :: SmfdWBoundWitness ColourBoundary
smfdWBoundWitness = forall m. OpenManifold m => SmfdWBoundWitness m
OpenManifoldWitness
  needleIsOpenMfd :: forall r.
(OpenManifold (Needle (Interior ColourBoundary)) => r) -> r
needleIsOpenMfd OpenManifold (Needle (Interior ColourBoundary)) => r
q = OpenManifold (Needle (Interior ColourBoundary)) => r
q
  Boundary ColourBoundary
b|+^ :: Boundary ColourBoundary
-> HalfNeedle ColourBoundary -> ColourBoundary
|+^HalfNeedle ColourBoundary
_ = case Boundary ColourBoundary
b of {}
  ColourBoundary
_.+^| :: ColourBoundary
-> Needle (Interior ColourBoundary)
-> Either
     (Boundary ColourBoundary,
      Scalar (Needle (Interior ColourBoundary)))
     (Interior ColourBoundary)
.+^|Needle (Interior ColourBoundary)
b = case Needle (Interior ColourBoundary)
b of {}
  fromInterior :: Interior ColourBoundary -> ColourBoundary
fromInterior = forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id
  fromBoundary :: Boundary ColourBoundary -> ColourBoundary
fromBoundary Boundary ColourBoundary
b = case Boundary ColourBoundary
b of {}
#endif

instance Hask.Foldable RGB where
  foldMap :: forall m a. Monoid m => (a -> m) -> RGB a -> m
foldMap a -> m
f (RGB a
r a
g a
b) = a -> m
f a
r forall a. Monoid a => a -> a -> a
`mappend` a -> m
f a
g forall a. Monoid a => a -> a -> a
`mappend` a -> m
f a
b

projectRGBToColourBoundary :: RGB ℝ -> ColourBoundary
projectRGBToColourBoundary :: RGB ℝ -> ColourBoundary
projectRGBToColourBoundary RGB ℝ
c = S²_ ℝ -> ColourBoundary
ColourBoundarySphere forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall r. r -> r -> S²_ r
S²Polar ℝ
ϑ ℝ
φ
 where (ℝ
h,ℝ
_,ℝ
l) = forall a. (Fractional a, Ord a) => RGB a -> (a, a, a)
hslView RGB ℝ
c
       φ :: ℝ
φ = ℝ
hforall a. Num a => a -> a -> a
*ℝ
2forall a. Num a => a -> a -> a
*forall a. Floating a => a
piforall a. Fractional a => a -> a -> a
/ℝ
360 forall a. Num a => a -> a -> a
- forall a. Floating a => a
pi
       ϑ :: ℝ
ϑ = ℝ
l forall a. Num a => a -> a -> a
* forall a. Floating a => a
pi

#if MIN_VERSION_manifolds(0,6,0)
instance SemimanifoldWithBoundary (Colour ℝ) where
  type Boundary (Colour ℝ) = ColourBoundary
  type HalfNeedle (Colour ℝ) = ColourHalfNeedle
  smfdWBoundWitness :: SmfdWBoundWitness (Colour ℝ)
smfdWBoundWitness = forall a. HasCallStack => a
undefined -- SmfdWBoundWitness
  needleIsOpenMfd :: forall r. (OpenManifold (Needle (Interior (Colour ℝ))) => r) -> r
needleIsOpenMfd OpenManifold (Needle (Interior (Colour ℝ))) => r
q = OpenManifold (Needle (Interior (Colour ℝ))) => r
q
  fromBoundary :: Boundary (Colour ℝ) -> Colour ℝ
fromBoundary (ColourBoundarySphere (S²Polar ℝ
ϑ ℝ
φ))
        = forall a. Fractional a => RGB a -> Colour a
fromRGB forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. (RealFrac a, Ord a) => a -> a -> a -> RGB a
hsl ((ℝ
φforall a. Num a => a -> a -> a
+forall a. Floating a => a
pi)forall a. Num a => a -> a -> a
*ℝ
360forall a. Fractional a => a -> a -> a
/(ℝ
2forall a. Num a => a -> a -> a
*forall a. Floating a => a
pi)) ℝ
1 (ℝ
ϑforall a. Fractional a => a -> a -> a
/forall a. Floating a => a
pi)
  Boundary (Colour ℝ)
b |+^ :: Boundary (Colour ℝ) -> HalfNeedle (Colour ℝ) -> Colour ℝ
|+^ ColourHalfNeedle (Cℝay Scalar (Needle (ZeroDim ℝ))
d ZeroDim ℝ
Origin) Needle ColourBoundary
δb
        = forall a. Fractional a => RGB a -> Colour a
fromRGB forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. (RealFrac a, Ord a) => a -> a -> a -> RGB a
hsl ((ℝ
φforall a. Num a => a -> a -> a
+forall a. Floating a => a
pi)forall a. Num a => a -> a -> a
*ℝ
360forall a. Fractional a => a -> a -> a
/(ℝ
2forall a. Num a => a -> a -> a
*forall a. Floating a => a
pi)) (ℝ
1forall a. Fractional a => a -> a -> a
/(Scalar (Needle (ZeroDim ℝ))
dforall a. Num a => a -> a -> a
+ℝ
1)) (ℝ
0.5 forall a. Num a => a -> a -> a
+ (ℝ
ϑforall a. Fractional a => a -> a -> a
/forall a. Floating a => a
piforall a. Num a => a -> a -> a
-ℝ
0.5)forall a. Fractional a => a -> a -> a
/(Scalar (Needle (ZeroDim ℝ))
dforall a. Num a => a -> a -> a
+ℝ
1))
   where ColourBoundarySphere (S²Polar ℝ
ϑ ℝ
φ) = Boundary (Colour ℝ)
bforall x. Semimanifold x => x -> Needle x -> x
.+~^Needle ColourBoundary
δb
  Colour ℝ
c .+^| :: Colour ℝ
-> Needle (Interior (Colour ℝ))
-> Either
     (Boundary (Colour ℝ), Scalar (Needle (Interior (Colour ℝ))))
     (Interior (Colour ℝ))
.+^| ColourNeedle RGB ℝ
dc
    | ℝ
ηforall a. Ord a => a -> a -> Bool
>ℝ
1        = forall a b. a -> Either a b
Left (RGB ℝ -> ColourBoundary
projectRGBToColourBoundary forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. Num a => a -> a -> a
(+)forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
.(forall a. Fractional a => a -> a -> a
/ℝ
η) forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> RGB ℝ
dc forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Applicative f r t, ObjectMorphism r a b,
 ObjectMorphism t (f a) (f b), Object t (t (f a) (f b)),
 ObjectPair r (r a b) a, ObjectPair t (f (r a b)) (f a), Object r a,
 Object r b) =>
t (f (r a b)) (t (f a) (f b))
<*> RGB ℝ
rgb, ℝ
η forall a. Num a => a -> a -> a
- ℝ
1)
    | Bool
otherwise  = case forall m.
SemimanifoldWithBoundary m =>
m -> Either (Boundary m) (Interior m)
separateInterior forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a. Fractional a => RGB a -> Colour a
fromRGB forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. Num a => a -> a -> a
(+)forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>RGB ℝ
dcforall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Applicative f r t, ObjectMorphism r a b,
 ObjectMorphism t (f a) (f b), Object t (t (f a) (f b)),
 ObjectPair r (r a b) a, ObjectPair t (f (r a b)) (f a), Object r a,
 Object r b) =>
t (f (r a b)) (t (f a) (f b))
<*>RGB ℝ
rgb of
                     Right Interior (Colour ℝ)
c' -> forall a b. b -> Either a b
Right Interior (Colour ℝ)
c'
                     Left Boundary (Colour ℝ)
c'b -> forall a. HasCallStack => String -> a
error forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. Show a => a -> String
show (ℝ
η, forall a. Num a => a -> a -> a
(+)forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$>RGB ℝ
dcforall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Applicative f r t, ObjectMorphism r a b,
 ObjectMorphism t (f a) (f b), Object t (t (f a) (f b)),
 ObjectPair r (r a b) a, ObjectPair t (f (r a b)) (f a), Object r a,
 Object r b) =>
t (f (r a b)) (t (f a) (f b))
<*>RGB ℝ
rgb)
   where rgb :: RGB ℝ
rgb = forall a. Fractional a => Colour a -> RGB a
toRGB Colour ℝ
c
         η :: ℝ
η = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (\ℝ
m ℝ
d -> if ℝ
dforall a. Ord a => a -> a -> Bool
>ℝ
0 then if ℝ
mforall a. Ord a => a -> a -> Bool
<ℝ
1 then ℝ
dforall a. Fractional a => a -> a -> a
/(ℝ
1forall a. Num a => a -> a -> a
-ℝ
m) else ℝ
huge
                                 else if ℝ
dforall a. Ord a => a -> a -> Bool
<ℝ
0 then -ℝ
dforall a. Fractional a => a -> a -> a
/ℝ
m
                                 else ℝ
0)
                      forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> RGB ℝ
rgb forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Applicative f r t, ObjectMorphism r a b,
 ObjectMorphism t (f a) (f b), Object t (t (f a) (f b)),
 ObjectPair r (r a b) a, ObjectPair t (f (r a b)) (f a), Object r a,
 Object r b) =>
t (f (r a b)) (t (f a) (f b))
<*> RGB ℝ
dc
         huge :: ℝ
huge = ℝ
1e12
  separateInterior :: Colour ℝ -> Either (Boundary (Colour ℝ)) (Interior (Colour ℝ))
separateInterior Colour ℝ
c = case RGB (CD¹ (ZeroDim ℝ)) -> Either S⁰ (RGB ℝ)
toin forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Colour ℝ -> RGB (CD¹ (ZeroDim ℝ))
toLtdRGB Colour ℝ
c of
           Left S⁰
_ -> forall a b. a -> Either a b
Left forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. RGB ℝ -> ColourBoundary
projectRGBToColourBoundary forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. Fractional a => Colour a -> RGB a
toRGB Colour ℝ
c
           Right RGB ℝ
ci -> forall a b. b -> Either a b
Right forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ RGB ℝ -> ColourNeedle
ColourNeedle RGB ℝ
ci
   where rgb :: RGB ℝ
rgb = forall a. Fractional a => Colour a -> RGB a
toRGB Colour ℝ
c
         toin :: RGB (CD¹ (ZeroDim ℝ)) -> Either S⁰ (RGB ℝ)
toin (RGB CD¹ (ZeroDim ℝ)
r CD¹ (ZeroDim ℝ)
g CD¹ (ZeroDim ℝ)
b) = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) c d b a.
(Applicative f r t, Object r c, Object r d, ObjectMorphism r c d,
 ObjectMorphism r b (r c d), Object r (r c d), ObjectPair r a b,
 ObjectPair r (r c d) c, Object t (f c), Object t (f d),
 Object t (f a, f b), ObjectMorphism t (f c) (f d),
 ObjectMorphism t (f b) (t (f c) (f d)), Object t (t (f c) (f d)),
 ObjectPair t (f a) (f b), ObjectPair t (t (f c) (f d)) (f c),
 ObjectPair t (f (r c d)) (f c)) =>
r a (r b (r c d)) -> t (f a) (t (f b) (t (f c) (f d)))
liftA3 forall a. a -> a -> a -> RGB a
RGB (CD¹ (ZeroDim ℝ) -> Either S⁰ ℝ
bijectFromLtd CD¹ (ZeroDim ℝ)
r) (CD¹ (ZeroDim ℝ) -> Either S⁰ ℝ
bijectFromLtd CD¹ (ZeroDim ℝ)
g) (CD¹ (ZeroDim ℝ) -> Either S⁰ ℝ
bijectFromLtd CD¹ (ZeroDim ℝ)
b)
#else
instance Semimanifold (Colour ℝ) where
  type Needle (Colour ℝ) = ColourNeedle
#endif
  type Interior (Colour ℝ) = ColourNeedle
  fromInterior :: Interior (Colour ℝ) -> Colour ℝ
fromInterior (ColourNeedle RGB ℝ
q) = RGB (CD¹ (ZeroDim ℝ)) -> Colour ℝ
fromLtdRGB forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap ℝ -> CD¹ (ZeroDim ℝ)
bijectToLtd RGB ℝ
q
  toInterior :: Colour ℝ -> Maybe (Interior (Colour ℝ))
toInterior = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap RGB ℝ -> ColourNeedle
ColourNeedle forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall a b. Either a b -> Maybe b
eitherToMaybe forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. RGB (CD¹ (ZeroDim ℝ)) -> Either S⁰ (RGB ℝ)
toin forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Colour ℝ -> RGB (CD¹ (ZeroDim ℝ))
toLtdRGB
   where toin :: RGB (CD¹ (ZeroDim ℝ)) -> Either S⁰ (RGB ℝ)
toin (RGB CD¹ (ZeroDim ℝ)
r CD¹ (ZeroDim ℝ)
g CD¹ (ZeroDim ℝ)
b) = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) c d b a.
(Applicative f r t, Object r c, Object r d, ObjectMorphism r c d,
 ObjectMorphism r b (r c d), Object r (r c d), ObjectPair r a b,
 ObjectPair r (r c d) c, Object t (f c), Object t (f d),
 Object t (f a, f b), ObjectMorphism t (f c) (f d),
 ObjectMorphism t (f b) (t (f c) (f d)), Object t (t (f c) (f d)),
 ObjectPair t (f a) (f b), ObjectPair t (t (f c) (f d)) (f c),
 ObjectPair t (f (r c d)) (f c)) =>
r a (r b (r c d)) -> t (f a) (t (f b) (t (f c) (f d)))
liftA3 forall a. a -> a -> a -> RGB a
RGB (CD¹ (ZeroDim ℝ) -> Either S⁰ ℝ
bijectFromLtd CD¹ (ZeroDim ℝ)
r) (CD¹ (ZeroDim ℝ) -> Either S⁰ ℝ
bijectFromLtd CD¹ (ZeroDim ℝ)
g) (CD¹ (ZeroDim ℝ) -> Either S⁰ ℝ
bijectFromLtd CD¹ (ZeroDim ℝ)
b)
#if !MIN_VERSION_manifolds(0,6,0)
  translateP = pure (^+^)
#endif

#if MIN_VERSION_manifolds(0,6,0)
instance PseudoAffineWithBoundary (Colour ℝ) where
  Colour ℝ
c .--! :: Colour ℝ -> Colour ℝ -> Needle (Interior (Colour ℝ))
.--! Colour ℝ
d = RGB ℝ -> ColourNeedle
ColourNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ (-) forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall a. Fractional a => Colour a -> RGB a
toRGB Colour ℝ
c forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Applicative f r t, ObjectMorphism r a b,
 ObjectMorphism t (f a) (f b), Object t (t (f a) (f b)),
 ObjectPair r (r a b) a, ObjectPair t (f (r a b)) (f a), Object r a,
 Object r b) =>
t (f (r a b)) (t (f a) (f b))
<*> forall a. Fractional a => Colour a -> RGB a
toRGB Colour ℝ
d
#else
instance PseudoAffine (Colour ℝ) where
  c .-~. ζ = liftA2 (^-^) (toInterior c) (toInterior ζ)
#endif

eitherToMaybe :: Either a b -> Maybe b
eitherToMaybe :: forall a b. Either a b -> Maybe b
eitherToMaybe (Left a
_) = forall a. Maybe a
Nothing
eitherToMaybe (Right b
x) = forall a. a -> Maybe a
Just b
x

instance Geodesic (Colour ℝ) where
  geodesicBetween :: Colour ℝ -> Colour ℝ -> Maybe (D¹ -> Colour ℝ)
geodesicBetween Colour ℝ
a Colour ℝ
b = forall (m :: * -> *) a. Monad m (->) => a -> m a
return forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \(D¹ ℝ
q) -> forall a (f :: * -> *).
(Num a, AffineSpace f) =>
a -> f a -> f a -> f a
blend ((ℝ
qforall a. Num a => a -> a -> a
+ℝ
1)forall a. Fractional a => a -> a -> a
/ℝ
2) Colour ℝ
b Colour ℝ
a

instance Geodesic ColourNeedle where
  geodesicBetween :: ColourNeedle -> ColourNeedle -> Maybe (D¹ -> ColourNeedle)
geodesicBetween (ColourNeedle (RGB ℝ
r ℝ
g ℝ
b)) (ColourNeedle (RGB ℝ
r' ℝ
g' ℝ
b'))
                 = forall (m :: * -> *) a. Monad m (->) => a -> m a
return forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \(D¹ ℝ
q) -> let η' :: ℝ
η' = (ℝ
qforall a. Num a => a -> a -> a
+ℝ
1)forall a. Fractional a => a -> a -> a
/ℝ
2 in RGB ℝ -> ColourNeedle
ColourNeedle
                                        forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB (forall v. VectorSpace v => v -> v -> Scalar v -> v
lerp ℝ
r ℝ
r' ℝ
η')
                                              (forall v. VectorSpace v => v -> v -> Scalar v -> v
lerp ℝ
g ℝ
g' ℝ
η')
                                              (forall v. VectorSpace v => v -> v -> Scalar v -> v
lerp ℝ
b ℝ
b' ℝ
η')

instance Atlas (Colour ℝ) where
  type ChartIndex (Colour ℝ) = ()
  chartReferencePoint :: ChartIndex (Colour ℝ) -> Colour ℝ
chartReferencePoint () = forall a. (Ord a, Floating a) => Colour a
grey
#if !MIN_VERSION_manifolds(0,6,0)
  interiorChartReferencePoint = \_ () -> intGrey
   where Just intGrey = toInterior (grey :: Colour ℝ)
#endif
  lookupAtlas :: Colour ℝ -> ChartIndex (Colour ℝ)
lookupAtlas Colour ℝ
_ = ()

class QuantisedColour c where
  quantiseColour :: Colour ℝ -> c

instance QuantisedColour PixelRGBF where
  quantiseColour :: Colour ℝ -> PixelRGBF
quantiseColour Colour ℝ
c = Float -> Float -> Float -> PixelRGBF
PixelRGBF Float
r Float
g Float
b
   where RGB Float
r Float
g Float
b = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a b.
(Functor f r t, Object r a, Object t (f a), Object r b,
 Object t (f b)) =>
r a b -> t (f a) (f b)
fmap forall a b. (Real a, Fractional b) => a -> b
realToFrac forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall b. (Ord b, Floating b) => Colour b -> RGB b
toSRGB Colour ℝ
c
  
instance QuantisedColour PixelRGB8 where
  quantiseColour :: Colour ℝ -> PixelRGB8
quantiseColour Colour ℝ
c = Pixel8 -> Pixel8 -> Pixel8 -> PixelRGB8
PixelRGB8 Pixel8
r Pixel8
g Pixel8
b
   where RGB Pixel8
r Pixel8
g Pixel8
b = forall b. (RealFrac b, Floating b) => Colour b -> RGB Pixel8
toSRGB24 Colour ℝ
c


-- | A two-dimensional, smoothly varying colour palette.
data ColourMap x = ColourMap {
       forall x. ColourMap x -> ColourPlane
_cmPlane :: ColourPlane
     , forall x. ColourMap x -> ℝ
_cmSpectSwing :: ℝ
     }

planarColourMap :: ColourPlane -> ColourMap x
planarColourMap :: forall x. ColourPlane -> ColourMap x
planarColourMap = (forall x. ColourPlane -> ℝ -> ColourMap x
`ColourMap`ℝ
0)

colourCurve :: ColourPlane -> ℝ -> ColourMap ℝ
colourCurve :: ColourPlane -> ℝ -> ColourMap ℝ
colourCurve = forall x. ColourPlane -> ℝ -> ColourMap x
ColourMap

spectralSwing :: (Needle x ~ ℝ) => Traversal' (ColourMap x) ℝ
spectralSwing :: forall x. (Needle x ~ ℝ) => Traversal' (ColourMap x) ℝ
spectralSwing = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall x. ColourMap x -> ℝ
_cmSpectSwing (\ColourMap x
cm ℝ
sw' -> ColourMap x
cm{_cmSpectSwing :: ℝ
_cmSpectSwing = ℝ
sw'})

colourMapPlane :: Traversal' (ColourMap x) ColourPlane
colourMapPlane :: forall x. Traversal' (ColourMap x) ColourPlane
colourMapPlane = forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens forall x. ColourMap x -> ColourPlane
_cmPlane (\ColourMap x
cm ColourPlane
pl' -> ColourMap x
cm{_cmPlane :: ColourPlane
_cmPlane = ColourPlane
pl'})

fromRGB :: Fractional a => RGB a -> Colour a
fromRGB :: forall a. Fractional a => RGB a -> Colour a
fromRGB (RGB a
r a
g a
b) = forall a. Fractional a => a -> a -> a -> Colour a
rgb a
r a
g a
b

data ColourPlane = ColourPlane {
        ColourPlane -> Colour ℝ
_cpCold :: Colour ℝ
      , ColourPlane -> Interior (Colour ℝ)
_cpNeutral :: Interior (Colour ℝ)
      , ColourPlane -> Colour ℝ
_cpHot :: Colour ℝ
      }
makeLenses ''ColourPlane

spanColourPlane :: Interior (Colour ℝ)   -- ^ Neutral colour
                -> (Colour ℝ, Colour ℝ)  -- ^ Extreme “cold” / “hot” colours
                -> ColourPlane
spanColourPlane :: Interior (Colour ℝ) -> (Colour ℝ, Colour ℝ) -> ColourPlane
spanColourPlane Interior (Colour ℝ)
neutral (Colour ℝ
cold,Colour ℝ
hot) = Colour ℝ -> Interior (Colour ℝ) -> Colour ℝ -> ColourPlane
ColourPlane Colour ℝ
cold Interior (Colour ℝ)
neutral Colour ℝ
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 :: HasCallStack =>
ColourMap (MappingVertex ℝ)
-> Interior (MappingVertex ℝ)
-> (MappingVertex ℝ, MappingVertex ℝ)
-> ℝ
-> ColourMapped ℝ
mapToColourWith (ColourMap (ColourPlane Colour ℝ
coldC Interior (Colour ℝ)
neutralC Colour ℝ
hotC) ℝ
swing)
              Interior (MappingVertex ℝ)
neutralP (MappingVertex ℝ
coldP, MappingVertex ℝ
hotP)
        = (\(Shade ColourNeedle
c Metric' ColourNeedle
_) -> forall m. SemimanifoldWithBoundary m => Interior m -> m
fromInterior ColourNeedle
c)
           forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Shade (Interior (ℝ, ℝ)) -> Shade (Interior (Colour ℝ))
shFn
           forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. \ℝ
x -> let φ :: ℝ
φ = ℝ
2forall a. Num a => a -> a -> a
*(ℝ
xforall a. Num a => a -> a -> a
-Interior (MappingVertex ℝ)
neutralP)forall a. Fractional a => a -> a -> a
/(MappingVertex ℝ
hotPforall a. Num a => a -> a -> a
-MappingVertex ℝ
coldP)
                   in forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade ( (ℝ
1 forall a. Num a => a -> a -> a
- ℝ
φ)forall a. Fractional a => a -> a -> a
/ℝ
2 forall a. Num a => a -> a -> a
+ (ℝ
φforall a b. (Num a, Integral b) => a -> b -> a
^Integer
2 forall a. Num a => a -> a -> a
- ℝ
1)forall a. Num a => a -> a -> a
*forall a. Floating a => a -> a
exp ℝ
swingforall a. Fractional a => a -> a -> a
/ℝ
2
                            , (ℝ
φ forall a. Num a => a -> a -> a
+ ℝ
1)forall a. Fractional a => a -> a -> a
/ℝ
2 forall a. Num a => a -> a -> a
+ (ℝ
φforall a b. (Num a, Integral b) => a -> b -> a
^Integer
2 forall a. Num a => a -> a -> a
- ℝ
1)forall a. Num a => a -> a -> a
*forall a. Floating a => a -> a
exp ℝ
swingforall a. Fractional a => a -> a -> a
/ℝ
2 )
                            (forall v. LSpace v => [DualVector v] -> Seminorm v
spanNorm [(ℝ
256,ℝ
0), (ℝ
0,ℝ
256)])
                                     :: Shade (ℝ,ℝ)
   where Just Shade (Interior (ℝ, ℝ)) -> Shade (Interior (Colour ℝ))
shFn = forall i m (t :: * -> *) s.
(Geodesic i, Geodesic m, WithField s AffineManifold (Interior i),
 WithField s AffineManifold (Interior m),
 SimpleSpace (Needle (Interior i)),
 SimpleSpace (Needle (Interior m)),
 SimpleSpace (Needle' (Interior i)),
 SimpleSpace (Needle' (Interior m)), RealFrac' s, Traversable t) =>
(Interior i, Interior m)
-> t (i, m) -> Maybe (Shade (Interior i) -> Shade (Interior m))
rangeWithinVertices ((ℝ
0,ℝ
0), Interior (Colour ℝ)
neutralC)
                                        [((ℝ
1,ℝ
0) :: (ℝ,ℝ), Colour ℝ
coldC), ((ℝ
0,ℝ
1), Colour ℝ
hotC)]

instance ColourMappable (ℝ,ℝ) where
  type ColourMapped (ℝ,ℝ) = Colour ℝ
  type MappingVertex (ℝ,ℝ) = (ℝ,ℝ)
  mapToColourWith :: HasCallStack =>
ColourMap (MappingVertex (ℝ, ℝ))
-> Interior (MappingVertex (ℝ, ℝ))
-> (MappingVertex (ℝ, ℝ), MappingVertex (ℝ, ℝ))
-> (ℝ, ℝ)
-> ColourMapped (ℝ, ℝ)
mapToColourWith (ColourMap ColourPlane
cp ℝ
swing)
              (ℝ
xN,ℝ
yN) ((ℝ
xCold,ℝ
yCold), (ℝ
xHot,ℝ
yHot))
      = forall x.
(ColourMappable x, HasCallStack) =>
ColourMap (MappingVertex x)
-> Interior (MappingVertex x)
-> (MappingVertex x, MappingVertex x)
-> x
-> ColourMapped x
mapToColourWith (forall x. ColourPlane -> ℝ -> ColourMap x
ColourMap ColourPlane
cp ℝ
swing) (forall a. a -> a -> V2 a
V2 ℝ
xN ℝ
yN) (forall a. a -> a -> V2 a
V2 ℝ
xCold ℝ
yCold, forall a. a -> a -> V2 a
V2 ℝ
xHot ℝ
yHot)
          forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. \(ℝ
x,ℝ
y) -> (forall a. a -> a -> V2 a
V2 ℝ
x ℝ
y)

instance ColourMappable ℝ² where
  type ColourMapped ℝ² = Colour ℝ
  type MappingVertex ℝ² = ℝ²
  mapToColourWith :: HasCallStack =>
ColourMap (MappingVertex (V2 ℝ))
-> Interior (MappingVertex (V2 ℝ))
-> (MappingVertex (V2 ℝ), MappingVertex (V2 ℝ))
-> V2 ℝ
-> ColourMapped (V2 ℝ)
mapToColourWith (ColourMap (ColourPlane Colour ℝ
coldC Interior (Colour ℝ)
neutralC Colour ℝ
hotC) ℝ
swing)
              Interior (MappingVertex (V2 ℝ))
neutralP (MappingVertex (V2 ℝ)
coldP, MappingVertex (V2 ℝ)
hotP)
        = (\(Shade ColourNeedle
c Metric' ColourNeedle
_) -> forall m. SemimanifoldWithBoundary m => Interior m -> m
fromInterior ColourNeedle
c)
           forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. Shade (Interior (V2 ℝ)) -> Shade (Interior (Colour ℝ))
shFn
           forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. \V2 ℝ
xy -> forall x.
(Semimanifold x, SimpleSpace (Needle x)) =>
x -> Metric' x -> Shade x
Shade V2 ℝ
xy Norm (DualVector (DualVector (V2 ℝ)))
quantisationNorm
   where Just Shade (Interior (V2 ℝ)) -> Shade (Interior (Colour ℝ))
shFn = forall i m (t :: * -> *) s.
(Geodesic i, Geodesic m, WithField s AffineManifold (Interior i),
 WithField s AffineManifold (Interior m),
 SimpleSpace (Needle (Interior i)),
 SimpleSpace (Needle (Interior m)),
 SimpleSpace (Needle' (Interior i)),
 SimpleSpace (Needle' (Interior m)), RealFrac' s, Traversable t) =>
(Interior i, Interior m)
-> t (i, m) -> Maybe (Shade (Interior i) -> Shade (Interior m))
rangeWithinVertices (Interior (MappingVertex (V2 ℝ))
neutralP, Interior (Colour ℝ)
neutralC)
                                        [(MappingVertex (V2 ℝ)
coldP, Colour ℝ
coldC), (MappingVertex (V2 ℝ)
hotP, Colour ℝ
hotC)]
         quantisationNorm :: Norm (DualVector (DualVector (V2 ℝ)))
quantisationNorm = forall v. LSpace v => Scalar v -> Norm v -> Norm v
scaleNorm Scalar (DualVector (DualVector (V2 ℝ)))
256 forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall v. SimpleSpace v => Norm v -> Variance v
dualNorm
                              forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall v. LSpace v => [v] -> Variance v
spanVariance [MappingVertex (V2 ℝ)
coldPforall v. AdditiveGroup v => v -> v -> v
^-^Interior (MappingVertex (V2 ℝ))
neutralP, MappingVertex (V2 ℝ)
hotPforall v. AdditiveGroup v => v -> v -> v
^-^Interior (MappingVertex (V2 ℝ))
neutralP]


class ColourMappable x => HasSimpleColourMaps x where
  simpleColourMap :: ColourPlane -> ℝ -> ColourMap x
  simpleColourMap = forall (a :: * -> * -> *) b x.
(WellPointed a, Object a b, ObjectPoint a x) =>
x -> a b x
const forall κ (k :: κ -> κ -> *) (a :: κ) (b :: κ) (c :: κ).
(Category k, Object k a, Object k b, Object k c) =>
k b c -> k a b -> k a c
. forall x. ColourPlane -> ColourMap x
planarColourMap

instance HasSimpleColourMaps ℝ where
  simpleColourMap :: ColourPlane -> ℝ -> ColourMap ℝ
simpleColourMap = ColourPlane -> ℝ -> ColourMap ℝ
colourCurve

instance HasSimpleColourMaps (ℝ,ℝ)
instance HasSimpleColourMaps ℝ²

type SimpleColourMap = ∀ x . HasSimpleColourMaps x => ColourMap x

blackBlueYellowRed :: SimpleColourMap
blackBlueYellowRed :: SimpleColourMap
blackBlueYellowRed
   = forall x. HasSimpleColourMaps x => ColourPlane -> ℝ -> ColourMap x
simpleColourMap (Interior (Colour ℝ) -> (Colour ℝ, Colour ℝ) -> ColourPlane
spanColourPlane ColourNeedle
neutralc (forall a. (Ord a, Floating a) => Colour a
darkblue,forall a. (Ord a, Floating a) => Colour a
goldenrod)) ℝ
1
 where Just Interior (Colour ℝ)
neutralc = forall m. SemimanifoldWithBoundary m => m -> Maybe (Interior m)
toInterior (forall a. (Ord a, Floating a) => Colour a
dimgrey :: Colour ℝ)

redVsBlue :: SimpleColourMap
redVsBlue :: SimpleColourMap
redVsBlue
   = forall x. HasSimpleColourMaps x => ColourPlane -> ℝ -> ColourMap x
simpleColourMap (Interior (Colour ℝ) -> (Colour ℝ, Colour ℝ) -> ColourPlane
spanColourPlane ColourNeedle
neutralc (forall a. Fractional a => a -> a -> a -> Colour a
rgb ℝ
0.9 ℝ
0 ℝ
0.2, forall a. Fractional a => a -> a -> a -> Colour a
rgb ℝ
0.1 ℝ
0.3 ℝ
1)) (-ℝ
1forall a. Fractional a => a -> a -> a
/ℝ
2)
 where neutralc :: ColourNeedle
neutralc = RGB ℝ -> ColourNeedle
ColourNeedle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. a -> a -> a -> RGB a
RGB (-ℝ
1.2) (-ℝ
0.5) (-ℝ
1.5)

brightVsRed :: SimpleColourMap
brightVsRed :: SimpleColourMap
brightVsRed
   = forall x. HasSimpleColourMaps x => ColourPlane -> ℝ -> ColourMap x
simpleColourMap (Interior (Colour ℝ) -> (Colour ℝ, Colour ℝ) -> ColourPlane
spanColourPlane ColourNeedle
neutralc (forall a. (Ord a, Floating a) => Colour a
white, forall a. (Ord a, Floating a) => Colour a
orangered)) ℝ
1
 where Just Interior (Colour ℝ)
neutralc = forall m. SemimanifoldWithBoundary m => m -> Maybe (Interior m)
toInterior (forall a. (Ord a, Floating a) => Colour a
darkgrey :: Colour ℝ)