{-# LANGUAGE TypeOperators, TypeFamilies, UndecidableInstances
  , FlexibleInstances, MultiParamTypeClasses, CPP  #-}
{-# LANGUAGE DefaultSignatures    #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
----------------------------------------------------------------------
-- |
-- Module      :  Data.Basis
-- Copyright   :  (c) Conal Elliott 2008
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Basis of a vector space, as an associated type
-- This module requires ghc-6.10 or later
----------------------------------------------------------------------

module Data.Basis (HasBasis(..), linearCombo, recompose) where

-- import Control.Applicative ((<$>))
import Control.Arrow (first)
import Data.Ratio
import Foreign.C.Types (CFloat, CDouble)
-- import Data.Either

import Data.VectorSpace

import Data.VectorSpace.Generic
import qualified GHC.Generics as Gnrx
import GHC.Generics (Generic, (:*:)(..))

-- using associated data type instead of associated type synonym to work
-- around ghc bug <http://hackage.haskell.org/trac/ghc/ticket/3038>

class VectorSpace v => HasBasis v where
  -- | Representation of the canonical basis for @v@
  type Basis v :: *
  type Basis v = Basis (VRep v)
  -- | Interpret basis rep as a vector
  basisValue   :: Basis v -> v
  default basisValue :: (Generic v, HasBasis (VRep v), Basis (VRep v) ~ Basis v)
                    => Basis v -> v
  basisValue Basis v
b = Rep v Void -> v
forall a x. Generic a => Rep a x -> a
Gnrx.to (Basis (Rep v Void) -> Rep v Void
forall v. HasBasis v => Basis v -> v
basisValue Basis v
Basis (Rep v Void)
b :: VRep v)
  -- | Extract coordinates
  decompose    :: v -> [(Basis v, Scalar v)]
  default decompose :: ( Generic v, HasBasis (VRep v)
                       , Scalar (VRep v) ~ Scalar v, Basis (VRep v) ~ Basis v )
                    => v -> [(Basis v, Scalar v)]
  decompose v
v = Rep v Void -> [(Basis (Rep v Void), Scalar (Rep v Void))]
forall v. HasBasis v => v -> [(Basis v, Scalar v)]
decompose (v -> Rep v Void
forall a x. Generic a => a -> Rep a x
Gnrx.from v
v :: VRep v)
  -- | Experimental version.  More elegant definitions, and friendly to
  -- infinite-dimensional vector spaces.
  decompose'   :: v -> (Basis v -> Scalar v)
  default decompose' :: ( Generic v, HasBasis (VRep v)
                        , Scalar (VRep v) ~ Scalar v, Basis (VRep v) ~ Basis v )
                    => v -> Basis v -> Scalar v
  decompose' v
v = Rep v Void -> Basis (Rep v Void) -> Scalar (Rep v Void)
forall v. HasBasis v => v -> Basis v -> Scalar v
decompose' (v -> Rep v Void
forall a x. Generic a => a -> Rep a x
Gnrx.from v
v :: VRep v)

-- Defining property: recompose . decompose == id

-- Turn a basis decomposition back into a vector.
recompose :: HasBasis v => [(Basis v, Scalar v)] -> v
recompose :: [(Basis v, Scalar v)] -> v
recompose = [(v, Scalar v)] -> v
forall v. VectorSpace v => [(v, Scalar v)] -> v
linearCombo ([(v, Scalar v)] -> v)
-> ([(Basis v, Scalar v)] -> [(v, Scalar v)])
-> [(Basis v, Scalar v)]
-> v
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Basis v, Scalar v) -> (v, Scalar v))
-> [(Basis v, Scalar v)] -> [(v, Scalar v)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Basis v -> v) -> (Basis v, Scalar v) -> (v, Scalar v)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Basis v -> v
forall v. HasBasis v => Basis v -> v
basisValue)

-- recompose ps = linearCombo (first basisValue <$> ps)

-- I don't know how to define
-- 
--   recompose' :: HasBasis v => (Basis v -> Scalar v) -> v
-- 
-- However, I don't seem to use recompose anywhere.
-- I don't even use basisValue or decompose.

