-- |
-- 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 = 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 = forall x. Scalar (Needle x) -> x -> CD¹ x
CD¹ (forall r. RealFloat r => r -> r
bijectℝtoIntvplus Interior (CD¹ ℝ⁰)
l) forall s. ZeroDim s
Origin
  separateInterior :: CD¹ ℝ⁰ -> Either (Boundary (CD¹ ℝ⁰)) (Interior (CD¹ ℝ⁰))
separateInterior (CD¹ Scalar (Needle ℝ⁰)
0 ℝ⁰
Origin) = forall a b. a -> Either a b
Left forall r. S⁰_ r
NegativeHalfSphere
  separateInterior (CD¹ Scalar (Needle ℝ⁰)
1 ℝ⁰
Origin) = forall a b. a -> Either a b
Left forall r. S⁰_ r
PositiveHalfSphere
  separateInterior (CD¹ Scalar (Needle ℝ⁰)
ρ ℝ⁰
Origin) = 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
$ forall r. RealFloat r => r -> r
bijectIntvplustoℝ Scalar (Needle ℝ⁰)
ρ
  S⁰
Boundary (CD¹ ℝ⁰)
NegativeHalfSphere |+^ :: Boundary (CD¹ ℝ⁰) -> HalfNeedle (CD¹ ℝ⁰) -> CD¹ ℝ⁰
|+^ Cℝay Scalar (Needle ℝ⁰)
a ℝ⁰
Origin = forall x. Scalar (Needle x) -> x -> CD¹ x
CD¹ (forall r. RealFloat r => r -> r
bijectℝplustoIntv 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
   | Needle (Interior (CD¹ ℝ⁰))
aforall a. Ord a => a -> a -> Bool
<ℝ
0        = forall a. a -> Maybe a
Just forall r. S⁰_ r
NegativeHalfSphere
   | Needle (Interior (CD¹ ℝ⁰))
aforall a. Ord a => a -> a -> Bool
>ℝ
0        = forall a. a -> Maybe a
Just forall r. S⁰_ r
PositiveHalfSphere
   | Bool
otherwise  = 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
   | Scalar (Needle ℝ⁰)
ρ forall a. Ord a => a -> a -> Bool
>= -Needle (Interior ℝay)
w    = 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
$ Scalar (Needle ℝ⁰)
ρforall a. Num a => a -> a -> a
+Needle (Interior ℝay)
w
   | Bool
otherwise  = forall a b. a -> Either a b
Left (forall s. ZeroDim s
Origin, (Scalar (Needle ℝ⁰)
ρforall a. Num a => a -> a -> a
+Needle (Interior ℝay)
w)forall a. Fractional a => a -> a -> a
/Needle (Interior ℝay)
w)
  fromInterior :: Interior ℝay -> ℝay
fromInterior Interior ℝay
l = forall x. Scalar (Needle x) -> x -> Cℝay x
Cℝay (forall r. RealFloat r => r -> r
bijectℝtoℝplus Interior ℝay
l) forall s. ZeroDim s
Origin
  fromBoundary :: Boundary ℝay -> ℝay
fromBoundary ℝ⁰
Boundary ℝay
Origin = forall x. Scalar (Needle x) -> x -> Cℝay x
Cℝay ℝ
0 forall s. ZeroDim s
Origin
  separateInterior :: ℝay -> Either (Boundary ℝay) (Interior ℝay)
separateInterior (Cℝay Scalar (Needle ℝ⁰)
ρ ℝ⁰
Origin)
   | Scalar (Needle ℝ⁰)
ρforall a. Ord a => a -> a -> Bool
>ℝ
0        = 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
$ forall r. RealFloat r => r -> r
bijectℝplustoℝ Scalar (Needle ℝ⁰)
ρ
   | Bool
otherwise  = forall a b. a -> Either a b
Left forall s. ZeroDim s
Origin
  ℝ⁰
Boundary ℝay
Origin |+^ :: Boundary ℝay -> HalfNeedle ℝay -> ℝay
|+^ HalfNeedle ℝay
a = HalfNeedle ℝay
a
  extendToBoundary :: Interior ℝay -> Needle (Interior ℝay) -> Maybe (Boundary ℝay)
extendToBoundary Interior ℝay
l Needle (Interior ℝay)
a
   | Needle (Interior ℝay)
aforall a. Ord a => a -> a -> Bool
<ℝ
0        = forall a. a -> Maybe a
Just forall s. ZeroDim s
Origin
   | Bool
otherwise  = 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⁰) -> Cℝay S⁰
fromInterior Interior (Cℝay S⁰)
l
   | Interior (Cℝay S⁰)
