{-# LANGUAGE TypeFamilies, FlexibleContexts #-}
{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable, DeriveDataTypeable, UndecidableInstances #-}
{-# LANGUAGE TupleSections #-}
module Data.Map.Vector (MapVector(..)) where
import Prelude hiding (foldr)
import Data.Foldable
import Data.Traversable
import Data.Data
import Control.Applicative
import Control.Arrow
import Data.AdditiveGroup
import Data.VectorSpace
import Data.Basis
import Data.Map (Map)
import qualified Data.Map as Map
data MapVector k v =
MapVector (Map k v)
| ConstantMap v
deriving (Eq, Functor, Show, Read, Foldable, Traversable, Typeable, Data)
instance Semigroup (MapVector k v) where
(<>) a b = a <> b
instance (Ord k, Monoid v) => Monoid (MapVector k v) where
mempty = pure mempty
instance (Ord k) => Applicative (MapVector k) where
pure = ConstantMap
(ConstantMap f) <*> (ConstantMap v) = ConstantMap $ f v
(ConstantMap f) <*> (MapVector vs) = MapVector $ f <$> vs
(MapVector fs) <*> (ConstantMap v) = MapVector $ ($ v) <$> fs
(MapVector fs) <*> (MapVector vs) = MapVector $ Map.intersectionWith ($) fs vs
{-# INLINABLE (<*>) #-}
instance (AdditiveGroup v, Ord k) => AdditiveGroup (MapVector k v) where
zeroV = MapVector Map.empty
negateV = fmap negateV
(ConstantMap v) ^+^ (ConstantMap v') = ConstantMap $ v ^+^ v'
(ConstantMap v) ^+^ (MapVector vs) = MapVector $ (v ^+^) <$> vs
(MapVector vs) ^+^ (ConstantMap v) = MapVector $ (^+^ v) <$> vs
(MapVector vs) ^+^ (MapVector vs') = MapVector $ Map.unionWith (^+^) vs vs'
{-# INLINABLE (^+^) #-}
instance (Ord k, VectorSpace v) => VectorSpace (MapVector k v) where
type Scalar (MapVector k v) = Scalar v
s *^ v = (s *^) <$> v
{-# INLINABLE (*^) #-}
instance (Ord k, VectorSpace v, InnerSpace v, AdditiveGroup (Scalar v)) => InnerSpace (MapVector k v) where
(ConstantMap v) <.> (ConstantMap v') = v <.> v'
(ConstantMap v) <.> (MapVector vs) = foldl' (^+^) zeroV $ (v <.>) <$> vs
(MapVector vs) <.> (ConstantMap v) = foldl' (^+^) zeroV $ (<.> v) <$> vs
(MapVector vs) <.> (MapVector vs') = foldl' (^+^) zeroV $ Map.intersectionWith (<.>) vs vs'
{-# INLINABLE (<.>) #-}
instance (Ord k, HasBasis v, AdditiveGroup (Scalar v)) => HasBasis (MapVector k v) where
type Basis (MapVector k v) = (k, Basis v)
basisValue (k, v) = MapVector $ Map.fromList $ (k, basisValue v):[]
decompose (MapVector vs)
= Map.toList (decompose<$>vs) >>= \(k,vs) -> first(k,)<$>vs
decompose (ConstantMap _) = error "decompose: not defined for ConstantMap.\
\ Use decompose', which works properly on infinite-dimensional spaces."
decompose' (MapVector vs) (k,bv) = case Map.lookup k vs of
Nothing -> zeroV
Just v -> decompose' v bv
decompose' (ConstantMap c) (_,bv) = decompose' c bv