#define ScalarTypeCon(con,t) \
  instance con => HasBasis (t) where \
    { type Basis (t) = () \
    ; basisValue ()  = 1 \
    ; decompose s    = [((),s)] \
    ; decompose' s   = const s }

#define ScalarType(t) ScalarTypeCon((),t)

ScalarType(Float)
ScalarType(CFloat)
ScalarType(Double)
ScalarType(CDouble)
ScalarTypeCon(Integral a, Ratio a)

instance ( HasBasis u, s ~ Scalar u
         , HasBasis v, s ~ Scalar v )
      => HasBasis (u,v) where
  type Basis (u,v)     = Basis u `Either` Basis v
  basisValue :: Basis (u, v) -> (u, v)
basisValue (Left  a) = (Basis u -> u
forall v. HasBasis v => Basis v -> v
basisValue Basis u
a, v
forall v. AdditiveGroup v => v
zeroV)
  basisValue (Right b) = (u
forall v. AdditiveGroup v => v
zeroV, Basis v -> v
forall v. HasBasis v => Basis v -> v
basisValue Basis v
b)
  decompose :: (u, v) -> [(Basis (u, v), Scalar (u, v))]
decompose  (u
u,v
v)     = (Basis u -> Either (Basis u) (Basis v))
-> u -> [(Either (Basis u) (Basis v), Scalar u)]
forall w b. HasBasis w => (Basis w -> b) -> w -> [(b, Scalar w)]
decomp2 Basis u -> Either (Basis u) (Basis v)
forall a b. a -> Either a b
Left u
u [(Either (Basis u) (Basis v), s)]
-> [(Either (Basis u) (Basis v), s)]
-> [(Either (Basis u) (Basis v), s)]
forall a. [a] -> [a] -> [a]
++ (Basis v -> Either (Basis u) (Basis v))
-> v -> [(Either (Basis u) (Basis v), Scalar v)]
forall w b. HasBasis w => (Basis w -> b) -> w -> [(b, Scalar w)]
decomp2 Basis v -> Either (Basis u) (Basis v)
forall a b. b -> Either a b
Right v
v
  decompose' :: (u, v) -> Basis (u, v) -> Scalar (u, v)
decompose' (u
u,v
v)     = u -> Basis u -> Scalar u
forall v. HasBasis v => v -> Basis v -> Scalar v
decompose' u
u (Basis u -> s) -> (Basis v -> s) -> Either (Basis u) (Basis v) -> s
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
`either` v -> Basis v -> Scalar v
forall v. HasBasis v => v -> Basis v -> Scalar v
decompose' v
v


