module Data.Manifold.PseudoAffine (
Manifold
, Semimanifold(..), Needle'
, PseudoAffine(..)
, Local(..)
, Metric, Metric', euclideanMetric
, RieMetric, RieMetric'
, SemimanifoldWitness(..)
, PseudoAffineWitness(..)
, BoundarylessWitness(..)
, boundarylessWitness
, DualNeedleWitness
, RealDimension, AffineManifold
, LinearManifold
, WithField
, HilbertManifold
, EuclidSpace
, LocallyScalable
, LocalLinear, LocalAffine
, alerpB, palerp, palerpB, LocallyCoercible(..), CanonicalDiffeomorphism(..)
, ImpliesMetric(..), coerceMetric, coerceMetric'
) where
import Math.Manifold.Core.PseudoAffine
import Data.Maybe
import Data.Fixed
import Data.VectorSpace
import Linear.V0
import Linear.V1
import Linear.V2
import Linear.V3
import Linear.V4
import qualified Linear.Affine as LinAff
import Data.Embedding
import Data.LinearMap
import Math.LinearMap.Category
import Data.AffineSpace
import Data.Tagged
import Data.Manifold.Types.Primitive
import Data.CoNat
import qualified Prelude
import qualified Control.Applicative as Hask
import Control.Category.Constrained.Prelude hiding ((^))
import Control.Arrow.Constrained
import Control.Monad.Constrained
import Data.Foldable.Constrained
import GHC.Exts (Constraint)
class (PseudoAffine m, LSpace (Needle m)) => Manifold m where
boundarylessWitness :: BoundarylessWitness m
default boundarylessWitness :: (m ~ Interior m) => BoundarylessWitness m
boundarylessWitness = BoundarylessWitness
instance (PseudoAffine m, LSpace (Needle m), Interior m ~ m) => Manifold m
class ( Semimanifold x, Semimanifold ξ, LSpace (Needle x), LSpace (Needle ξ)
, Scalar (Needle x) ~ Scalar (Needle ξ) )
=> LocallyCoercible x ξ where
locallyTrivialDiffeomorphism :: x -> ξ
coerceNeedle :: Functor p (->) (->) => p (x,ξ) -> (Needle x -+> Needle ξ)
coerceNeedle' :: Functor p (->) (->) => p (x,ξ) -> (Needle' x -+> Needle' ξ)
oppositeLocalCoercion :: CanonicalDiffeomorphism ξ x
default oppositeLocalCoercion :: LocallyCoercible ξ x => CanonicalDiffeomorphism ξ x
oppositeLocalCoercion = CanonicalDiffeomorphism
interiorLocalCoercion :: Functor p (->) (->)
=> p (x,ξ) -> CanonicalDiffeomorphism (Interior x) (Interior ξ)
default interiorLocalCoercion :: LocallyCoercible (Interior x) (Interior ξ)
=> p (x,ξ) -> CanonicalDiffeomorphism (Interior x) (Interior ξ)
interiorLocalCoercion _ = CanonicalDiffeomorphism
#define identityCoercion(c,t) \
instance (c) => LocallyCoercible (t) (t) where { \
locallyTrivialDiffeomorphism = id; \
coerceNeedle _ = id; \
coerceNeedle' _ = id; \
oppositeLocalCoercion = CanonicalDiffeomorphism; \
interiorLocalCoercion _ = CanonicalDiffeomorphism }
identityCoercion(NumberManifold s, ZeroDim s)
identityCoercion(NumberManifold s, V0 s)
identityCoercion((), ℝ)
identityCoercion(NumberManifold s, V1 s)
identityCoercion((), (ℝ,ℝ))
identityCoercion(NumberManifold s, V2 s)
identityCoercion((), (ℝ,(ℝ,ℝ)))
identityCoercion((), ((ℝ,ℝ),ℝ))
identityCoercion(NumberManifold s, V3 s)
identityCoercion(NumberManifold s, V4 s)
data CanonicalDiffeomorphism a b where
CanonicalDiffeomorphism :: LocallyCoercible a b => CanonicalDiffeomorphism a b
newtype Local x = Local { getLocalOffset :: Needle x }
deriving instance (Show (Needle x)) => Show (Local x)
type LocallyScalable s x = ( PseudoAffine x
, LSpace (Needle x)
, s ~ Scalar (Needle x)
, s ~ Scalar (Needle' x)
, Num' s )
type LocalLinear x y = LinearMap (Scalar (Needle x)) (Needle x) (Needle y)
type LocalAffine x y = (Needle y, LocalLinear x y)
type LinearManifold x = ( AffineManifold x, Needle x ~ x, LSpace x )
type LinearManifold' x = ( PseudoAffine x, AffineSpace x, Diff x ~ x
, Interior x ~ x, Needle x ~ x, LSpace x )
type WithField s c x = ( c x, s ~ Scalar (Needle x), s ~ Scalar (Needle' x) )
type RealDimension r = ( PseudoAffine r, Interior r ~ r, Needle r ~ r, r ~ ℝ)
type AffineManifold m = ( PseudoAffine m, Interior m ~ m, AffineSpace m
, Needle m ~ Diff m, LinearManifold' (Diff m) )
type HilbertManifold x = ( LinearManifold x, InnerSpace x
, Interior x ~ x, Needle x ~ x, DualVector x ~ x
, Floating (Scalar x) )
type EuclidSpace x = ( AffineManifold x, InnerSpace (Diff x)
, DualVector (Diff x) ~ Diff x, Floating (Scalar (Diff x)) )
type NumberManifold n = ( Num' n, Manifold n, Interior n ~ n, Needle n ~ n
, LSpace n, DualVector n ~ n, Scalar n ~ n )
euclideanMetric :: EuclidSpace x => proxy x -> Metric x
euclideanMetric _ = euclideanNorm
type Needle' x = DualVector (Needle x)
type Metric x = Norm (Needle x)
type Metric' x = Variance (Needle x)
type RieMetric x = x -> Metric x
type RieMetric' x = x -> Metric' x
coerceMetric :: ∀ x ξ . (LocallyCoercible x ξ, LSpace (Needle ξ))
=> RieMetric ξ -> RieMetric x
coerceMetric = case ( dualSpaceWitness :: DualNeedleWitness x
, dualSpaceWitness :: DualNeedleWitness ξ ) of
(DualSpaceWitness, DualSpaceWitness)
-> \m x -> case m $ locallyTrivialDiffeomorphism x of
Norm sc -> Norm $ bw . sc . fw
where fw = coerceNeedle ([]::[(x,ξ)])
bw = case oppositeLocalCoercion :: CanonicalDiffeomorphism ξ x of
CanonicalDiffeomorphism -> coerceNeedle' ([]::[(ξ,x)])
coerceMetric' :: ∀ x ξ . (LocallyCoercible x ξ, LSpace (Needle ξ))
=> RieMetric' ξ -> RieMetric' x
coerceMetric' = case ( dualSpaceWitness :: DualNeedleWitness x
, dualSpaceWitness :: DualNeedleWitness ξ ) of
(DualSpaceWitness, DualSpaceWitness)
-> \m x -> case m $ locallyTrivialDiffeomorphism x of
Norm sc -> Norm $ bw . sc . fw
where fw = coerceNeedle' ([]::[(x,ξ)])
bw = case oppositeLocalCoercion :: CanonicalDiffeomorphism ξ x of
CanonicalDiffeomorphism -> coerceNeedle ([]::[(ξ,x)])
hugeℝVal :: ℝ
hugeℝVal = 1e+100
#define deriveAffine(c,t) \
instance (c) => Semimanifold (t) where { \
type Needle (t) = Diff (t); \
fromInterior = id; \
toInterior = pure; \
translateP = Tagged (.+^); \
(.+~^) = (.+^) }; \
instance (c) => PseudoAffine (t) where { \
a.-~.b = pure (a.-.b); }
deriveAffine(KnownNat n, FreeVect n ℝ)
instance (NumberManifold s) => LocallyCoercible (ZeroDim s) (V0 s) where
locallyTrivialDiffeomorphism Origin = V0
coerceNeedle _ = LinearFunction $ \Origin -> V0
coerceNeedle' _ = LinearFunction $ \Origin -> V0
instance (NumberManifold s) => LocallyCoercible (V0 s) (ZeroDim s) where
locallyTrivialDiffeomorphism V0 = Origin
coerceNeedle _ = LinearFunction $ \V0 -> Origin
coerceNeedle' _ = LinearFunction $ \V0 -> Origin
instance LocallyCoercible ℝ (V1 ℝ) where
locallyTrivialDiffeomorphism = V1
coerceNeedle _ = LinearFunction V1
coerceNeedle' _ = LinearFunction V1
instance LocallyCoercible (V1 ℝ) ℝ where
locallyTrivialDiffeomorphism (V1 n) = n
coerceNeedle _ = LinearFunction $ \(V1 n) -> n
coerceNeedle' _ = LinearFunction $ \(V1 n) -> n
instance LocallyCoercible (ℝ,ℝ) (V2 ℝ) where
locallyTrivialDiffeomorphism = uncurry V2
coerceNeedle _ = LinearFunction $ uncurry V2
coerceNeedle' _ = LinearFunction $ uncurry V2
instance LocallyCoercible (V2 ℝ) (ℝ,ℝ) where
locallyTrivialDiffeomorphism (V2 x y) = (x,y)
coerceNeedle _ = LinearFunction $ \(V2 x y) -> (x,y)
coerceNeedle' _ = LinearFunction $ \(V2 x y) -> (x,y)
instance LocallyCoercible ((ℝ,ℝ),ℝ) (V3 ℝ) where
locallyTrivialDiffeomorphism ((x,y),z) = V3 x y z
coerceNeedle _ = LinearFunction $ \((x,y),z) -> V3 x y z
coerceNeedle' _ = LinearFunction $ \((x,y),z) -> V3 x y z
instance LocallyCoercible (ℝ,(ℝ,ℝ)) (V3 ℝ) where
locallyTrivialDiffeomorphism (x,(y,z)) = V3 x y z
coerceNeedle _ = LinearFunction $ \(x,(y,z)) -> V3 x y z
coerceNeedle' _ = LinearFunction $ \(x,(y,z)) -> V3 x y z
instance LocallyCoercible (V3 ℝ) ((ℝ,ℝ),ℝ) where
locallyTrivialDiffeomorphism (V3 x y z) = ((x,y),z)
coerceNeedle _ = LinearFunction $ \(V3 x y z) -> ((x,y),z)
coerceNeedle' _ = LinearFunction $ \(V3 x y z) -> ((x,y),z)
instance LocallyCoercible (V3 ℝ) (ℝ,(ℝ,ℝ)) where
locallyTrivialDiffeomorphism (V3 x y z) = (x,(y,z))
coerceNeedle _ = LinearFunction $ \(V3 x y z) -> (x,(y,z))
coerceNeedle' _ = LinearFunction $ \(V3 x y z) -> (x,(y,z))
instance LocallyCoercible ((ℝ,ℝ),(ℝ,ℝ)) (V4 ℝ) where
locallyTrivialDiffeomorphism ((x,y),(z,w)) = V4 x y z w
coerceNeedle _ = LinearFunction $ \((x,y),(z,w)) -> V4 x y z w
coerceNeedle' _ = LinearFunction $ \((x,y),(z,w)) -> V4 x y z w
instance LocallyCoercible (V4 ℝ) ((ℝ,ℝ),(ℝ,ℝ)) where
locallyTrivialDiffeomorphism (V4 x y z w) = ((x,y),(z,w))
coerceNeedle _ = LinearFunction $ \(V4 x y z w) -> ((x,y),(z,w))
coerceNeedle' _ = LinearFunction $ \(V4 x y z w) -> ((x,y),(z,w))
instance ( Semimanifold a, Semimanifold b, Semimanifold c
, LSpace (Needle a), LSpace (Needle b), LSpace (Needle c)
, Scalar (Needle a) ~ Scalar (Needle b), Scalar (Needle b) ~ Scalar (Needle c)
, Scalar (Needle' a) ~ Scalar (Needle a), Scalar (Needle' b) ~ Scalar (Needle b)
, Scalar (Needle' c) ~ Scalar (Needle c) )
=> LocallyCoercible (a,(b,c)) ((a,b),c) where
locallyTrivialDiffeomorphism = regroup
coerceNeedle _ = regroup
coerceNeedle' _ = regroup
oppositeLocalCoercion = CanonicalDiffeomorphism
interiorLocalCoercion _ = case ( semimanifoldWitness :: SemimanifoldWitness a
, semimanifoldWitness :: SemimanifoldWitness b
, semimanifoldWitness :: SemimanifoldWitness c ) of
( SemimanifoldWitness BoundarylessWitness
,SemimanifoldWitness BoundarylessWitness
,SemimanifoldWitness BoundarylessWitness )
-> CanonicalDiffeomorphism
instance ∀ a b c .
( Semimanifold a, Semimanifold b, Semimanifold c
, LSpace (Needle a), LSpace (Needle b), LSpace (Needle c)
, Scalar (Needle a) ~ Scalar (Needle b), Scalar (Needle b) ~ Scalar (Needle c)
, Scalar (Needle' a) ~ Scalar (Needle a), Scalar (Needle' b) ~ Scalar (Needle b)
, Scalar (Needle' c) ~ Scalar (Needle c) )
=> LocallyCoercible ((a,b),c) (a,(b,c)) where
locallyTrivialDiffeomorphism = regroup'
coerceNeedle _ = regroup'
coerceNeedle' _ = regroup'
oppositeLocalCoercion = CanonicalDiffeomorphism
interiorLocalCoercion _ = case ( semimanifoldWitness :: SemimanifoldWitness a
, semimanifoldWitness :: SemimanifoldWitness b
, semimanifoldWitness :: SemimanifoldWitness c ) of
( SemimanifoldWitness BoundarylessWitness
,SemimanifoldWitness BoundarylessWitness
,SemimanifoldWitness BoundarylessWitness )
-> CanonicalDiffeomorphism
instance LinearManifold (a n) => Semimanifold (LinAff.Point a n) where
type Needle (LinAff.Point a n) = a n
fromInterior = id
toInterior = pure
LinAff.P v .+~^ w = LinAff.P $ v ^+^ w
translateP = Tagged $ \(LinAff.P v) w -> LinAff.P $ v ^+^ w
instance LinearManifold (a n) => PseudoAffine (LinAff.Point a n) where
LinAff.P v .-~. LinAff.P w = return $ v ^-^ w
instance Semimanifold S² where
type Needle S² = ℝ²
fromInterior = id
toInterior = pure
translateP = Tagged (.+~^)
S² ϑ₀ φ₀ .+~^ δv
| ϑ₀ < pi/2 = sphereFold PositiveHalfSphere $ ϑ₀*^embed(S¹ φ₀) ^+^ δv
| otherwise = sphereFold NegativeHalfSphere $ (piϑ₀)*^embed(S¹ φ₀) ^+^ δv
instance PseudoAffine S² where
S² ϑ₁ φ₁ .-~. S² ϑ₀ φ₀
| ϑ₀ < pi/2 = pure ( ϑ₁*^embed(S¹ φ₁) ^-^ ϑ₀*^embed(S¹ φ₀) )
| otherwise = pure ( (piϑ₁)*^embed(S¹ φ₁) ^-^ (piϑ₀)*^embed(S¹ φ₀) )
sphereFold :: S⁰ -> ℝ² -> S²
sphereFold hfSphere v
| ϑ₀ > pi = S² (inv $ tau ϑ₀) (toS¹range $ φ₀+pi)
| otherwise = S² (inv ϑ₀) φ₀
where S¹ φ₀ = coEmbed v
ϑ₀ = magnitude v `mod'` tau
inv ϑ = case hfSphere of PositiveHalfSphere -> ϑ
NegativeHalfSphere -> pi ϑ
instance Semimanifold ℝP² where
type Needle ℝP² = ℝ²
fromInterior = id
toInterior = pure
translateP = Tagged (.+~^)
ℝP² r₀ φ₀ .+~^ V2 δr δφ
| r₀ > 1/2 = case r₀ + δr of
r₁ | r₁ > 1 -> ℝP² (2r₁) (toS¹range $ φ₀+δφ+pi)
| otherwise -> ℝP² r₁ (toS¹range $ φ₀+δφ)
ℝP² r₀ φ₀ .+~^ δxy = let v = r₀*^embed(S¹ φ₀) ^+^ δxy
S¹ φ₁ = coEmbed v
r₁ = magnitude v `mod'` 1
in ℝP² r₁ φ₁
instance PseudoAffine ℝP² where
ℝP² r₁ φ₁ .-~. ℝP² r₀ φ₀
| r₀ > 1/2 = pure `id` case φ₁φ₀ of
δφ | δφ > 3*pi/2 -> V2 ( r₁ r₀) (δφ 2*pi)
| δφ < 3*pi/2 -> V2 ( r₁ r₀) (δφ + 2*pi)
| δφ > pi/2 -> V2 (2r₁ r₀) (δφ pi )
| δφ < pi/2 -> V2 (2r₁ r₀) (δφ + pi )
| otherwise -> V2 ( r₁ r₀) (δφ )
| otherwise = pure ( r₁*^embed(S¹ φ₁) ^-^ r₀*^embed(S¹ φ₀) )
class ImpliesMetric s where
type MetricRequirement s x :: Constraint
type MetricRequirement s x = Semimanifold x
inferMetric :: (MetricRequirement s x, LSpace (Needle x))
=> s x -> Metric x
inferMetric' :: (MetricRequirement s x, LSpace (Needle x))
=> s x -> Metric' x
instance ImpliesMetric Norm where
type MetricRequirement Norm x = (SimpleSpace x, x ~ Needle x)
inferMetric = id
inferMetric' = dualNorm
type DualNeedleWitness x = DualSpaceWitness (Needle x)