module Math.Manifold.Core.PseudoAffine where
import Data.VectorSpace
import Data.AffineSpace
import Data.Tagged
import Data.Fixed (mod')
import Math.Manifold.Core.Types
import Math.Manifold.VectorSpace.ZeroDimensional
import Control.Applicative
data BoundarylessWitness m where
BoundarylessWitness :: (Semimanifold m, Interior m ~ m)
=> BoundarylessWitness m
data SemimanifoldWitness x where
SemimanifoldWitness ::
( Semimanifold (Needle x), Needle (Interior x) ~ Needle x
, Needle (Needle x) ~ Needle x
, Interior (Needle x) ~ Needle x )
=> BoundarylessWitness (Interior x) -> SemimanifoldWitness x
data PseudoAffineWitness x where
PseudoAffineWitness ::
( PseudoAffine (Interior x), PseudoAffine (Needle x) )
=> SemimanifoldWitness x -> PseudoAffineWitness x
infix 6 .-~., .-~!
infixl 6 .+~^, .-~^
class AdditiveGroup (Needle x) => Semimanifold x where
type Needle x :: *
type Interior x :: *
type Interior x = x
(.+~^) :: Interior x -> Needle x -> x
(.+~^) = addvp
where addvp :: ∀ x . Semimanifold x => Interior x -> Needle x -> x
addvp p = fromInterior . tp p
where (Tagged tp) = translateP :: Tagged x (Interior x -> Needle x -> Interior x)
fromInterior :: Interior x -> x
fromInterior p = p .+~^ zeroV
toInterior :: x -> Maybe (Interior x)
translateP :: Tagged x (Interior x -> Needle x -> Interior x)
(.-~^) :: Interior x -> Needle x -> x
p .-~^ v = p .+~^ negateV v
semimanifoldWitness :: SemimanifoldWitness x
default semimanifoldWitness ::
( Semimanifold (Interior x), Semimanifold (Needle x)
, Interior (Interior x) ~ Interior x, Needle (Interior x) ~ Needle x
, Needle (Needle x) ~ Needle x
, Interior (Needle x) ~ Needle x )
=> SemimanifoldWitness x
semimanifoldWitness = SemimanifoldWitness BoundarylessWitness
class Semimanifold x => PseudoAffine x where
(.-~.) :: x -> x -> Maybe (Needle x)
p.-~.q = return $ p.-~!q
(.-~!) :: x -> x -> Needle x
p.-~!q = case p.-~.q of
Just v -> v
pseudoAffineWitness :: PseudoAffineWitness x
default pseudoAffineWitness ::
( PseudoAffine (Interior x), PseudoAffine (Needle x) )
=> PseudoAffineWitness x
pseudoAffineWitness = PseudoAffineWitness semimanifoldWitness
palerp :: ∀ x. (PseudoAffine x, VectorSpace (Needle x))
=> x -> x -> Maybe (Scalar (Needle x) -> x)
palerp p₀ p₁ = case (toInterior p₀, p₁.-~.p₀) of
(Just b, Just v) -> return $ \t -> b .+~^ t *^ v
_ -> Nothing
palerpB :: ∀ x. (PseudoAffine x, VectorSpace (Needle x), Scalar (Needle x) ~ ℝ)
=> x -> x -> Maybe (D¹ -> x)
palerpB p₀ p₁ = case (toInterior p₀, p₁.-~.p₀) of
(Just b, Just v) -> return $ \(D¹ t) -> b .+~^ ((t+1)/2) *^ v
_ -> Nothing
alerpB :: ∀ x. (AffineSpace x, VectorSpace (Diff x), Scalar (Diff x) ~ ℝ)
=> x -> x -> D¹ -> x
alerpB p1 p2 = case p2 .-. p1 of
v -> \(D¹ t) -> p1 .+^ ((t+1)/2) *^ v
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((),Double)
deriveAffine((),Rational)
instance Semimanifold (ZeroDim k) where
type Needle (ZeroDim k) = ZeroDim k
fromInterior = id
toInterior = pure
Origin .+~^ Origin = Origin
Origin .-~^ Origin = Origin
translateP = Tagged (.+~^)
instance PseudoAffine (ZeroDim k) where
Origin .-~. Origin = pure Origin
instance ∀ a b . (Semimanifold a, Semimanifold b) => Semimanifold (a,b) where
type Needle (a,b) = (Needle a, Needle b)
type Interior (a,b) = (Interior a, Interior b)
(a,b).+~^(v,w) = (a.+~^v, b.+~^w)
(a,b).-~^(v,w) = (a.-~^v, b.-~^w)
fromInterior (i,j) = (fromInterior i, fromInterior j)
toInterior (a,b) = (,) <$> toInterior a <*> toInterior b
translateP = Tagged $ \(a,b) (v,w) -> (ta a v, tb b w)
where Tagged ta = translateP :: Tagged a (Interior a -> Needle a -> Interior a)
Tagged tb = translateP :: Tagged b (Interior b -> Needle b -> Interior b)
semimanifoldWitness = case ( semimanifoldWitness :: SemimanifoldWitness a
, semimanifoldWitness :: SemimanifoldWitness b ) of
(SemimanifoldWitness BoundarylessWitness, SemimanifoldWitness BoundarylessWitness)
-> SemimanifoldWitness BoundarylessWitness
instance (PseudoAffine a, PseudoAffine b) => PseudoAffine (a,b) where
(a,b).-~.(c,d) = liftA2 (,) (a.-~.c) (b.-~.d)
pseudoAffineWitness = case ( pseudoAffineWitness :: PseudoAffineWitness a
, pseudoAffineWitness :: PseudoAffineWitness b ) of
( PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)
, PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) )
->PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)
instance ∀ a b c . (Semimanifold a, Semimanifold b, Semimanifold c)
=> Semimanifold (a,b,c) where
type Needle (a,b,c) = (Needle a, Needle b, Needle c)
type Interior (a,b,c) = (Interior a, Interior b, Interior c)
(a,b,c).+~^(v,w,x) = (a.+~^v, b.+~^w, c.+~^x)
(a,b,c).-~^(v,w,x) = (a.-~^v, b.-~^w, c.-~^x)
fromInterior (i,j,k) = (fromInterior i, fromInterior j, fromInterior k)
toInterior (a,b,c) = liftA3 (,,) (toInterior a) (toInterior b) (toInterior c)
translateP = Tagged $ \(a,b,c) (v,w,x) -> (ta a v, tb b w, tc c x)
where Tagged ta = translateP :: Tagged a (Interior a -> Needle a -> Interior a)
Tagged tb = translateP :: Tagged b (Interior b -> Needle b -> Interior b)
Tagged tc = translateP :: Tagged c (Interior c -> Needle c -> Interior c)
semimanifoldWitness = case ( semimanifoldWitness :: SemimanifoldWitness a
, semimanifoldWitness :: SemimanifoldWitness b
, semimanifoldWitness :: SemimanifoldWitness c ) of
( SemimanifoldWitness BoundarylessWitness
,SemimanifoldWitness BoundarylessWitness
,SemimanifoldWitness BoundarylessWitness )
-> SemimanifoldWitness BoundarylessWitness
instance (PseudoAffine a, PseudoAffine b, PseudoAffine c) => PseudoAffine (a,b,c) where
(a,b,c).-~.(d,e,f) = liftA3 (,,) (a.-~.d) (b.-~.e) (c.-~.f)
pseudoAffineWitness = case ( pseudoAffineWitness :: PseudoAffineWitness a
, pseudoAffineWitness :: PseudoAffineWitness b
, pseudoAffineWitness :: PseudoAffineWitness c ) of
( PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)
, PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)
, PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness) )
->PseudoAffineWitness (SemimanifoldWitness BoundarylessWitness)
instance Semimanifold S⁰ where
type Needle S⁰ = ZeroDim ℝ
fromInterior = id
toInterior = pure
translateP = Tagged (.+~^)
p .+~^ Origin = p
p .-~^ Origin = p
instance PseudoAffine S⁰ where
PositiveHalfSphere .-~. PositiveHalfSphere = pure Origin
NegativeHalfSphere .-~. NegativeHalfSphere = pure Origin
_ .-~. _ = Nothing
instance Semimanifold S¹ where
type Needle S¹ = ℝ
fromInterior = id
toInterior = pure
translateP = Tagged (.+~^)
S¹ φ₀ .+~^ δφ
| φ' < 0 = S¹ $ φ' + tau
| otherwise = S¹ $ φ'
where φ' = toS¹range $ φ₀ + δφ
instance PseudoAffine S¹ where
S¹ φ₁ .-~. S¹ φ₀
| δφ > pi = pure (δφ 2*pi)
| δφ < (pi) = pure (δφ + 2*pi)
| otherwise = pure δφ
where δφ = φ₁ φ₀
instance Semimanifold D¹ where
type Needle D¹ = ℝ
type Interior D¹ = ℝ
fromInterior = D¹ . tanh
toInterior (D¹ x) | abs x < 1 = return $ atanh x
| otherwise = empty
translateP = Tagged (+)
instance PseudoAffine D¹ where
D¹ 1 .-~. _ = empty
D¹ (1) .-~. _ = empty
D¹ x .-~. D¹ y
| abs x < 1, abs y < 1 = return $ atanh x atanh y
| otherwise = empty
tau :: ℝ
tau = 2 * pi
toS¹range :: ℝ -> ℝ
toS¹range φ = (φ+pi)`mod'`tau pi