decomp2 :: HasBasis w => (Basis w -> b) -> w -> [(b, Scalar w)]
decomp2 :: (Basis w -> b) -> w -> [(b, Scalar w)]
decomp2 Basis w -> b
inject = ((Basis w, Scalar w) -> (b, Scalar w))
-> [(Basis w, Scalar w)] -> [(b, Scalar w)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Basis w -> b) -> (Basis w, Scalar w) -> (b, Scalar w)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first Basis w -> b
inject) ([(Basis w, Scalar w)] -> [(b, Scalar w)])
-> (w -> [(Basis w, Scalar w)]) -> w -> [(b, Scalar w)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. w -> [(Basis w, Scalar w)]
forall v. HasBasis v => v -> [(Basis v, Scalar v)]
decompose

instance ( HasBasis u, s ~ Scalar u
         , HasBasis v, s ~ Scalar v
         , HasBasis w, s ~ Scalar w )
      => HasBasis (u,v,w) where
  type Basis (u,v,w) = Basis (u,(v,w))
  basisValue :: Basis (u, v, w) -> (u, v, w)
basisValue         = (u, (v, w)) -> (u, v, w)
forall a b c. (a, (b, c)) -> (a, b, c)
unnest3 ((u, (v, w)) -> (u, v, w))
-> (Either (Basis u) (Either (Basis v) (Basis w)) -> (u, (v, w)))
-> Either (Basis u) (Either (Basis v) (Basis w))
-> (u, v, w)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either (Basis u) (Either (Basis v) (Basis w)) -> (u, (v, w))
forall v. HasBasis v => Basis v -> v
basisValue
  decompose :: (u, v, w) -> [(Basis (u, v, w), Scalar (u, v, w))]
decompose          = (u, (v, w)) -> [(Either (Basis u) (Either (Basis v) (Basis w)), s)]
forall v. HasBasis v => v -> [(Basis v, Scalar v)]
decompose  ((u, (v, w))
 -> [(Either (Basis u) (Either (Basis v) (Basis w)), s)])
-> ((u, v, w) -> (u, (v, w)))
-> (u, v, w)
-> [(Either (Basis u) (Either (Basis v) (Basis w)), s)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (u, v, w) -> (u, (v, w))
forall a b c. (a, b, c) -> (a, (b, c))
nest3
  decompose' :: (u, v, w) -> Basis (u, v, w) -> Scalar (u, v, w)
decompose'         = (u, (v, w)) -> Either (Basis u) (Either (Basis v) (Basis w)) -> s
forall v. HasBasis v => v -> Basis v -> Scalar v
decompose' ((u, (v, w)) -> Either (Basis u) (Either (Basis v) (Basis w)) -> s)
-> ((u, v, w) -> (u, (v, w)))
-> (u, v, w)
-> Either (Basis u) (Either (Basis v) (Basis w))
-> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (u, v, w) -> (u, (v, w))
forall a b c. (a, b, c) -> (a, (b, c))
nest3

unnest3 :: (a,(b,c)) -> (a,b,c)
unnest3 :: (a, (b, c)) -> (a, b, c)
unnest3 (a
a,(b
b,c
c)) = (a
a,b
b,c
c)

nest3 :: (a,b,c) -> (a,(b,c))
nest3 :: (a, b, c) -> (a, (b, c))
nest3 (a
a,b
b,c
c) = (a
a,(b
b,c
c))


-- instance (Eq a, HasBasis u) => HasBasis (a -> u) where
--   type Basis (a -> u) = (a, Basis u)
--   basisValue (a,b) = f
--     where f a' | a == a'   = bv
--                | otherwise = zeroV
--           bv = basisValue b
--   decompose = error "decompose: not defined on functions"
--   decompose' g (a,b) = decompose' (g a) b


-- Simpler but less efficient:
-- 
--   basisValue (a,b) a' | a == a'   = basisValue b
--                       | otherwise = zeroV

-- Just for pointless perversion points:
-- 
--   decompose' g = uncurry (\ a b -> decompose' (g a) b)
--   decompose' g = uncurry (\ a -> decompose' (g a))
--   decompose' g = uncurry (decompose' . g)
--   decompose' = uncurry . fmap decompose'
--   decompose' = (fmap uncurry) (fmap decompose')


{-

---- Testing

t1 = basisValue () :: Float
t2 = basisValue () :: Double
t3 = basisValue (Right ()) :: (Float,Double)
t4 = basisValue (Right (Left ())) :: (Float,Double,Float)

-}

instance HasBasis a => HasBasis (Gnrx.Rec0 a s) where
  type Basis (Gnrx.Rec0 a s) = Basis a
  basisValue :: Basis (Rec0 a s) -> Rec0 a s
basisValue = a -> Rec0 a s
forall k i c (p :: k). c -> K1 i c p
Gnrx.K1 (a -> Rec0 a s) -> (Basis a -> a) -> Basis a -> Rec0 a s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Basis a -> a
forall v. HasBasis v => Basis v -> v
basisValue
  decompose :: Rec0 a s -> [(Basis (Rec0 a s), Scalar (Rec0 a s))]
