-- |
-- Module      : Data.Manifold.Cone
-- Copyright   : (c) Justus Sagemüller 2015
-- License     : GPL v3
-- 
-- Maintainer  : (@) jsag $ hvl.no
-- Stability   : experimental
-- Portability : portable
-- 

{-# LANGUAGE FlexibleInstances        #-}
{-# LANGUAGE UndecidableInstances     #-}
{-# LANGUAGE TypeFamilies             #-}
{-# LANGUAGE FunctionalDependencies   #-}
{-# LANGUAGE FlexibleContexts         #-}
{-# LANGUAGE LiberalTypeSynonyms      #-}
{-# LANGUAGE GADTs                    #-}
{-# LANGUAGE RankNTypes               #-}
{-# LANGUAGE TupleSections            #-}
{-# LANGUAGE ConstraintKinds          #-}
{-# LANGUAGE PatternGuards            #-}
{-# LANGUAGE EmptyCase                #-}
{-# LANGUAGE TypeOperators            #-}
{-# LANGUAGE UnicodeSyntax            #-}
{-# LANGUAGE MultiWayIf               #-}
{-# LANGUAGE ScopedTypeVariables      #-}
{-# LANGUAGE RecordWildCards          #-}
{-# LANGUAGE CPP                      #-}


module Data.Manifold.Cone where
    


import qualified Data.Vector.Generic as Arr
import Data.Maybe

import Data.VectorSpace
import Data.Tagged
import Data.Manifold.Types.Primitive
import Math.Manifold.Core.Types
import Data.Manifold.WithBoundary
import Data.Manifold.Types.Stiefel
import Math.LinearMap.Category

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 Data.Manifold.PseudoAffine

import Data.Kind (Type)



instance SemimanifoldWithBoundary (CD¹ ℝ⁰) where
  type Interior (CD¹ ℝ⁰) = ℝ
  type Boundary (CD¹ ℝ⁰) = S⁰
  type HalfNeedle (CD¹ ℝ⁰) = ℝay
  smfdWBoundWitness :: SmfdWBoundWitness (CD¹ ℝ⁰)
smfdWBoundWitness = SmfdWBoundWitness (CD¹ ℝ⁰)
forall m.
(OpenManifold (Interior m), OpenManifold (Boundary m),
 FullSubspace (HalfNeedle m) ~ Needle (Boundary m)) =>
SmfdWBoundWitness m
SmfdWBoundWitness
  fromInterior :: Interior (CD¹ ℝ⁰) -> CD¹ ℝ⁰
fromInterior Interior (CD¹ ℝ⁰)
l = Scalar (Needle ℝ⁰) -> ℝ⁰ -> CD¹ ℝ⁰
forall x. Scalar (Needle x) -> x -> CD¹ x
CD¹ (Double -> Double
forall r. RealFloat r => r -> r
bijectℝtoIntvplus Double
Interior (CD¹ ℝ⁰)
l) ℝ⁰
forall s. ZeroDim s
Origin
  separateInterior :: CD¹ ℝ⁰ -> Either (Boundary (CD¹ ℝ⁰)) (Interior (CD¹ ℝ⁰))
separateInterior (CD¹ Scalar (Needle ℝ⁰)
0 ℝ⁰
Origin) = S⁰_ Double -> Either (S⁰_ Double) Double
forall a b. a -> Either a b
Left S⁰_ Double
forall r. S⁰_ r
NegativeHalfSphere
  separateInterior (CD¹ Scalar (Needle ℝ⁰)
1 ℝ⁰
Origin) = S⁰_ Double -> Either (S⁰_ Double) Double
forall a b. a -> Either a b
Left S⁰_ Double
forall r. S⁰_ r
PositiveHalfSphere
  separateInterior (CD¹ Scalar (Needle ℝ⁰)
ρ ℝ⁰
Origin) = Double -> Either (S⁰_ Double) Double
forall a b. b -> Either a b
Right (Double -> Either (S⁰_ Double) Double)
-> Double -> Either (S⁰_ Double) Double
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Double -> Double
forall r. RealFloat r => r -> r
bijectIntvplustoℝ Double
Scalar (Needle ℝ⁰)
ρ
  Boundary (CD¹ ℝ⁰)
NegativeHalfSphere |+^ :: Boundary (CD¹ ℝ⁰) -> HalfNeedle (CD¹ ℝ⁰) -> CD¹ ℝ⁰
|+^ Cℝay a Origin = Scalar (Needle ℝ⁰) -> ℝ⁰ -> CD¹ ℝ⁰
forall x. Scalar (Needle x) -> x -> CD¹ x
CD¹ (Double -> Double
forall r. RealFloat r => r -> r
bijectℝplustoIntv Double
Scalar (Needle ℝ⁰)
a) ℝ⁰
forall s. ZeroDim s
Origin
  extendToBoundary :: Interior (CD¹ ℝ⁰)
-> Needle (Interior (CD¹ ℝ⁰)) -> Maybe (Boundary (CD¹ ℝ⁰))
extendToBoundary Interior (CD¹ ℝ⁰)
l Needle (Interior (CD¹ ℝ⁰))
a
   | Double
Needle (Interior (CD¹ ℝ⁰))
aDouble -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<Double
0        = S⁰_ Double -> Maybe (S⁰_ Double)
forall a. a -> Maybe a
Just S⁰_ Double
forall r. S⁰_ r
NegativeHalfSphere
   | Double
Needle (Interior (CD¹ ℝ⁰))
aDouble -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>Double
0        = S⁰_ Double -> Maybe (S⁰_ Double)
forall a. a -> Maybe a
Just S⁰_ Double
forall r. S⁰_ r
PositiveHalfSphere
   | Bool
otherwise  = Maybe (Boundary (CD¹ ℝ⁰))
forall a. Maybe a
Nothing

instance SemimanifoldWithBoundary ℝay where
  type Interior ℝay = ℝ
  type Boundary ℝay = ℝ⁰
  type HalfNeedle ℝay = ℝay
  Cℝay Scalar (Needle ℝ⁰)
ρ ℝ⁰
Origin .+^| :: ℝay
-> Needle (Interior ℝay)
-> Either
     (Boundary ℝay, Scalar (Needle (Interior ℝay))) (Interior ℝay)
.+^| Needle (Interior ℝay)
w
   | Double
Scalar (Needle ℝ⁰)
ρ Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>= -Double
Needle (Interior ℝay)
w    = Double -> Either (ℝ⁰, Double) Double
forall a b. b -> Either a b
Right (Double -> Either (ℝ⁰, Double) Double)
-> Double -> Either (ℝ⁰, Double) Double
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Double
Scalar (Needle ℝ⁰)
ρDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
Needle (Interior ℝay)
w
   | Bool
otherwise  = (ℝ⁰, Double) -> Either (ℝ⁰, Double) Double
forall a b. a -> Either a b
Left (ℝ⁰
forall s. ZeroDim s
Origin, (Double
Scalar (Needle ℝ⁰)
ρDouble -> Double -> Double
forall a. Num a => a -> a -> a
+Double
Needle (Interior ℝay)
w)Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/Double
Needle (Interior ℝay)
w)
  fromInterior :: Interior ℝay -> ℝay
fromInterior Interior ℝay
l = Scalar (Needle ℝ⁰) -> ℝ⁰ -> ℝay
forall x. Scalar (Needle x) -> x -> Cℝay x
Cℝay (Double -> Double
forall r. RealFloat r => r -> r
bijectℝtoℝplus Double
Interior ℝay
l) ℝ⁰
forall s. ZeroDim s
Origin
  fromBoundary :: Boundary ℝay -> ℝay
fromBoundary Boundary ℝay
Origin = Scalar (Needle ℝ⁰) -> ℝ⁰ -> ℝay
forall x. Scalar (Needle x) -> x -> Cℝay x
Cℝay Scalar (Needle ℝ⁰)
0 ℝ⁰
forall s. ZeroDim s
Origin
  separateInterior :: ℝay -> Either (Boundary ℝay) (Interior ℝay)
separateInterior (Cℝay Scalar (Needle ℝ⁰)
ρ ℝ⁰
Origin)
   | Double
Scalar (Needle ℝ⁰)
ρDouble -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>Double
0        = Double -> Either ℝ⁰ Double
forall a b. b -> Either a b
Right (Double -> Either ℝ⁰ Double) -> Double -> Either ℝ⁰ Double
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Double -> Double
forall r. RealFloat r => r -> r
bijectℝplustoℝ Double
Scalar (Needle ℝ⁰)
ρ
   | Bool
otherwise  = ℝ⁰ -> Either ℝ⁰ Double
forall a b. a -> Either a b
Left ℝ⁰
forall s. ZeroDim s
Origin
  Boundary ℝay
Origin |+^ :: Boundary ℝay -> HalfNeedle ℝay -> ℝay
|+^ HalfNeedle ℝay
a = ℝay
HalfNeedle ℝay
a
  extendToBoundary :: Interior ℝay -> Needle (Interior ℝay) -> Maybe (Boundary ℝay)
extendToBoundary Interior ℝay
l Needle (Interior ℝay)
a
   | Double
Needle (Interior ℝay)
aDouble -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<Double
0        = ℝ⁰ -> Maybe ℝ⁰
forall a. a -> Maybe a
Just ℝ⁰
forall s. ZeroDim s
Origin
   | Bool
otherwise  = Maybe (Boundary ℝay)
forall a. Maybe a
Nothing

instance SemimanifoldWithBoundary (Cℝay S⁰) where
  type Interior (Cℝay S⁰) = ℝ
  type Boundary (Cℝay S⁰) = EmptyMfd ℝ⁰
  type HalfNeedle (Cℝay S⁰) = ℝay
  fromInterior :: Interior (Cℝay (S⁰_ Double)) -> Cℝay (S⁰_ Double)
fromInterior Interior (Cℝay (S⁰_ Double))
l
   | Double
Interior (Cℝay (S⁰_ Double))
lDouble -> Double -> Bool
forall a. Ord a => a -> a -> Bool
<Double
0        = Scalar (Needle (S⁰_ Double)) -> S⁰_ Double -> Cℝay (S⁰_ Double)
forall x. Scalar (Needle x) -> x -> Cℝay x
Cℝay Scalar (Needle (S⁰_ Double))
Interior (Cℝay (S⁰_ Double))
l S⁰_ Double
forall r. S⁰_ r
PositiveHalfSphere
   | Bool
otherwise  = Scalar (Needle (S⁰_ Double)) -> S⁰_ Double -> Cℝay (S⁰_ Double)
forall x. Scalar (Needle x) -> x -> Cℝay x
Cℝay (-Double
Interior (Cℝay (S⁰_ Double))
l) S⁰_ Double
forall r. S⁰_ r
NegativeHalfSphere
  separateInterior :: Cℝay (S⁰_ Double)
-> Either
     (Boundary (Cℝay (S⁰_ Double))) (Interior (Cℝay (S⁰_ Double)))
separateInterior (Cℝay Scalar (Needle (S⁰_ Double))
ρ S⁰_ Double
PositiveHalfSphere) = Double -> Either (EmptyMfd ℝ⁰) Double
forall a b. b -> Either a b
Right Double
Scalar (Needle (S⁰_ Double))
ρ
  separateInterior (Cℝay Scalar (Needle (S⁰_ Double))
ρ S⁰_ Double
NegativeHalfSphere) = Double -> Either (EmptyMfd ℝ⁰) Double
forall a b. b -> Either a b
Right (Double -> Either (EmptyMfd ℝ⁰) Double)
-> Double -> Either (EmptyMfd ℝ⁰) Double
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ -Double
Scalar (Needle (S⁰_ Double))
ρ
  Boundary (Cℝay (S⁰_ Double))
b |+^ :: Boundary (Cℝay (S⁰_ Double))
-> HalfNeedle (Cℝay (S⁰_ Double)) -> Cℝay (S⁰_ Double)
|+^ HalfNeedle (Cℝay (S⁰_ Double))
_ = case Boundary (Cℝay (S⁰_ Double))
b of {}
  extendToBoundary :: Interior (Cℝay (S⁰_ Double))
-> Needle (Interior (Cℝay (S⁰_ Double)))
-> Maybe (Boundary (Cℝay (S⁰_ Double)))
extendToBoundary Interior (Cℝay (S⁰_ Double))
_ Needle (Interior (Cℝay (S⁰_ Double)))
_ = Maybe (Boundary (Cℝay (S⁰_ Double)))
forall a. Maybe a
Nothing 




                                      




-- Some essential homeomorphisms
bijectℝtoℝplus      , bijectℝplustoℝ
 , bijectIntvtoℝplus, bijectℝplustoIntv
 ,     bijectIntvtoℝ, bijectℝtoIntv
 , bijectIntvplustoℝ, bijectℝtoIntvplus
               :: RealFloat r => r -> r

bijectℝplustoℝ :: r -> r
bijectℝplustoℝ r
x = r
x r -> r -> r
forall a. Num a => a -> a -> a
- r
1r -> r -> r
forall a. Fractional a => a -> a -> a
/r
x
bijectℝtoℝplus :: r -> r
bijectℝtoℝplus r
y = r
yr -> r -> r
forall a. Fractional a => a -> a -> a
/r
2 r -> r -> r
forall a. Num a => a -> a -> a
+ r -> r
forall a. Floating a => a -> a
sqrt(r
yr -> Int -> r
forall a. Num a => a -> Int -> a
^Int
2r -> r -> r
forall a. Fractional a => a -> a -> a
/r
4 r -> r -> r
forall a. Num a => a -> a -> a
+ r
1)

-- [0, 1[ ↔ ℝ⁺
bijectℝplustoIntv :: r -> r
bijectℝplustoIntv r
y = r
1 r -> r -> r
forall a. Num a => a -> a -> a
- r -> r
forall a. Fractional a => a -> a
recip (r
yr -> r -> r
forall a. Num a => a -> a -> a
+r
1)
bijectIntvtoℝplus :: r -> r
bijectIntvtoℝplus r
x = r -> r
forall a. Fractional a => a -> a
recip(r
1r -> r -> r
forall a. Num a => a -> a -> a
-r
x) r -> r -> r
forall a. Num a => a -> a -> a
- r
1

-- ]-1, 1[ ↔ ℝ  (Similar to 'tanh', but converges less quickly towards ±1.)
bijectℝtoIntv :: r -> r
bijectℝtoIntv r
y | r
yr -> r -> Bool
forall a. Ord a => a -> a -> Bool
>r
0        = -r
1r -> r -> r
forall a. Fractional a => a -> a -> a
/(r
2r -> r -> r
forall a. Num a => a -> a -> a
*r
y) r -> r -> r
forall a. Num a => a -> a -> a
+ r -> r
forall a. Floating a => a -> a
sqrt(r
1r -> r -> r
forall a. Fractional a => a -> a -> a
/(r
4r -> r -> r
forall a. Num a => a -> a -> a
*r
yr -> Int -> r
forall a. Num a => a -> Int -> a
^Int
2) r -> r -> r
forall a. Num a => a -> a -> a
+ r
1)
                | r
yr -> r -> Bool
forall a. Ord a => a -> a -> Bool
<r
0        = -r
1r -> r -> r
forall a. Fractional a => a -> a -> a
/(r
2r -> r -> r
forall a. Num a => a -> a -> a
*r
y) r -> r -> r
forall a. Num a => a -> a -> a
- r -> r
forall a. Floating a => a -> a
sqrt(r
1r -> r -> r
forall a. Fractional a => a -> a -> a
/(r
4r -> r -> r
forall a. Num a => a -> a -> a
*r
yr -> Int -> r
forall a. Num a => a -> Int -> a
^Int
2) r -> r -> r
forall a. Num a => a -> a -> a
+ r
1)
                | Bool
otherwise  = r
0
                 -- 0 = x² + x/y - 1
                 -- x = -1/2y ± sqrt(1/4y² + 1)
bijectIntvtoℝ :: r -> r
bijectIntvtoℝ r
x = r
x r -> r -> r
forall a. Fractional a => a -> a -> a
/ (r
1r -> r -> r
forall a. Num a => a -> a -> a
-r
xr -> Int -> r
forall a. Num a => a -> Int -> a
^Int
2)

-- ]0, 1[ ↔ ℝ
bijectℝtoIntvplus :: r -> r
bijectℝtoIntvplus r
y = (r -> r
forall r. RealFloat r => r -> r
bijectℝtoIntv r
y r -> r -> r
forall a. Num a => a -> a -> a
+ r
1)r -> r -> r
forall a. Fractional a => a -> a -> a
/r
2
bijectIntvplustoℝ :: r -> r
bijectIntvplustoℝ r
x = r -> r
forall r. RealFloat r => r -> r
bijectIntvtoℝ (r -> r) -> r -> r
forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ r
xr -> r -> r
forall a. Num a => a -> a -> a
*r
2 r -> r -> r
forall a. Num a => a -> a -> a
- r
1

embCℝayToCD¹ :: RealFloat (Scalar (Needle m)) => Cℝay m -> CD¹ m
embCℝayToCD¹ :: Cℝay m -> CD¹ m
embCℝayToCD¹ (Cℝay Scalar (Needle m)
h m
m) = Scalar (Needle m) -> m -> CD¹ m
forall x. Scalar (Needle x) -> x -> CD¹ x
CD¹ (Scalar (Needle m) -> Scalar (Needle m)
forall r. RealFloat r => r -> r
bijectℝplustoIntv Scalar (Needle m)
h) m
m

projCD¹ToCℝay :: RealFloat (Scalar (Needle m)) => CD¹ m -> Cℝay m
projCD¹ToCℝay :: CD¹ m -> Cℝay m
projCD¹ToCℝay (CD¹ Scalar (Needle m)
h m
m) = Scalar (Needle m) -> m -> Cℝay m
forall x. Scalar (Needle x) -> x -> Cℝay x
Cℝay (Scalar (Needle m) -> Scalar (Needle m)
forall r. RealFloat r => r -> r
bijectIntvtoℝplus Scalar (Needle m)
h) m
m


stiefel1Project :: LinearSpace v =>
             DualVector v       -- ^ Must be nonzero.
                 -> Stiefel1 v
stiefel1Project :: DualVector v -> Stiefel1 v
stiefel1Project = DualVector v -> Stiefel1 v
forall v. DualVector v -> Stiefel1 v
Stiefel1

stiefel1Embed :: (HilbertSpace v, RealFloat (Scalar v)) => Stiefel1 v -> v
stiefel1Embed :: Stiefel1 v -> v
stiefel1Embed (Stiefel1 DualVector v
n) = v -> v
forall v s. (InnerSpace v, s ~ Scalar v, Floating s) => v -> v
normalized v
DualVector v
n
  

class (PseudoAffine v, InnerSpace v, NaturallyEmbedded (UnitSphere v) (DualVector v))
          => HasUnitSphere v where
  type UnitSphere v :: *
  stiefel :: UnitSphere v -> Stiefel1 v
  stiefel = DualVector v -> Stiefel1 v
forall v. DualVector v -> Stiefel1 v
Stiefel1 (DualVector v -> Stiefel1 v)
-> (UnitSphere v -> DualVector v) -> UnitSphere v -> Stiefel1 v
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
. UnitSphere v -> DualVector v
forall m v. NaturallyEmbedded m v => m -> v
embed
  unstiefel :: Stiefel1 v -> UnitSphere v
  unstiefel = DualVector v -> UnitSphere v
forall m v. NaturallyEmbedded m v => v -> m
coEmbed (DualVector v -> UnitSphere v)
-> (Stiefel1 v -> DualVector v) -> Stiefel1 v -> UnitSphere v
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
. Stiefel1 v -> DualVector v
forall v. Stiefel1 v -> DualVector v
getStiefel1N

instance HasUnitSphere ℝ  where type UnitSphere ℝ  = S⁰

instance HasUnitSphere ℝ² where type UnitSphere ℝ² = S¹

instance HasUnitSphere ℝ³ where type UnitSphere ℝ³ = S²