lforall a. Ord a => a -> a -> Bool
<ℝ
0        = forall x. Scalar (Needle x) -> x -> Cℝay x
Cℝay Interior (Cℝay S⁰)
l forall r. S⁰_ r
PositiveHalfSphere
   | Bool
otherwise  = forall x. Scalar (Needle x) -> x -> Cℝay x
Cℝay (-Interior (Cℝay S⁰)
l) forall r. S⁰_ r
NegativeHalfSphere
  separateInterior :: Cℝay S⁰ -> Either (Boundary (Cℝay S⁰)) (Interior (Cℝay S⁰))
separateInterior (Cℝay Scalar (Needle S⁰)
ρ S⁰
PositiveHalfSphere) = forall a b. b -> Either a b
Right Scalar (Needle S⁰)
ρ
  separateInterior (Cℝay Scalar (Needle S⁰)
ρ S⁰
NegativeHalfSphere) = 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
$ -Scalar (Needle S⁰)
ρ
  Boundary (Cℝay S⁰)
b |+^ :: Boundary (Cℝay S⁰) -> HalfNeedle (Cℝay S⁰) -> Cℝay S⁰
|+^ HalfNeedle (Cℝay S⁰)
_ = case Boundary (Cℝay S⁰)
b of {}
  extendToBoundary :: Interior (Cℝay S⁰)
-> Needle (Interior (Cℝay S⁰)) -> Maybe (Boundary (Cℝay S⁰))
extendToBoundary Interior (Cℝay S⁰)
_ Needle (Interior (Cℝay S⁰))
_ = 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ℝ :: forall r. RealFloat r => r -> r
bijectℝplustoℝ r
x = r
x forall a. Num a => a -> a -> a
- r
1forall a. Fractional a => a -> a -> a
/r
x
bijectℝtoℝplus :: forall r. RealFloat r => r -> r
bijectℝtoℝplus r
y = r
yforall a. Fractional a => a -> a -> a
/r
2 forall a. Num a => a -> a -> a
+ forall a. Floating a => a -> a
sqrt(r
yforall a. Num a => a -> Int -> a
^Int
2forall a. Fractional a => a -> a -> a
/r
4 forall a. Num a => a -> a -> a
+ r
1)

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

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

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

embCℝayToCD¹ :: RealFloat (Scalar (Needle m)) => Cℝay m -> CD¹ m
embCℝayToCD¹ :: forall m. RealFloat (Scalar (Needle m)) => Cℝay m -> CD¹ m
embCℝayToCD¹ (Cℝay Scalar (Needle m)
h m
m) = forall x. Scalar (Needle x) -> x -> CD¹ x
CD¹ (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 :: forall m. RealFloat (Scalar (Needle m)) => CD¹ m -> Cℝay m
projCD¹ToCℝay (CD¹ Scalar (Needle m)
h m
m) = forall x. Scalar (Needle x) -> x -> Cℝay x
Cℝay (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 :: forall v. LinearSpace v => DualVector v -> Stiefel1 v
stiefel1Project = forall v. DualVector v -> Stiefel1 v
Stiefel1

stiefel1Embed :: (HilbertSpace v, RealFloat (Scalar v)) => Stiefel1 v -> v
stiefel1Embed :: forall v. (HilbertSpace v, RealFloat (Scalar v)) => Stiefel1 v -> v
stiefel1Embed (Stiefel1 DualVector v
n) = forall v s. (InnerSpace v, s ~ Scalar v, Floating s) => v -> v
normalized 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 = forall v. DualVector v -> Stiefel1 v
Stiefel1 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 m v. NaturallyEmbedded m v => m -> v
embed
  unstiefel :: Stiefel1 v -> UnitSphere v
  unstiefel = forall m v. NaturallyEmbedded m v => v -> m
coEmbed 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. Stiefel1 v -> DualVector v
getStiefel1N

instance HasUnitSphere ℝ  where type UnitSphere ℝ  = S⁰

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

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