decompose = a -> [(Basis a, Scalar a)]
forall v. HasBasis v => v -> [(Basis v, Scalar v)]
decompose (a -> [(Basis a, Scalar a)])
-> (Rec0 a s -> a) -> Rec0 a s -> [(Basis a, Scalar a)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rec0 a s -> a
forall i c k (p :: k). K1 i c p -> c
Gnrx.unK1
  decompose' :: Rec0 a s -> Basis (Rec0 a s) -> Scalar (Rec0 a s)
decompose' = a -> Basis a -> Scalar a
forall v. HasBasis v => v -> Basis v -> Scalar v
decompose' (a -> Basis a -> Scalar a)
-> (Rec0 a s -> a) -> Rec0 a s -> Basis a -> Scalar a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rec0 a s -> a
forall i c k (p :: k). K1 i c p -> c
Gnrx.unK1
instance HasBasis (f p) => HasBasis (Gnrx.M1 i c f p) where
  type Basis (Gnrx.M1 i c f p) = Basis (f p)
  basisValue :: Basis (M1 i c f p) -> M1 i c f p
basisValue = f p -> M1 i c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
Gnrx.M1 (f p -> M1 i c f p)
-> (Basis (f p) -> f p) -> Basis (f p) -> M1 i c f p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Basis (f p) -> f p
forall v. HasBasis v => Basis v -> v
basisValue
  decompose :: M1 i c f p -> [(Basis (M1 i c f p), Scalar (M1 i c f p))]
decompose = f p -> [(Basis (f p), Scalar (f p))]
forall v. HasBasis v => v -> [(Basis v, Scalar v)]
decompose (f p -> [(Basis (f p), Scalar (f p))])
-> (M1 i c f p -> f p)
-> M1 i c f p
-> [(Basis (f p), Scalar (f p))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 i c f p -> f p
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
Gnrx.unM1
  decompose' :: M1 i c f p -> Basis (M1 i c f p) -> Scalar (M1 i c f p)
decompose' = f p -> Basis (f p) -> Scalar (f p)
forall v. HasBasis v => v -> Basis v -> Scalar v
decompose' (f p -> Basis (f p) -> Scalar (f p))
-> (M1 i c f p -> f p) -> M1 i c f p -> Basis (f p) -> Scalar (f p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. M1 i c f p -> f p
forall i (c :: Meta) k (f :: k -> *) (p :: k). M1 i c f p -> f p
Gnrx.unM1
instance (HasBasis (f p), HasBasis (g p), Scalar (f p) ~ Scalar (g p))
         => HasBasis ((f :*: g) p) where
  type Basis ((f:*:g) p) = Either (Basis (f p)) (Basis (g p))
  basisValue :: Basis ((:*:) f g p) -> (:*:) f g p
basisValue (Left bf) = Basis (f p) -> f p
forall v. HasBasis v => Basis v -> v
basisValue Basis (f p)
bf f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: g p
forall v. AdditiveGroup v => v
zeroV
  basisValue (Right bg) = f p
forall v. AdditiveGroup v => v
zeroV f p -> g p -> (:*:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k).
f p -> g p -> (:*:) f g p
:*: Basis (g p) -> g p
forall v. HasBasis v => Basis v -> v
basisValue Basis (g p)
bg
  decompose :: (:*:) f g p -> [(Basis ((:*:) f g p), Scalar ((:*:) f g p))]
decompose  (f p
u:*:g p
v)     = (Basis (f p) -> Either (Basis (f p)) (Basis (g p)))
-> f p -> [(Either (Basis (f p)) (Basis (g p)), Scalar (f p))]
forall w b. HasBasis w => (Basis w -> b) -> w -> [(b, Scalar w)]
decomp2 Basis (f p) -> Either (Basis (f p)) (Basis (g p))
forall a b. a -> Either a b
Left f p
u [(Either (Basis (f p)) (Basis (g p)), Scalar (g p))]
-> [(Either (Basis (f p)) (Basis (g p)), Scalar (g p))]
-> [(Either (Basis (f p)) (Basis (g p)), Scalar (g p))]
forall a. [a] -> [a] -> [a]
++ (Basis (g p) -> Either (Basis (f p)) (Basis (g p)))
-> g p -> [(Either (Basis (f p)) (Basis (g p)), Scalar (g p))]
forall w b. HasBasis w => (Basis w -> b) -> w -> [(b, Scalar w)]
decomp2 Basis (g p) -> Either (Basis (f p)) (Basis (g p))
forall a b. b -> Either a b
Right g p
v
  decompose' :: (:*:) f g p -> Basis ((:*:) f g p) -> Scalar ((:*:) f g p)
decompose' (f p
u:*:g p
v)     = f p -> Basis (f p) -> Scalar (f p)
forall v. HasBasis v => v -> Basis v -> Scalar v
decompose' f p
u (Basis (f p) -> Scalar (g p))
-> (Basis (g p) -> Scalar (g p))
-> Either (Basis (f p)) (Basis (g p))
-> Scalar (g p)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
`either` g p -> Basis (g p) -> Scalar (g p)
forall v. HasBasis v => v -> Basis v -> Scalar v
decompose' g p
v