    {-# 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.Kind
    -- 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
      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 = VRep v -> v
    forall a x. Generic a => Rep a x -> a
    forall x. Rep v x -> v
    Gnrx.to (Basis (VRep v) -> VRep v
    forall v. HasBasis v => Basis v -> v
    basisValue Basis v
    Basis (VRep v)
    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 = VRep v -> [(Basis (VRep v), Scalar (VRep v))]
    forall v. HasBasis v => v -> [(Basis v, Scalar v)]
    decompose (v -> VRep v
    forall x. v -> Rep v x
    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 = VRep v -> Basis (VRep v) -> Scalar (VRep v)
    forall v. HasBasis v => v -> Basis v -> Scalar v
    decompose' (v -> VRep v
    forall x. v -> Rep v x
    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 :: forall v. HasBasis v => [(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 a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((Basis v -> v) -> (Basis v, Scalar v) -> (v, Scalar v)
    forall b c d. (b -> c) -> (b, d) -> (c, d)
    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  Basis u
    a) = (Basis u -> u
    forall v. HasBasis v => Basis v -> v
    basisValue Basis u
    a, v
    forall v. AdditiveGroup v => v
    zeroV)
      basisValue (Right Basis v
    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 :: forall w b. HasBasis w => (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 a b. (a -> b) -> [a] -> [b]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ((Basis w -> b) -> (Basis w, Scalar w) -> (b, Scalar w)
    forall b c d. (b -> c) -> (b, d) -> (c, d)
    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))
    Basis (u, (v, 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)]
    (u, (v, w)) -> [(Basis (u, (v, w)), Scalar (u, (v, w)))]
    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
    (u, (v, w)) -> Basis (u, (v, w)) -> Scalar (u, (v, w))
    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 :: forall a b c. (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 :: forall a b c. (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 k i c (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 k i c (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 k i (c :: Meta) (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 k i (c :: Meta) (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 Basis (f p)
    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 Basis (g p)
    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