-- |
-- Module      : Data.Manifold.Types
-- Copyright   : (c) Justus Sagemüller 2015
-- License     : GPL v3
-- 
-- Maintainer  : (@) jsag $ hvl.no
-- Stability   : experimental
-- Portability : portable
-- 
-- Several commonly-used manifolds, represented in some simple way as Haskell
-- data types. All these are in the 'PseudoAffine' class.


{-# LANGUAGE FlexibleInstances        #-}
{-# LANGUAGE UndecidableInstances     #-}
{-# LANGUAGE InstanceSigs             #-}
{-# LANGUAGE CPP                      #-}
{-# LANGUAGE TypeFamilies             #-}
{-# LANGUAGE FunctionalDependencies   #-}
{-# LANGUAGE FlexibleContexts         #-}
{-# LANGUAGE LiberalTypeSynonyms      #-}
{-# LANGUAGE StandaloneDeriving       #-}
{-# LANGUAGE GADTs                    #-}
{-# LANGUAGE RankNTypes               #-}
{-# LANGUAGE TupleSections            #-}
{-# LANGUAGE MultiWayIf               #-}
{-# LANGUAGE ConstraintKinds          #-}
{-# LANGUAGE PatternGuards            #-}
{-# LANGUAGE TypeOperators            #-}
{-# LANGUAGE TypeApplications         #-}
{-# LANGUAGE DataKinds                #-}
{-# LANGUAGE ScopedTypeVariables      #-}
{-# LANGUAGE UnicodeSyntax            #-}
{-# LANGUAGE PatternSynonyms          #-}


module Data.Manifold.Types (
        -- * Index / ASCII names
          Real0, Real1, RealPlus, Real2, Real3
        , Sphere0, Sphere1, Sphere2
        , Projective0, Projective1, Projective2
        , Disk1, Disk2, Cone, OpenCone
        , FibreBundle(..), TangentBundle
        -- * Trivial manifolds
        , EmptyMfd(..), ZeroDim(..)
        -- * Linear manifolds
        , ℝ, ℝ⁰, ℝ¹, ℝ², ℝ³, ℝ⁴
        -- * Hyperspheres
        -- ** General form: Stiefel manifolds
        , Stiefel1(..), stiefel1Project, stiefel1Embed
        -- ** Specific examples
        , HasUnitSphere(..)
        , S⁰, S⁰_(..), S¹, S¹_(..), pattern S¹, S², S²_(..), pattern S²
        -- * Projective spaces
        , ℝP⁰, ℝP⁰_(..), ℝP¹, ℝP¹_(..), pattern ℝP¹,  ℝP²,  ℝP²_(..), pattern ℝP²
        -- * Intervals\/disks\/cones
        , D¹, D¹_(..), D², D²_(..), pattern D²
        , ℝay
        , CD¹(..), Cℝay(..)
        -- * Affine subspaces
        -- ** Lines
        , Line(..), lineAsPlaneIntersection
        -- ** Hyperplanes
        , Cutplane(..), normalPlane
        , fathomCutDistance, sideOfCut, cutPosBetween
        -- * Linear mappings
        , LinearMap, LocalLinear
        -- * Misc
        , StiefelScalar
   ) where


import Data.VectorSpace
import Data.VectorSpace.Free
import Data.AffineSpace
import Data.MemoTrie (HasTrie(..))
import Data.Basis
import Data.Fixed
import Data.Tagged
import qualified Data.Vector.Generic as Arr
import qualified Data.Vector
import qualified Data.Vector.Unboxed as UArr
import Data.List (maximumBy)
import Data.Ord (comparing)

import Data.Manifold.Types.Primitive
import Data.Manifold.Types.Stiefel
import Data.Manifold.PseudoAffine
import Data.Manifold.Cone
import Math.LinearMap.Category
#if MIN_VERSION_linearmap_category(0,6,0)
import Math.VectorSpace.DimensionAware
#if MIN_VERSION_singletons(3,0,0)
import Prelude.Singletons (SNum(..))
import GHC.TypeLits.Singletons (withKnownNat, SNat(..))
#else
import Data.Singletons.Prelude.Num (SNum(..), SNat(..))
import Data.Singletons.TypeLits (withKnownNat)
#endif
#endif
#if MIN_VERSION_linearmap_category(0,5,0)
import Math.LinearMap.Coercion
#endif

import qualified Prelude
import GHC.TypeLits (type (+), type (-))
import qualified Data.Traversable as Hask

import Control.Category.Constrained.Prelude hiding ((^), type (+))
import Control.Arrow.Constrained
import Control.Monad.Constrained
import Data.Foldable.Constrained hiding (type (+))

import Data.Coerce
import Data.Type.Coercion

type StiefelScalar s = (RealFloat s, UArr.Unbox s)

#define deriveAffine(c,t)                \
instance (c) => Semimanifold (t) where {  \
  type Needle (t) = Diff (t);              \
  (.+~^) = (.+^) };                         \
instance (c) => PseudoAffine (t) where {     \
  a.-~.b = pure (a.-.b);                      \
  a.-~!b = a.-.b }


newtype Stiefel1Needle v = Stiefel1Needle { forall v. Stiefel1Needle v -> Vector (Scalar v)
getStiefel1Tangent :: UArr.Vector (Scalar v) }
deriving instance (Eq (Scalar v), UArr.Unbox (Scalar v)) => Eq (Stiefel1Needle v)
newtype Stiefel1Basis v = Stiefel1Basis { forall v. Stiefel1Basis v -> Int
getStiefel1Basis :: Int }
s1bTrie :: ∀ v b. FiniteFreeSpace v => (Stiefel1Basis v->b) -> Stiefel1Basis v:->:b
s1bTrie :: forall v b.
FiniteFreeSpace v =>
(Stiefel1Basis v -> b) -> Stiefel1Basis v :->: b
s1bTrie = \Stiefel1Basis v -> b
f -> forall v a. Array a -> Stiefel1Basis v :->: a
St1BTrie 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 (Stiefel1Basis v -> b
f 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. Int -> Stiefel1Basis v
Stiefel1Basis) Vector Int
allIs
 where d :: Int
d = forall v (p :: * -> *).
(FiniteFreeSpace v, Functor p) =>
p v -> Int
freeDimension ([]::[v])
       allIs :: Vector Int
allIs = forall (v :: * -> *) a. Vector v a => [a] -> v a
Arr.fromList [Int
0 .. Int
dforall a. Num a => a -> a -> a
-Int
2]

instance FiniteFreeSpace v => HasTrie (Stiefel1Basis v) where
  data (Stiefel1Basis v :->: a) = St1BTrie ( Array a )
  trie :: forall b. (Stiefel1Basis v -> b) -> Stiefel1Basis v :->: b
trie = forall v b.
FiniteFreeSpace v =>
(Stiefel1Basis v -> b) -> Stiefel1Basis v :->: b
s1bTrie; untrie :: forall b. (Stiefel1Basis v :->: b) -> Stiefel1Basis v -> b
untrie (St1BTrie Array b
a) (Stiefel1Basis Int
i) = Array b
a forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
Arr.! Int
i
  enumerate :: forall b. (Stiefel1Basis v :->: b) -> [(Stiefel1Basis v, b)]
enumerate (St1BTrie Array b
a) = forall (v :: * -> *) a b.
Vector v a =>
(Int -> a -> b -> b) -> b -> v a -> b
Arr.ifoldr (\Int
i b
x [(Stiefel1Basis v, b)]
l -> (forall v. Int -> Stiefel1Basis v
Stiefel1Basis Int
i,b
x)forall a. a -> [a] -> [a]
:[(Stiefel1Basis v, b)]
l) [] Array b
a

type Array = Data.Vector.Vector

instance (FiniteFreeSpace v, UArr.Unbox (Scalar v))
                        => AdditiveGroup(Stiefel1Needle v) where
  Stiefel1Needle Vector (Scalar v)
v ^+^ :: Stiefel1Needle v -> Stiefel1Needle v -> Stiefel1Needle v
^+^ Stiefel1Needle Vector (Scalar v)
w = forall v. Vector (Scalar v) -> Stiefel1Needle v
Stiefel1Needle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall n. (Num n, Unbox n) => Vector n -> Vector n -> Vector n
uarrAdd Vector (Scalar v)
v Vector (Scalar v)
w
  Stiefel1Needle Vector (Scalar v)
v ^-^ :: Stiefel1Needle v -> Stiefel1Needle v -> Stiefel1Needle v
^-^ Stiefel1Needle Vector (Scalar v)
w = forall v. Vector (Scalar v) -> Stiefel1Needle v
Stiefel1Needle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall n. (Num n, Unbox n) => Vector n -> Vector n -> Vector n
uarrSubtract Vector (Scalar v)
v Vector (Scalar v)
w
  zeroV :: Stiefel1Needle v
zeroV = forall v. (FiniteFreeSpace v, Unbox (Scalar v)) => Stiefel1Needle v
s1nZ; negateV :: Stiefel1Needle v -> Stiefel1Needle v
negateV (Stiefel1Needle Vector (Scalar v)
v) = forall v. Vector (Scalar v) -> Stiefel1Needle v
Stiefel1Needle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
UArr.map forall a. Num a => a -> a
negate Vector (Scalar v)
v

uarrAdd :: (Num n, UArr.Unbox n) => UArr.Vector n -> UArr.Vector n -> UArr.Vector n
uarrAdd :: forall n. (Num n, Unbox n) => Vector n -> Vector n -> Vector n
uarrAdd = forall a b c.
(Unbox a, Unbox b, Unbox c) =>
(a -> b -> c) -> Vector a -> Vector b -> Vector c
UArr.zipWith forall a. Num a => a -> a -> a
(+)
uarrSubtract :: (Num n, UArr.Unbox n) => UArr.Vector n -> UArr.Vector n -> UArr.Vector n
uarrSubtract :: forall n. (Num n, Unbox n) => Vector n -> Vector n -> Vector n
uarrSubtract = forall a b c.
(Unbox a, Unbox b, Unbox c) =>
(a -> b -> c) -> Vector a -> Vector b -> Vector c
UArr.zipWith (-)

s1nZ :: ∀ v. (FiniteFreeSpace v, UArr.Unbox (Scalar v)) => Stiefel1Needle v
s1nZ :: forall v. (FiniteFreeSpace v, Unbox (Scalar v)) => Stiefel1Needle v
s1nZ = forall v. Vector (Scalar v) -> Stiefel1Needle v
Stiefel1Needle 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. Unbox a => [a] -> Vector a
UArr.fromList forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. Int -> a -> [a]
replicate (Int
dforall a. Num a => a -> a -> a
-Int
1) Scalar v
0
 where d :: Int
d = forall v (p :: * -> *).
(FiniteFreeSpace v, Functor p) =>
p v -> Int
freeDimension ([]::[v])

instance (FiniteFreeSpace v, UArr.Unbox (Scalar v)) => VectorSpace (Stiefel1Needle v) where
  type Scalar (Stiefel1Needle v) = Scalar v
  Scalar (Stiefel1Needle v)
μ *^ :: Scalar (Stiefel1Needle v) -> Stiefel1Needle v -> Stiefel1Needle v
*^ Stiefel1Needle Vector (Scalar v)
v = forall v. Vector (Scalar v) -> Stiefel1Needle v
Stiefel1Needle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall n. (Num n, Unbox n) => n -> Vector n -> Vector n
uarrScale Scalar (Stiefel1Needle v)
μ Vector (Scalar v)
v

uarrScale :: (Num n, UArr.Unbox n) => n -> UArr.Vector n -> UArr.Vector n
uarrScale :: forall n. (Num n, Unbox n) => n -> Vector n -> Vector n
uarrScale n
μ = forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
UArr.map (forall a. Num a => a -> a -> a
*n
μ)

instance (FiniteFreeSpace v, UArr.Unbox (Scalar v)) => HasBasis (Stiefel1Needle v) where
  type Basis (Stiefel1Needle v) = Stiefel1Basis v
  basisValue :: Basis (Stiefel1Needle v) -> Stiefel1Needle v
basisValue = forall v b.
(FiniteFreeSpace v, Unbox (Scalar v)) =>
Stiefel1Basis v -> Stiefel1Needle v
s1bV
  decompose :: Stiefel1Needle v
-> [(Basis (Stiefel1Needle v), Scalar (Stiefel1Needle v))]
decompose (Stiefel1Needle Vector (Scalar v)
v) = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((,)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. Int -> Stiefel1Basis v
Stiefel1Basis) [Int
0..] forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. Unbox a => Vector a -> [a]
UArr.toList Vector (Scalar v)
v
  decompose' :: Stiefel1Needle v
-> Basis (Stiefel1Needle v) -> Scalar (Stiefel1Needle v)
decompose' (Stiefel1Needle Vector (Scalar v)
v) (Stiefel1Basis Int
i) = Vector (Scalar v)
v forall a. Unbox a => Vector a -> Int -> a
UArr.! Int
i

s1bV :: ∀ v b. (FiniteFreeSpace v, UArr.Unbox (Scalar v))
                  => Stiefel1Basis v -> Stiefel1Needle v
s1bV :: forall v b.
(FiniteFreeSpace v, Unbox (Scalar v)) =>
Stiefel1Basis v -> Stiefel1Needle v
s1bV = \(Stiefel1Basis Int
i) -> forall v. Vector (Scalar v) -> Stiefel1Needle v
Stiefel1Needle
            forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. Unbox a => [a] -> Vector a
UArr.fromList [ if Int
kforall a. Eq a => a -> a -> Bool
==Int
i then Scalar v
1 else Scalar v
0 | Int
k<-[Int
0..Int
dforall a. Num a => a -> a -> a
-Int
2] ]
 where d :: Int
d = forall v (p :: * -> *).
(FiniteFreeSpace v, Functor p) =>
p v -> Int
freeDimension ([]::[v])

instance (FiniteFreeSpace v, UArr.Unbox (Scalar v))
                      => FiniteFreeSpace (Stiefel1Needle v) where
  freeDimension :: forall (p :: * -> *). Functor p => p (Stiefel1Needle v) -> Int
freeDimension = forall v (p :: * -> *).
FiniteFreeSpace v =>
p (Stiefel1Needle v) -> Int
s1nD
  toFullUnboxVect :: Unbox (Scalar (Stiefel1Needle v)) =>
Stiefel1Needle v -> Vector (Scalar (Stiefel1Needle v))
toFullUnboxVect = forall v. Stiefel1Needle v -> Vector (Scalar v)
getStiefel1Tangent
  unsafeFromFullUnboxVect :: Unbox (Scalar (Stiefel1Needle v)) =>
Vector (Scalar (Stiefel1Needle v)) -> Stiefel1Needle v
unsafeFromFullUnboxVect = forall v. Vector (Scalar v) -> Stiefel1Needle v
Stiefel1Needle
s1nD :: ∀ v p . FiniteFreeSpace v => p (Stiefel1Needle v) -> Int
s1nD :: forall v (p :: * -> *).
FiniteFreeSpace v =>
p (Stiefel1Needle v) -> Int
s1nD p (Stiefel1Needle v)
_ = forall v (p :: * -> *).
(FiniteFreeSpace v, Functor p) =>
p v -> Int
freeDimension ([]::[v]) forall a. Num a => a -> a -> a
- Int
1

instance (FiniteFreeSpace v, UArr.Unbox (Scalar v)) => AffineSpace (Stiefel1Needle v) where
  type Diff (Stiefel1Needle v) = Stiefel1Needle v
  .+^ :: Stiefel1Needle v -> Diff (Stiefel1Needle v) -> Stiefel1Needle v
(.+^) = forall v. AdditiveGroup v => v -> v -> v
(^+^)
  .-. :: Stiefel1Needle v -> Stiefel1Needle v -> Diff (Stiefel1Needle v)
(.-.) = forall v. AdditiveGroup v => v -> v -> v
(^-^)

deriveAffine((FiniteFreeSpace v, UArr.Unbox (Scalar v)), Stiefel1Needle v)

#if MIN_VERSION_linearmap_category(0,6,0)
type family ClipPred n where
  ClipPred 0 = 0
  ClipPred n = n-1
type family FmapClipPred n where
  FmapClipPred ('Just n) = 'Just (ClipPred n)
  FmapClipPred 'Nothing = 'Nothing

clipPredSing :: SNat n -> SNat (ClipPred n)
clipPredSing :: forall (n :: Natural). SNat n -> SNat (ClipPred n)
clipPredSing SNat n
_ = forall a. HasCallStack => a
undefined

instance ∀ v . (FiniteFreeSpace v, DimensionAware v, UArr.Unbox (Scalar v))
              => DimensionAware (Stiefel1Needle v) where
  type StaticDimension (Stiefel1Needle v) = FmapClipPred (StaticDimension v) 
  dimensionalityWitness :: DimensionalityWitness (Stiefel1Needle v)
dimensionalityWitness = case forall v. DimensionAware v => DimensionalityWitness v
dimensionalityWitness @v of
    DimensionalityWitness v
IsStaticDimensional -> forall (n :: Natural) r. Sing n -> (KnownNat n => r) -> r
withKnownNat (forall (n :: Natural). SNat n -> SNat (ClipPred n)
clipPredSing forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall v (n :: Natural). Dimensional n v => Sing n
dimensionalitySing @v)
                             forall (n :: Natural) v. Dimensional n v => DimensionalityWitness v
IsStaticDimensional
    DimensionalityWitness v
IsFlexibleDimensional -> forall v. (StaticDimension v ~ 'Nothing) => DimensionalityWitness v
IsFlexibleDimensional
instance ∀ v n n' . ( FiniteFreeSpace v, n`Dimensional`v, n' ~ ClipPred n
                    , UArr.Unbox (Scalar v) )
              => n'`Dimensional`(Stiefel1Needle v) where
  knownDimensionalitySing :: Sing n'
knownDimensionalitySing = forall (n :: Natural). SNat n -> SNat (ClipPred n)
clipPredSing (forall v (n :: Natural). Dimensional n v => Sing n
dimensionalitySing @v)
#endif

instance ∀ v . (LSpace v, FiniteFreeSpace v, Eq (Scalar v), UArr.Unbox (Scalar v))
              => TensorSpace (Stiefel1Needle v) where
  type TensorProduct (Stiefel1Needle v) w = Array w
  scalarSpaceWitness :: ScalarSpaceWitness (Stiefel1Needle v)
scalarSpaceWitness = case forall v. TensorSpace v => ScalarSpaceWitness v
scalarSpaceWitness :: ScalarSpaceWitness v of
         ScalarSpaceWitness v
ScalarSpaceWitness -> forall v.
(Num' (Scalar v), Scalar (Scalar v) ~ Scalar v) =>
ScalarSpaceWitness v
ScalarSpaceWitness
  linearManifoldWitness :: LinearManifoldWitness (Stiefel1Needle v)
linearManifoldWitness = forall v.
(Needle v ~ v, AffineSpace v, Diff v ~ v) =>
LinearManifoldWitness v
LinearManifoldWitness
  zeroTensor :: forall w.
(TensorSpace w, Scalar w ~ Scalar (Stiefel1Needle v)) =>
Stiefel1Needle v ⊗ w
zeroTensor = 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 (v :: * -> *) a. Vector v a => Int -> a -> v a
Arr.replicate (forall v (p :: * -> *).
(FiniteFreeSpace v, Functor p) =>
p v -> Int
freeDimension ([]::[v]) forall a. Num a => a -> a -> a
- Int
1) forall v. AdditiveGroup v => v
zeroV
  toFlatTensor :: Stiefel1Needle v -+> (Stiefel1Needle v ⊗ Scalar (Stiefel1Needle v))
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
$ forall s v w. TensorProduct v w -> Tensor s v w
Tensor 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 :: * -> *) a (w :: * -> *).
(Vector v a, Vector w a) =>
v a -> w a
Arr.convert 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. Stiefel1Needle v -> Vector (Scalar v)
getStiefel1Tangent
  fromFlatTensor :: (Stiefel1Needle v ⊗ Scalar (Stiefel1Needle v)) -+> Stiefel1Needle v
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
$ forall v. Vector (Scalar v) -> Stiefel1Needle v
Stiefel1Needle 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 :: * -> *) a (w :: * -> *).
(Vector v a, Vector w a) =>
v a -> w a
Arr.convert 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 s v w. Tensor s v w -> TensorProduct v w
getTensorProduct
  addTensors :: forall w.
(TensorSpace w, Scalar w ~ Scalar (Stiefel1Needle v)) =>
(Stiefel1Needle v ⊗ w)
-> (Stiefel1Needle v ⊗ w) -> Stiefel1Needle v ⊗ w
addTensors (Tensor TensorProduct (Stiefel1Needle v) w
a) (Tensor TensorProduct (Stiefel1Needle v) 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 (v :: * -> *) a b c.
(Vector v a, Vector v b, Vector v c) =>
(a -> b -> c) -> v a -> v b -> v c
Arr.zipWith forall v. AdditiveGroup v => v -> v -> v
(^+^) TensorProduct (Stiefel1Needle v) w
a TensorProduct (Stiefel1Needle v) w
b
  subtractTensors :: forall w.
(TensorSpace (Stiefel1Needle v), TensorSpace w,
 Scalar w ~ Scalar (Stiefel1Needle v)) =>
(Stiefel1Needle v ⊗ w)
-> (Stiefel1Needle v ⊗ w) -> Stiefel1Needle v ⊗ w
subtractTensors (Tensor TensorProduct (Stiefel1Needle v) w
a) (Tensor TensorProduct (Stiefel1Needle v) 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 (v :: * -> *) a b c.
(Vector v a, Vector v b, Vector v c) =>
(a -> b -> c) -> v a -> v b -> v c
Arr.zipWith forall v. AdditiveGroup v => v -> v -> v
(^-^) TensorProduct (Stiefel1Needle v) w
a TensorProduct (Stiefel1Needle v) w
b
  scaleTensor :: forall w.
(TensorSpace w, Scalar w ~ Scalar (Stiefel1Needle v)) =>
Bilinear
  (Scalar (Stiefel1Needle v))
  (Stiefel1Needle v ⊗ w)
  (Stiefel1Needle v ⊗ 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
$ \Scalar v
μ (Tensor TensorProduct (Stiefel1Needle v) w
a) -> 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 (v :: * -> *) a b.
(Vector v a, Vector v b) =>
(a -> b) -> v a -> v b
Arr.map (Scalar v
μforall v. VectorSpace v => Scalar v -> v -> v
*^) TensorProduct (Stiefel1Needle v) w
a
  negateTensor :: forall w.
(TensorSpace w, Scalar w ~ Scalar (Stiefel1Needle v)) =>
(Stiefel1Needle v ⊗ w) -+> (Stiefel1Needle v ⊗ 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 TensorProduct (Stiefel1Needle v) w
a) -> 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 (v :: * -> *) a b.
(Vector v a, Vector v b) =>
(a -> b) -> v a -> v b
Arr.map forall v. AdditiveGroup v => v -> v
negateV TensorProduct (Stiefel1Needle v) w
a
  tensorProduct :: forall w.
(TensorSpace w, Scalar w ~ Scalar (Stiefel1Needle v)) =>
Bilinear (Stiefel1Needle v) w (Stiefel1Needle v ⊗ 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
$ \(Stiefel1Needle Vector (Scalar v)
n) 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 (v :: * -> *) a b.
(Vector v a, Vector v b) =>
(a -> b) -> v a -> v b
Arr.map (forall v. VectorSpace v => Scalar v -> v -> v
*^w
w) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (v :: * -> *) a (w :: * -> *).
(Vector v a, Vector w a) =>
v a -> w a
Arr.convert Vector (Scalar v)
n
  transposeTensor :: forall w.
(TensorSpace w, Scalar w ~ Scalar (Stiefel1Needle v)) =>
(Stiefel1Needle v ⊗ w) -+> (w ⊗ Stiefel1Needle v)
transposeTensor = 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 TensorProduct (Stiefel1Needle v) w
a) -> forall (v :: * -> *) b a.
Vector v b =>
(a -> b -> a) -> a -> v b -> a
Arr.foldl' forall v. AdditiveGroup v => v -> v -> v
(^+^) forall v. AdditiveGroup v => v
zeroV
       forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (v :: * -> *) a b.
(Vector v a, Vector v b) =>
(Int -> a -> b) -> v a -> v b
Arr.imap ( \Int
i w
w -> (forall s v w. LinearFunction s v w -> v -> w
getLinearFunction forall v w.
(TensorSpace v, TensorSpace w, Scalar w ~ Scalar v) =>
Bilinear v w (v ⊗ w)
tensorProduct w
w) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall v. Vector (Scalar v) -> Stiefel1Needle v
Stiefel1Needle
                             forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. Unbox a => Int -> (Int -> a) -> Vector a
UArr.generate Int
d (\Int
j -> if Int
iforall a. Eq a => a -> a -> Bool
==Int
j then Scalar v
1 else Scalar v
0) ) TensorProduct (Stiefel1Needle v) w
a
   where d :: Int
d = forall v (p :: * -> *).
(FiniteFreeSpace v, Functor p) =>
p v -> Int
freeDimension ([]::[v]) forall a. Num a => a -> a -> a
- Int
1
  fmapTensor :: forall w x.
(TensorSpace w, TensorSpace x,
 Scalar w ~ Scalar (Stiefel1Needle v),
 Scalar x ~ Scalar (Stiefel1Needle v)) =>
Bilinear (w -+> x) (Stiefel1Needle v ⊗ w) (Stiefel1Needle v ⊗ 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 (Scalar v) w x
f (Tensor TensorProduct (Stiefel1Needle v) w
a) -> 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 (v :: * -> *) a b.
(Vector v a, Vector v b) =>
(a -> b) -> v a -> v b
Arr.map (LinearFunction (Scalar v) w x
fforall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$) TensorProduct (Stiefel1Needle v) w
a
  fzipTensorWith :: forall u w x.
(TensorSpace u, TensorSpace w, TensorSpace x,
 Scalar u ~ Scalar (Stiefel1Needle v),
 Scalar w ~ Scalar (Stiefel1Needle v),
 Scalar x ~ Scalar (Stiefel1Needle v)) =>
Bilinear
  ((w, x) -+> u)
  (Stiefel1Needle v ⊗ w, Stiefel1Needle v ⊗ x)
  (Stiefel1Needle v ⊗ 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 (Scalar v) (w, x) u
f (Tensor TensorProduct (Stiefel1Needle v) w
a, Tensor TensorProduct (Stiefel1Needle v) 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 (v :: * -> *) a b c.
(Vector v a, Vector v b, Vector v c) =>
(a -> b -> c) -> v a -> v b -> v c
Arr.zipWith (forall (k :: * -> * -> *) a b c.
(Curry k, ObjectPair k a b, ObjectMorphism k b c) =>
k (a, b) c -> k a (k b c)
curry forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall (a :: * -> * -> *) (k :: * -> * -> *) b c.
(EnhancedCat a k, Object k b, Object k c, Object a b,
 Object a c) =>
k b c -> a b c
arr LinearFunction (Scalar v) (w, x) u
f) TensorProduct (Stiefel1Needle v) w
a TensorProduct (Stiefel1Needle v) x
b
#if MIN_VERSION_linearmap_category(0,6,0)
  coerceFmapTensorProduct :: forall (p :: * -> *) a b.
(Functor p, TensorSpace a, Scalar a ~ Scalar (Stiefel1Needle v),
 TensorSpace b, Scalar b ~ Scalar (Stiefel1Needle v)) =>
p (Stiefel1Needle v)
-> VSCCoercion (Scalar (Stiefel1Needle v)) a b
-> Coercion
     (TensorProduct (Stiefel1Needle v) a)
     (TensorProduct (Stiefel1Needle v) b)
coerceFmapTensorProduct p (Stiefel1Needle v)
_ VSCCoercion (Scalar (Stiefel1Needle v)) a b
VSCCoercion = forall {k} (a :: k) (b :: k). Coercible a b => Coercion a b
Coercion
#elif MIN_VERSION_linearmap_category(0,5,0)
  coerceFmapTensorProduct _ VSCCoercion = VSCCoercion
#endif
  wellDefinedTensor :: forall w.
(TensorSpace w, Scalar w ~ Scalar (Stiefel1Needle v)) =>
(Stiefel1Needle v ⊗ w) -> Maybe (Stiefel1Needle v ⊗ w)
wellDefinedTensor (Tensor TensorProduct (Stiefel1Needle v) w
a) = forall s v w. TensorProduct v w -> Tensor s v w
Tensor forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
Hask.traverse forall v. TensorSpace v => v -> Maybe v
wellDefinedVector TensorProduct (Stiefel1Needle v) w
a

infixr 0 +$>
(+$>) :: (LinearSpace a, TensorSpace b, Scalar a ~ s, Scalar b ~ s)
            => LinearMap s a b -> a -> b
+$> :: forall a b s.
(LinearSpace a, TensorSpace b, Scalar a ~ s, Scalar b ~ s) =>
LinearMap s a b -> a -> b
(+$>) = forall s v w. LinearFunction s v w -> v -> w
getLinearFunction 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 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
  
instance ∀ v . (LSpace v, FiniteFreeSpace v, Eq (Scalar v), UArr.Unbox (Scalar v))
              => LinearSpace (Stiefel1Needle v) where
  type DualVector (Stiefel1Needle v) = Stiefel1Needle v
  linearId :: Stiefel1Needle v +> Stiefel1Needle v
linearId = forall s v w. TensorProduct (DualVector v) w -> LinearMap s v w
LinearMap 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 :: * -> *) a. Vector v a => Int -> (Int -> a) -> v a
Arr.generate Int
d forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \Int
i -> forall v. Vector (Scalar v) -> Stiefel1Needle v
Stiefel1Needle 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 :: * -> *) a. Vector v a => Int -> (Int -> a) -> v a
Arr.generate Int
d forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$
                                           \Int
j -> if Int
iforall a. Eq a => a -> a -> Bool
==Int
j then Scalar v
1 else Scalar v
0
   where d :: Int
d = forall v (p :: * -> *).
(FiniteFreeSpace v, Functor p) =>
p v -> Int
freeDimension ([]::[v]) forall a. Num a => a -> a -> a
- Int
1
  tensorId :: forall w.
(LinearSpace w, Scalar w ~ Scalar (Stiefel1Needle v)) =>
(Stiefel1Needle v ⊗ w) +> (Stiefel1Needle v ⊗ w)
tensorId = forall w.
(LinearSpace w, Scalar w ~ Scalar v) =>
DualSpaceWitness w
-> (Stiefel1Needle v ⊗ w) +> (Stiefel1Needle v ⊗ w)
ti forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness
   where ti :: ∀ w . (LinearSpace w, Scalar w ~ Scalar v)
           => DualSpaceWitness w -> (Stiefel1Needle v ⊗ w) +> (Stiefel1Needle v ⊗ w)
         ti :: forall w.
(LinearSpace w, Scalar w ~ Scalar v) =>
DualSpaceWitness w
-> (Stiefel1Needle v ⊗ w) +> (Stiefel1Needle v ⊗ w)
ti DualSpaceWitness w
DualSpaceWitness = forall s v w. TensorProduct (DualVector v) w -> LinearMap s v w
LinearMap 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 :: * -> *) a. Vector v a => Int -> (Int -> a) -> v a
Arr.generate Int
d
           forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \Int
i -> 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 κ (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 :: * -> *) a. Vector v a => Int -> (Int -> a) -> v a
Arr.generate Int
d forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$
              \Int
j -> if Int
iforall a. Eq a => a -> a -> Bool
==Int
j then w
w else forall v. AdditiveGroup v => v
zeroV) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ coerce :: forall a b. Coercible a b => a -> b
coerce (forall κ (k :: κ -> κ -> *) (a :: κ).
(Category k, Object k a) =>
k a a
id :: w+>w)
         d :: Int
d = forall v (p :: * -> *).
(FiniteFreeSpace v, Functor p) =>
p v -> Int
freeDimension ([]::[v]) forall a. Num a => a -> a -> a
- Int
1
  dualSpaceWitness :: DualSpaceWitness (Stiefel1Needle v)
dualSpaceWitness = case forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness :: DualSpaceWitness v of
         DualSpaceWitness v
DualSpaceWitness -> forall v.
(LinearSpace (Scalar v), DualVector (Scalar v) ~ Scalar v,
 LinearSpace (DualVector v), Scalar (DualVector v) ~ Scalar v,
 DualVector (DualVector v) ~ v,
 StaticDimension (DualVector v) ~ StaticDimension v) =>
DualSpaceWitness v
DualSpaceWitness
#if MIN_VERSION_linearmap_category(0,5,0)
  coerceDoubleDual :: VSCCoercion
  (Scalar (Stiefel1Needle v))
  (Stiefel1Needle v)
  (DualVector (DualVector (Stiefel1Needle v)))
coerceDoubleDual = forall a b s.
(Coercible a b, StaticDimension a ~ StaticDimension b) =>
VSCCoercion s a b
VSCCoercion
#else
  coerceDoubleDual = Coercion
#endif
  contractTensorMap :: forall w.
(TensorSpace w, Scalar w ~ Scalar (Stiefel1Needle v)) =>
(Stiefel1Needle v +> (Stiefel1Needle v ⊗ 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 TensorProduct
  (DualVector (Stiefel1Needle v))
  (Tensor (Scalar v) (Stiefel1Needle v) w)
m)
                        -> forall (v :: * -> *) b a.
Vector v b =>
(a -> Int -> b -> a) -> a -> v b -> a
Arr.ifoldl' (\w
acc Int
i (Tensor TensorProduct (Stiefel1Needle v) w
t) -> w
acc forall v. AdditiveGroup v => v -> v -> v
^+^ TensorProduct (Stiefel1Needle v) w
t forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
Arr.! Int
i) forall v. AdditiveGroup v => v
zeroV TensorProduct
  (DualVector (Stiefel1Needle v))
  (Tensor (Scalar v) (Stiefel1Needle v) w)
m
  contractMapTensor :: forall w.
(TensorSpace w, Scalar w ~ Scalar (Stiefel1Needle v)) =>
(Stiefel1Needle v ⊗ (Stiefel1Needle v +> 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 TensorProduct
  (Stiefel1Needle v) (LinearMap (Scalar v) (Stiefel1Needle v) w)
m)
                        -> forall (v :: * -> *) b a.
Vector v b =>
(a -> Int -> b -> a) -> a -> v b -> a
Arr.ifoldl' (\w
acc Int
i (LinearMap TensorProduct (DualVector (Stiefel1Needle v)) w
t) -> w
acc forall v. AdditiveGroup v => v -> v -> v
^+^ TensorProduct (DualVector (Stiefel1Needle v)) w
t forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
Arr.! Int
i) forall v. AdditiveGroup v => v
zeroV TensorProduct
  (Stiefel1Needle v) (LinearMap (Scalar v) (Stiefel1Needle v) w)
m
  contractLinearMapAgainst :: forall w.
(LinearSpace w, Scalar w ~ Scalar (Stiefel1Needle v)) =>
Bilinear
  (Stiefel1Needle v +> w)
  (w -+> Stiefel1Needle v)
  (Scalar (Stiefel1Needle v))
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 TensorProduct (DualVector (Stiefel1Needle v)) w
m) LinearFunction (Scalar v) w (Stiefel1Needle v)
f
                        -> forall (v :: * -> *) b a.
Vector v b =>
(a -> Int -> b -> a) -> a -> v b -> a
Arr.ifoldl' (\Scalar v
acc Int
i w
w -> case LinearFunction (Scalar v) w (Stiefel1Needle v)
f forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ w
w of
                                          Stiefel1Needle Vector (Scalar v)
n -> Vector (Scalar v)
n forall a. Unbox a => Vector a -> Int -> a
UArr.! Int
i ) Scalar v
0 TensorProduct (DualVector (Stiefel1Needle v)) w
m
  applyDualVector :: LinearSpace (Stiefel1Needle v) =>
Bilinear
  (DualVector (Stiefel1Needle v))
  (Stiefel1Needle v)
  (Scalar (Stiefel1Needle v))
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
$ \(Stiefel1Needle Vector (Scalar v)
v) (Stiefel1Needle Vector (Scalar v)
w)
                        -> forall a. (Unbox a, Num a) => Vector a -> a
UArr.sum forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b c.
(Unbox a, Unbox b, Unbox c) =>
(a -> b -> c) -> Vector a -> Vector b -> Vector c
UArr.zipWith forall a. Num a => a -> a -> a
(*) Vector (Scalar v)
v Vector (Scalar v)
w
  applyLinear :: forall w.
(TensorSpace w, Scalar w ~ Scalar (Stiefel1Needle v)) =>
Bilinear (Stiefel1Needle v +> w) (Stiefel1Needle v) 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 TensorProduct (DualVector (Stiefel1Needle v)) w
m) (Stiefel1Needle Vector (Scalar v)
v)
                        -> forall (v :: * -> *) b a.
Vector v b =>
(a -> Int -> b -> a) -> a -> v b -> a
Arr.ifoldl' (\w
acc Int
i w
w -> w
acc forall v. AdditiveGroup v => v -> v -> v
^+^ Vector (Scalar v)
v forall a. Unbox a => Vector a -> Int -> a
UArr.! Int
i forall v. VectorSpace v => Scalar v -> v -> v
*^ w
w) forall v. AdditiveGroup v => v
zeroV TensorProduct (DualVector (Stiefel1Needle v)) w
m
  applyTensorFunctional :: forall u.
(LinearSpace u, Scalar u ~ Scalar (Stiefel1Needle v)) =>
Bilinear
  (DualVector (Stiefel1Needle v ⊗ u))
  (Stiefel1Needle v ⊗ u)
  (Scalar (Stiefel1Needle v))
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 TensorProduct (DualVector (Stiefel1Needle v)) (DualVector u)
f) (Tensor TensorProduct (Stiefel1Needle v) u
t)
                           -> forall (v :: * -> *) b a.
Vector v b =>
(a -> Int -> b -> a) -> a -> v b -> a
Arr.ifoldl' (\Scalar v
acc Int
i DualVector u
u -> Scalar v
acc forall a. Num a => a -> a -> a
+ DualVector u
u forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^ TensorProduct (Stiefel1Needle v) u
t forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
Arr.! Int
i) Scalar v
0 TensorProduct (DualVector (Stiefel1Needle v)) (DualVector u)
f
  applyTensorLinMap :: ∀ u w . ( LinearSpace u, Scalar u ~ Scalar v
                               , TensorSpace w, Scalar w ~ Scalar v )
    => Bilinear (LinearMap (Scalar v) (Tensor (Scalar v) (Stiefel1Needle v) u) w)
               (Tensor (Scalar v) (Stiefel1Needle v) u)
               w
  applyTensorLinMap :: forall u w.
(LinearSpace u, Scalar u ~ Scalar v, TensorSpace w,
 Scalar w ~ Scalar v) =>
Bilinear
  (LinearMap (Scalar v) (Tensor (Scalar v) (Stiefel1Needle v) u) w)
  (Tensor (Scalar v) (Stiefel1Needle v) 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 TensorProduct
  (DualVector (Tensor (Scalar v) (Stiefel1Needle v) u)) w
f) (Tensor TensorProduct (Stiefel1Needle v) u
t)
         -> forall (v :: * -> *) b a.
Vector v b =>
(a -> Int -> b -> a) -> a -> v b -> a
Arr.ifoldl' (\w
w Int
i u
u -> w
w forall v. AdditiveGroup v => v -> v -> v
^+^ ((coerce :: forall a b. Coercible a b => a -> b
coerce forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ TensorProduct
  (DualVector (Tensor (Scalar v) (Stiefel1Needle v) u)) w
f forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
Arr.! Int
i) forall a b s.
(LinearSpace a, TensorSpace b, Scalar a ~ s, Scalar b ~ s) =>
LinearMap s a b -> a -> b
+$> u
u)) forall v. AdditiveGroup v => v
zeroV TensorProduct (Stiefel1Needle v) u
t
  composeLinear :: forall w x.
(LinearSpace w, TensorSpace x,
 Scalar w ~ Scalar (Stiefel1Needle v),
 Scalar x ~ Scalar (Stiefel1Needle v)) =>
Bilinear (w +> x) (Stiefel1Needle v +> w) (Stiefel1Needle v +> 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 (Scalar v) w x
f (LinearMap TensorProduct (DualVector (Stiefel1Needle v)) 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 (v :: * -> *) a b.
(Vector v a, Vector v b) =>
(a -> b) -> v a -> v b
Arr.map (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) w x
fforall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$) TensorProduct (DualVector (Stiefel1Needle v)) w
g
  useTupleLinearSpaceComponents :: forall x y φ.
(Stiefel1Needle v ~ (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 ∀ v .
   ( LinearSpace v, FiniteFreeSpace v, FiniteFreeSpace (DualVector v)
   , StiefelScalar (Scalar v) ) => Semimanifold (Stiefel1 v) where
  type Needle (Stiefel1 v) = Stiefel1Needle v
  .+~^ :: Stiefel1 v -> Needle (Stiefel1 v) -> Stiefel1 v
(.+~^) = DualSpaceWitness v -> Stiefel1 v -> Stiefel1Needle v -> Stiefel1 v
tpst forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness
   where tpst :: DualSpaceWitness v -> Stiefel1 v -> Stiefel1Needle v -> Stiefel1 v
         tpst :: DualSpaceWitness v -> Stiefel1 v -> Stiefel1Needle v -> Stiefel1 v
tpst DualSpaceWitness v
DualSpaceWitness (Stiefel1 DualVector v
s) (Stiefel1Needle Vector (Scalar v)
n)
             = 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 v.
(FiniteFreeSpace v, Unbox (Scalar v)) =>
Vector (Scalar v) -> v
unsafeFromFullUnboxVect 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 n. (Num n, Unbox n) => n -> Vector n -> Vector n
uarrScale (forall a. Num a => a -> a
signum Scalar v
s'i)
          forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ if| Scalar v
νforall a. Eq a => a -> a -> Bool
==Scalar v
0      -> Vector (Scalar (DualVector v))
s' -- ν'≡0 is a special case of this, so if not ν=0
                                --  we can otherwise assume ν'>0.
              | Scalar v
νforall a. Ord a => a -> a -> Bool
<=Scalar v
2      -> let m :: Vector (Scalar v)
m = forall n. (Num n, Unbox n) => n -> Vector n -> Vector n
uarrScale Scalar v
ιmν Vector (Scalar v)
spro
                                       forall n. (Num n, Unbox n) => Vector n -> Vector n -> Vector n
`uarrAdd` forall n. (Num n, Unbox n) => n -> Vector n -> Vector n
uarrScale ((Scalar v
1forall a. Num a => a -> a -> a
-forall a. Num a => a -> a
abs Scalar v
ιmν)forall a. Fractional a => a -> a -> a
/Scalar v
ν') Vector (Scalar v)
n
                                 ιmν :: Scalar v
ιmν = Scalar v
1forall a. Num a => a -> a -> a
-Scalar v
ν 
                             in Scalar v -> Vector (Scalar v) -> Vector (Scalar v)
insi Scalar v
ιmν Vector (Scalar v)
m
              | Bool
otherwise -> let m :: Vector (Scalar v)
m = forall n. (Num n, Unbox n) => n -> Vector n -> Vector n
uarrScale Scalar v
ιmν Vector (Scalar v)
spro
                                       forall n. (Num n, Unbox n) => Vector n -> Vector n -> Vector n
`uarrAdd` forall n. (Num n, Unbox n) => n -> Vector n -> Vector n
uarrScale ((forall a. Num a => a -> a
abs Scalar v
ιmνforall a. Num a => a -> a -> a
-Scalar v
1)forall a. Fractional a => a -> a -> a
/Scalar v
ν') Vector (Scalar v)
n
                                 ιmν :: Scalar v
ιmν = Scalar v
νforall a. Num a => a -> a -> a
-Scalar v
3
                             in Scalar v -> Vector (Scalar v) -> Vector (Scalar v)
insi Scalar v
ιmν Vector (Scalar v)
m
          where d :: Int
d = forall a. Unbox a => Vector a -> Int
UArr.length Vector (Scalar (DualVector v))
s'
                s' :: Vector (Scalar (DualVector v))
s'= forall v.
(FiniteFreeSpace v, Unbox (Scalar v)) =>
v -> Vector (Scalar v)
toFullUnboxVect DualVector v
s
                ν' :: Scalar v
ν' = forall s. (Floating s, Unbox s) => Vector s -> s
l2norm Vector (Scalar v)
n
                quop :: Scalar v
quop = forall a. Num a => a -> a
signum Scalar v
s'i forall a. Fractional a => a -> a -> a
/ Scalar v
ν'
                ν :: Scalar v
ν = Scalar v
ν' forall a. Real a => a -> a -> a
`mod'` Scalar v
4
                im :: Int
im = forall a. (Unbox a, Ord a) => Vector a -> Int
UArr.maxIndex forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
UArr.map forall a. Num a => a -> a
abs Vector (Scalar (DualVector v))
s'
                s'i :: Scalar v
s'i = Vector (Scalar (DualVector v))
s' forall a. Unbox a => Vector a -> Int -> a
UArr.! Int
im
                spro :: Vector (Scalar v)
spro = let v :: Vector (Scalar v)
v = Vector (Scalar v) -> Vector (Scalar v)
deli Vector (Scalar (DualVector v))
s' in forall n. (Num n, Unbox n) => n -> Vector n -> Vector n
uarrScale (forall a. Fractional a => a -> a
recip Scalar v
s'i) Vector (Scalar v)
v
                deli :: Vector (Scalar v) -> Vector (Scalar v)
deli Vector (Scalar v)
v = forall (v :: * -> *) a. Vector v a => Int -> v a -> v a
Arr.take Int
im Vector (Scalar v)
v forall (v :: * -> *) a. Vector v a => v a -> v a -> v a
Arr.++ forall (v :: * -> *) a. Vector v a => Int -> v a -> v a
Arr.drop (Int
imforall a. Num a => a -> a -> a
+Int
1) Vector (Scalar v)
v
                insi :: Scalar v -> Vector (Scalar v) -> Vector (Scalar v)
insi Scalar v
ti Vector (Scalar v)
v = forall (v :: * -> *) a. Vector v a => Int -> (Int -> a) -> v a
Arr.generate Int
d forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ \Int
i -> if | Int
iforall a. Ord a => a -> a -> Bool
<Int
im      -> Vector (Scalar v)
v forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
Arr.! Int
i
                                                      | Int
iforall a. Ord a => a -> a -> Bool
>Int
im      -> Vector (Scalar v)
v forall (v :: * -> *) a.
(HasCallStack, Vector v a) =>
v a -> Int -> a
Arr.! (Int
iforall a. Num a => a -> a -> a
-Int
1) 
                                                      | Bool
otherwise -> Scalar v
ti
instance ∀ v .
   ( LinearSpace v, FiniteFreeSpace v, FiniteFreeSpace (DualVector v)
   , StiefelScalar (Scalar v) ) => PseudoAffine (Stiefel1 v) where
  Stiefel1 v
p.-~. :: Stiefel1 v -> Stiefel1 v -> Maybe (Needle (Stiefel1 v))
.-~.Stiefel1 v
q = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure (Stiefel1 v
pforall x. (PseudoAffine x, HasCallStack) => x -> x -> Needle x
.-~!Stiefel1 v
q)
  .-~! :: HasCallStack => Stiefel1 v -> Stiefel1 v -> Needle (Stiefel1 v)
(.-~!) = DualSpaceWitness v -> Stiefel1 v -> Stiefel1 v -> Stiefel1Needle v
dpst forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness
   where dpst :: DualSpaceWitness v -> Stiefel1 v -> Stiefel1 v -> Stiefel1Needle v
         dpst :: DualSpaceWitness v -> Stiefel1 v -> Stiefel1 v -> Stiefel1Needle v
dpst DualSpaceWitness v
DualSpaceWitness (Stiefel1 DualVector v
s) (Stiefel1 DualVector v
t)
             = forall v. Vector (Scalar v) -> Stiefel1Needle v
Stiefel1Needle forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ case Vector (Scalar (DualVector v))
s' forall a. Unbox a => Vector a -> Int -> a
UArr.! Int
im of
                   Scalar v
0 -> forall n. (Num n, Unbox n) => n -> Vector n -> Vector n
uarrScale (forall a. Fractional a => a -> a
recip forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall s. (Floating s, Unbox s) => Vector s -> s
l2norm Vector (Scalar v)
delis) Vector (Scalar v)
delis
                   Scalar v
s'i | Vector (Scalar v)
v <- forall n. (Num n, Unbox n) => n -> Vector n -> Vector n
uarrScale (forall a. Fractional a => a -> a
recip Scalar v
s'i) Vector (Scalar v)
delis forall n. (Num n, Unbox n) => Vector n -> Vector n -> Vector n
`uarrSubtract` Vector (Scalar v)
tpro
                       , Scalar v
absv <- forall s. (Floating s, Unbox s) => Vector s -> s
l2norm Vector (Scalar v)
v
                       , Scalar v
absv forall a. Ord a => a -> a -> Bool
> Scalar v
0
                              -> let μ :: Scalar v
μ = (forall a. Num a => a -> a
signum (Scalar v
t'iforall a. Fractional a => a -> a -> a
/Scalar v
s'i) forall a. Num a => a -> a -> a
- forall a. Fractional a => a -> a
recip(Scalar v
absv forall a. Num a => a -> a -> a
+ Scalar v
1)) forall a. Fractional a => a -> a -> a
/ Scalar v
absv
                                 in forall n. (Num n, Unbox n) => n -> Vector n -> Vector n
uarrScale Scalar v
μ Vector (Scalar v)
v
                       | Scalar v
t'iforall a. Fractional a => a -> a -> a
/Scalar v
s'i forall a. Ord a => a -> a -> Bool
> Scalar v
0  -> Vector (Scalar v)
samePoint
                       | Bool
otherwise    -> Vector (Scalar v)
antipode
          where d :: Int
d = forall a. Unbox a => Vector a -> Int
UArr.length Vector (Scalar (DualVector v))
t'
                s' :: Vector (Scalar (DualVector v))
s'= forall v.
(FiniteFreeSpace v, Unbox (Scalar v)) =>
v -> Vector (Scalar v)
toFullUnboxVect DualVector v
s; t' :: Vector (Scalar (DualVector v))
t' = forall v.
(FiniteFreeSpace v, Unbox (Scalar v)) =>
v -> Vector (Scalar v)
toFullUnboxVect DualVector v
t
                im :: Int
im = forall a. (Unbox a, Ord a) => Vector a -> Int
UArr.maxIndex forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
UArr.map forall a. Num a => a -> a
abs Vector (Scalar (DualVector v))
t'
                t'i :: Scalar v
t'i = Vector (Scalar (DualVector v))
t' forall a. Unbox a => Vector a -> Int -> a
UArr.! Int
im
                tpro :: Vector (Scalar v)
tpro = let v :: Vector (Scalar v)
v = Vector (Scalar v) -> Vector (Scalar v)
deli Vector (Scalar (DualVector v))
t' in forall n. (Num n, Unbox n) => n -> Vector n -> Vector n
uarrScale (forall a. Fractional a => a -> a
recip Scalar v
t'i) Vector (Scalar v)
v
                delis :: Vector (Scalar v)
delis = Vector (Scalar v) -> Vector (Scalar v)
deli Vector (Scalar (DualVector v))
s'
                deli :: Vector (Scalar v) -> Vector (Scalar v)
deli Vector (Scalar v)
v = forall (v :: * -> *) a. Vector v a => Int -> v a -> v a
Arr.take Int
im Vector (Scalar v)
v forall (v :: * -> *) a. Vector v a => v a -> v a -> v a
Arr.++ forall (v :: * -> *) a. Vector v a => Int -> v a -> v a
Arr.drop (Int
imforall a. Num a => a -> a -> a
+Int
1) Vector (Scalar v)
v
                samePoint :: Vector (Scalar v)
samePoint = forall a. Unbox a => Int -> a -> Vector a
UArr.replicate (Int
dforall a. Num a => a -> a -> a
-Int
1) Scalar v
0
                antipode :: Vector (Scalar v)
antipode = (Int
dforall a. Num a => a -> a -> a
-Int
1) forall a. Unbox a => Int -> [a] -> Vector a
`UArr.fromListN` (Scalar v
2 forall a. a -> [a] -> [a]
: forall a. a -> [a]
repeat Scalar v
0)


-- instance ( WithField ℝ HilbertManifold x ) => ConeSemimfd (Stiefel1 x) where
--   type CℝayInterior (Stiefel1 x) = x


l2norm :: (Floating s, UArr.Unbox s) => UArr.Vector s -> s
l2norm :: forall s. (Floating s, Unbox s) => Vector s -> s
l2norm = forall a. Floating a => a -> a
sqrt 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. (Unbox a, Num a) => Vector a -> a
UArr.sum 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. (Unbox a, Unbox b) => (a -> b) -> Vector a -> Vector b
UArr.map (forall a. Num a => a -> Int -> a
^Int
2)




data Line x = Line { forall x. Line x -> x
lineHandle :: x
                   , forall x. Line x -> Stiefel1 (Needle' x)
lineDirection :: Stiefel1 (Needle' x) }



-- | Oriented hyperplanes, na&#xef;vely generalised to 'PseudoAffine' manifolds:
--   @'Cutplane' p w@ represents the set of all points 'q' such that
--   @(q.-~.p) ^\<.\> w &#x2261; 0@.
-- 
--   In vector spaces this is indeed a hyperplane; for general manifolds it should
--   behave locally as a plane, globally as an (/n/−1)-dimensional submanifold.
data Cutplane x = Cutplane { forall x. Cutplane x -> x
sawHandle :: x
                           , forall x. Cutplane x -> Stiefel1 (Needle x)
cutNormal :: Stiefel1 (Needle x) }
deriving instance (Show x, Show (Needle' x)) => Show (Cutplane x)

normalPlane :: x         -- ^ Some point lying in the desired plane.
            -> Needle' x -- ^ Co-vector perpendicular to the plane. Must be nonzero.
            -> Cutplane x
normalPlane :: forall x. x -> Needle' x -> Cutplane x
normalPlane x
x Needle' x
n = forall x. x -> Stiefel1 (Needle x) -> Cutplane x
Cutplane x
x forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall v. DualVector v -> Stiefel1 v
Stiefel1 Needle' x
n


sideOfCut :: (WithField ℝ PseudoAffine x, LinearSpace (Needle x))
                   => Cutplane x -> x -> Maybe S⁰
sideOfCut :: forall x.
(WithField ℝ PseudoAffine x, LinearSpace (Needle x)) =>
Cutplane x -> x -> Maybe S⁰
sideOfCut (Cutplane x
sh (Stiefel1 DualVector (Needle x)
cn)) x
p
              = forall {a} {m :: * -> *} {r}.
(Num a, MonadPlus m, Ord a) =>
a -> m (S⁰_ r)
decideSide 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
. (DualVector (Needle x)
cnforall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^) forall (m :: * -> *) (k :: * -> * -> *) a b.
(Monad m k, Object k a, Object k b, Object k (m a), Object k (m b),
 Object k (m (m b))) =>
k a (m b) -> k (m a) (m b)
=<< x
pforall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
sh
 where decideSide :: a -> m (S⁰_ r)
decideSide a
0 = forall (m :: * -> *) a. MonadZero m (->) => m a
mzero
       decideSide a
μ | a
μ forall a. Ord a => a -> a -> Bool
> a
0      = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure forall r. S⁰_ r
PositiveHalfSphere
                    | Bool
otherwise  = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure forall r. S⁰_ r
NegativeHalfSphere


fathomCutDistance :: ∀ x . (WithField ℝ PseudoAffine x, LinearSpace (Needle x))
        => Cutplane x        -- ^ Hyperplane to measure the distance from.
         -> Metric' x        -- ^ Metric to use for measuring that distance.
                             --   This can only be accurate if the metric
                             --   is valid both around the cut-plane's 'sawHandle', and
                             --   around the points you measure.
                             --   (Strictly speaking, we would need /parallel transport/
                             --   to ensure this).
         -> x                -- ^ Point to measure the distance to.
         -> Maybe ℝ          -- ^ A signed number, giving the distance from plane
                             --   to point with indication on which side the point lies.
                             --   'Nothing' if the point isn't reachable from the plane.
fathomCutDistance :: forall x.
(WithField ℝ PseudoAffine x, LinearSpace (Needle x)) =>
Cutplane x -> Metric' x -> x -> Maybe ℝ
fathomCutDistance = DualSpaceWitness (Needle x)
-> Cutplane x -> Norm (Needle' x) -> x -> Maybe ℝ
fcd forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness
 where fcd :: DualSpaceWitness (Needle x)
-> Cutplane x -> Norm (Needle' x) -> x -> Maybe ℝ
fcd (DualSpaceWitness (Needle x)
DualSpaceWitness :: DualSpaceWitness (Needle x))
           (Cutplane x
sh (Stiefel1 Needle' x
cn)) Norm (Needle' x)
met
               = \x
x -> 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 Needle x -> Scalar (Needle x)
fathom forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ x
x forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~. x
sh
        where fathom :: Needle x -> Scalar (Needle x)
fathom Needle x
v = (Needle' x
cn forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^ Needle x
v) forall a. Fractional a => a -> a -> a
/ Scalar (Needle' x)
scaleDist
              scaleDist :: Scalar (Needle' x)
scaleDist = Norm (Needle' x)
metforall v.
(LSpace v, Floating (Scalar v)) =>
Seminorm v -> v -> Scalar v
|$|Needle' x
cn
          

cutPosBetween :: WithField ℝ Manifold x => Cutplane x -> (x,x) -> Maybe D¹
cutPosBetween :: forall x.
WithField ℝ Manifold x =>
Cutplane x -> (x, x) -> Maybe D¹
cutPosBetween (Cutplane x
h (Stiefel1 DualVector (Needle x)
cn)) (x
x₀,x
x₁)
    | Just [Scalar (Needle x)
d₀,Scalar (Needle x)
d₁] <- forall a b. (a -> b) -> [a] -> [b]
map (DualVector (Needle x)
cnforall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^) forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [x
x₀forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
h, x
x₁forall x. PseudoAffine x => x -> x -> Maybe (Needle x)
.-~.x
h]
    , Scalar (Needle x)
d₀forall a. Num a => a -> a -> a
*Scalar (Needle x)
d₁ forall a. Ord a => a -> a -> Bool
< Scalar (Needle x)
0  = forall (f :: * -> *) (r :: * -> * -> *) (t :: * -> * -> *) a.
(Applicative f r t, Object r a, Object t (f a)) =>
t a (f a)
pure 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 r. r -> D¹_ r
D¹ forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Scalar (Needle x)
2 forall a. Num a => a -> a -> a
* Scalar (Needle x)
d₀ forall a. Fractional a => a -> a -> a
/ (Scalar (Needle x)
d₀ forall a. Num a => a -> a -> a
- Scalar (Needle x)
d₁) forall a. Num a => a -> a -> a
- Scalar (Needle x)
1
    | Bool
otherwise  = forall (f :: * -> *) a. Alternative f => f a
empty


lineAsPlaneIntersection :: ∀ x .
       (WithField ℝ Manifold x, FiniteDimensional (Needle' x))
           => Line x -> [Cutplane x]
lineAsPlaneIntersection :: forall x.
(WithField ℝ Manifold x, FiniteDimensional (Needle' x)) =>
Line x -> [Cutplane x]
lineAsPlaneIntersection = DualSpaceWitness (Needle x) -> Line x -> [Cutplane x]
lapi forall v. LinearSpace v => DualSpaceWitness v
dualSpaceWitness
 where lapi :: DualSpaceWitness (Needle x) -> Line x -> [Cutplane x]
lapi (DualSpaceWitness (Needle x)
DualSpaceWitness :: DualSpaceWitness (Needle x)) (Line x
h (Stiefel1 DualVector (Needle' x)
dir))
             = [ forall x. x -> Stiefel1 (Needle x) -> Cutplane x
Cutplane x
h 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. DualVector v -> Stiefel1 v
Stiefel1
                     forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ Needle' x
candidate forall v. AdditiveGroup v => v -> v -> v
^-^ Needle' x
worstCandidate forall v s. (VectorSpace v, s ~ Scalar v) => v -> s -> v
^* (ℝ
overlapforall a. Fractional a => a -> a -> a
/ℝ
worstOvlp)
               | (Int
i, (Needle' x
candidate, ℝ
overlap)) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Needle' x]
candidates [ℝ]
overlaps
               , Int
i forall a. Eq a => a -> a -> Bool
/= Int
worstId ]
        where candidates :: [Needle' x]
candidates = forall v. FiniteDimensional v => SubBasis v -> [v]
enumerateSubBasis forall v. FiniteDimensional v => SubBasis v
entireBasis
              overlaps :: [ℝ]
overlaps = (forall v. LinearSpace v => DualVector v -> v -> Scalar v
<.>^DualVector (Needle' x)
dir) forall (f :: * -> *) (r :: * -> * -> *) a b.
(Functor f r (->), Object r a, Object r b) =>
r a b -> f a -> f b
<$> [Needle' x]
candidates
              (Int
worstId, ℝ
worstOvlp) = forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
maximumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a. Num a => a -> a
abs 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 :: * -> * -> *) x y.
(PreArrow a, ObjectPair a x y) =>
a (x, y) y
snd) forall (f :: * -> * -> *) a b.
(Function f, Object f a, Object f b) =>
f a b -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [ℝ]
overlaps
              worstCandidate :: Needle' x
worstCandidate = [Needle' x]
candidates forall a. [a] -> Int -> a
!! Int
worstId