{-| Module : Multilinear.Generic.AsArray Description : Generic array tensor Copyright : (c) Artur M. Brodzki, 2018 License : BSD3 Maintainer : artur@brodzki.org Stability : experimental Portability : Windows/POSIX - This module contains generic implementation of tensor defined as nested arrays -} module Multilinear.Generic ( Tensor(..), (!), mergeScalars, isScalar, isSimple, isFiniteTensor, isInfiniteTensor, dot, _elemByElem, contractionErr, tensorIndex, _standardize ) where import Control.DeepSeq import Data.Bits import Data.Foldable import Data.List import Data.Maybe import qualified Data.Vector as Boxed import GHC.Generics import Multilinear.Class as Multilinear import qualified Multilinear.Index as Index import qualified Multilinear.Index.Finite as Finite import qualified Multilinear.Index.Infinite as Infinite {-| ERROR MESSAGES -} incompatibleTypes :: String incompatibleTypes = "Incompatible tensor types!" scalarIndices :: String scalarIndices = "Scalar has no indices!" infiniteIndex :: String infiniteIndex = "Index is infinitely-dimensional!" infiniteTensor :: String infiniteTensor = "This tensor is infinitely-dimensional and cannot be printed!" indexNotFound :: String indexNotFound = "This tensor has not such index!" {-| Tensor defined recursively as scalar or list of other tensors -} {-| @c@ is type of a container, @i@ is type of index size and @a@ is type of tensor elements -} data Tensor a = {-| Scalar -} Scalar { {-| value of scalar -} scalarVal :: a } | {-| Simple, one-dimensional finite tensor -} SimpleFinite { tensorFiniteIndex :: Finite.Index, tensorScalars :: Boxed.Vector a } | {-| Finite array of other tensors -} FiniteTensor { {-| Finite index "Mutltilinear.Index.Finite" of tensor -} tensorFiniteIndex :: Finite.Index, {-| Array of tensors on deeper recursion level -} tensorsFinite :: Boxed.Vector (Tensor a) } | {-| Infinite list of other tensors -} InfiniteTensor { {-| Infinite index "Mutltilinear.Index.Infinite" of tensor -} tensorInfiniteIndex :: Infinite.Index, {-| Infinite list of tensors on deeper recursion level -} tensorsInfinite :: [Tensor a] } | {-| Operations on tensors may throw an error -} Err { {-| Error message -} errMessage :: String } deriving (Eq, Generic) {-| Return true if tensor is a scalar -} {-# INLINE isScalar #-} isScalar :: Tensor a -> Bool isScalar x = case x of Scalar _ -> True _ -> False {-| Return true if tensor is a simple tensor -} {-# INLINE isSimple #-} isSimple :: Tensor a -> Bool isSimple x = case x of SimpleFinite _ _ -> True _ -> False {-| Return True if tensor is a complex tensor -} {-# INLINE isFiniteTensor #-} isFiniteTensor :: Tensor a -> Bool isFiniteTensor x = case x of FiniteTensor _ _ -> True _ -> False {-| Return True if tensor is a infinite tensor -} {-# INLINE isInfiniteTensor #-} isInfiniteTensor :: Tensor a -> Bool isInfiniteTensor x = case x of InfiniteTensor _ _ -> True _ -> False {- Return True if tensor is a error tensor -} {-# INLINE isErrTensor #-} isErrTensor :: Tensor a -> Bool isErrTensor x = case x of Err _ -> True _ -> False {-| Return generic tensor index -} {-# INLINE tensorIndex #-} tensorIndex :: Tensor a -> Index.TIndex tensorIndex x = case x of Scalar _ -> error scalarIndices SimpleFinite i _ -> Index.toTIndex i FiniteTensor i _ -> Index.toTIndex i InfiniteTensor i _ -> Index.toTIndex i Err msg -> error msg {-| Return True if tensor has no elements -} {-# INLINE isEmptyTensor #-} isEmptyTensor :: Tensor a -> Bool isEmptyTensor x = case x of Scalar _ -> False SimpleFinite _ ts -> Boxed.null ts FiniteTensor _ ts -> Boxed.null ts InfiniteTensor _ ts -> null ts Err _ -> False {-| Returns sample element of the tensor. Used to determine some features common for all elements, like bit-qualities. -} {-# INLINE firstElem #-} firstElem :: Tensor a -> a firstElem x = case x of Scalar val -> val SimpleFinite _ ts -> Boxed.head ts FiniteTensor _ ts -> firstElem $ Boxed.head ts InfiniteTensor _ ts -> firstElem $ head ts Err msg -> error msg {-| Returns sample tensor on deeper recursion level.Used to determine some features common for all tensors -} {-# INLINE firstTensor #-} firstTensor :: Tensor a -> Tensor a firstTensor x = case x of FiniteTensor _ ts -> Boxed.head ts InfiniteTensor _ ts -> Data.List.head ts _ -> x {-| Recursive indexing on list tensor @t ! i = t[i]@ -} {-# INLINE (!) #-} (!) :: Tensor a -- ^ tensor @t@ -> Int -- ^ index @i@ -> Tensor a -- ^ tensor @t[i]@ t ! i = case t of Scalar _ -> Err scalarIndices Err msg -> Err msg SimpleFinite ind ts -> if i >= Finite.indexSize ind then error ("Index + " ++ show ind ++ " out of bonds!") else Scalar $ ts Boxed.! i FiniteTensor ind ts -> if i >= Finite.indexSize ind then error ("Index + " ++ show ind ++ " out of bonds!") else ts Boxed.! i InfiniteTensor _ ts -> ts !! i -- NFData instance instance NFData a => NFData (Tensor a) -- move contravariant indices to lower recursion level _standardize :: Num a => Tensor a -> Tensor a _standardize tens = foldr' (\i t -> if Index.isContravariant i then t <<<| Index.indexName i else t) tens $ indices tens -- Print tensor instance ( Show a, Num a ) => Show (Tensor a) where -- merge errors first and then print whole tensor show = show' . _standardize . _mergeErr where show' x = case x of -- Scalar is showed simply as its value Scalar v -> show v -- SimpleFinite is shown dependent on its index... SimpleFinite index ts -> show index ++ "S: " ++ case index of -- If index is contravariant, show tensor components vertically Finite.Contravariant _ _ -> _showVertical ts -- If index is covariant or indifferent, show tensor compoments horizontally _ -> _showHorizontal ts -- FiniteTensor is shown dependent on its index... FiniteTensor index ts -> show index ++ "T: " ++ case index of -- If index is contravariant, show tensor components vertically Finite.Contravariant _ _ -> _showVertical ts -- If index is covariant or indifferent, show tensor compoments horizontally _ -> _showHorizontal ts -- Infinite tensor print erorr message as it cannot be fully shown InfiniteTensor _ _ -> show infiniteTensor -- Error prints its error message Err msg -> show msg -- Merge many errors in tensor to the first one _mergeErr x = case x of -- Error tensor is passed further Err msg -> Err msg -- FiniteTensor is merged to first error on deeper recursion level FiniteTensor _ ts -> -- find first error if present let err = Data.List.find isErrTensor (_mergeErr <$> ts) -- and return this error if found, whole tensor otherwise in fromMaybe x err -- in other types of tensor cannot be any error _ -> x -- print container elements vertically -- used to show contravariant components of tensor, which by convention are written vertically _showVertical :: (Show a, Foldable c) => c a -> String _showVertical container = "\n" ++ tail (foldl' (\string e -> string ++ "\n |" ++ show e) "" container) -- print container elements horizontally -- used to show covariant (or indifferent) components of tensor, which by convention are written horizontally _showHorizontal :: (Show a, Foldable c) => c a -> String _showHorizontal container = "[" ++ tail (foldl' (\string e -> string ++ "," ++ show e) "" container) ++ "]" -- Tensor is a functor instance Functor Tensor where {-# INLINE fmap #-} fmap f x = case x of -- Mapping scalar simply maps its value Scalar v -> Scalar $ f v -- Mapping complex tensor does mapping element by element SimpleFinite index ts -> SimpleFinite index (f <$> ts) FiniteTensor index ts -> FiniteTensor index $ fmap (fmap f) ts InfiniteTensor index ts -> InfiniteTensor index $ fmap (fmap f) ts -- Mapping errors changes nothing Err msg -> Err msg -- Tensors can be compared lexigographically -- Allowes to put tensors in typical ordered containers instance ( Ord a ) => Ord (Tensor a) where {-# INLINE (<=) #-} -- Error is smaller by other tensors, so when printing ordered containers, all erorrs will be printed first -- Two errors are compared by they messages lexigographically Err msg1 <= Err msg2 = msg1 <= msg2 Err _ <= _ = True _ <= Err _ = False -- Scalar is smaller than any complex tensor -- Two scalars are compared by they values Scalar x1 <= Scalar x2 = x1 <= x2 Scalar _ <= _ = True _ <= Scalar _ = False -- Complex tensors are compared lexigographically SimpleFinite _ ts1 <= SimpleFinite _ ts2 = ts1 <= ts2 FiniteTensor _ ts1 <= FiniteTensor _ ts2 = ts1 <= ts2 InfiniteTensor _ ts1 <= InfiniteTensor _ ts2 = ts1 <= ts2 FiniteTensor _ _ <= SimpleFinite _ _ = False SimpleFinite _ _ <= FiniteTensor _ _ = True InfiniteTensor _ _ <= FiniteTensor _ _ = False FiniteTensor _ _ <= InfiniteTensor _ _ = True InfiniteTensor _ _ <= SimpleFinite _ _ = False SimpleFinite _ _ <= InfiniteTensor _ _ = True {-| Merge FiniteTensor of Scalars to SimpleFinite tensor for performance improvement -} {-# INLINE mergeScalars #-} mergeScalars :: Tensor a -> Tensor a mergeScalars x = case x of (FiniteTensor index1 ts1) -> case ts1 Boxed.! 0 of Scalar _ -> SimpleFinite index1 (scalarVal <$> ts1) _ -> FiniteTensor index1 $ mergeScalars <$> ts1 _ -> x {-| Apply a tensor operator (here denoted by (+) ) elem by elem, trying to connect as many common indices as possible -} {-# INLINE _elemByElem' #-} _elemByElem' :: Num a => Tensor a -- ^ First argument of operator -> Tensor a -- ^ Second argument of operator -> (a -> a -> a) -- ^ Operator on tensor elements if indices are different -> (Tensor a -> Tensor a -> Tensor a) -- ^ Tensor operator called if indices are the same -> Tensor a -- ^ Result tensor -- @Scalar x + Scalar y = Scalar x + y@ _elemByElem' (Scalar x1) (Scalar x2) f _ = Scalar $ f x1 x2 -- @Scalar x + Tensor t[i] = Tensor r[i] | r[i] = x + t[i]@ _elemByElem' (Scalar x) t f _ = (x `f`) <$> t -- @Tensor t[i] + Scalar x = Tensor r[i] | r[i] = t[i] + x@ _elemByElem' t (Scalar x) f _ = (`f` x) <$> t -- Two finite tensors case _elemByElem' t1@(FiniteTensor index1 v1) t2@(FiniteTensor index2 v2) f op | Index.indexName index1 == Index.indexName index2 = op t1 t2 | Index.indexName index1 `Data.List.elem` indicesNames t2 = FiniteTensor index2 $ (\x -> _elemByElem' t1 x f op) <$> v2 | otherwise = FiniteTensor index1 $ (\x -> _elemByElem' x t2 f op) <$> v1 -- Two infinite tensors case _elemByElem' t1@(InfiniteTensor index1 v1) t2@(InfiniteTensor index2 v2) f op | Index.indexName index1 == Index.indexName index2 = op t1 t2 | Index.indexName index1 `Data.List.elem` indicesNames t2 = InfiniteTensor index2 $ (\x -> _elemByElem' t1 x f op) <$> v2 | otherwise = InfiniteTensor index1 $ (\x -> _elemByElem' x t2 f op) <$> v1 -- Two simple tensors case _elemByElem' t1@(SimpleFinite index1 v1) t2@(SimpleFinite index2 _) f op | Index.indexName index1 == Index.indexName index2 = op t1 t2 | otherwise = FiniteTensor index1 $ (\x -> f x <$> t2) <$> v1 -- Finite and infinite tensor case _elemByElem' t1@(FiniteTensor index1 v1) t2@(InfiniteTensor index2 v2) f op | Index.indexName index1 == Index.indexName index2 = op t1 t2 | Index.indexName index1 `Data.List.elem` indicesNames t2 = InfiniteTensor index2 $ (\x -> _elemByElem' t1 x f op) <$> v2 | otherwise = FiniteTensor index1 $ (\x -> _elemByElem' x t2 f op) <$> v1 -- Infinite and finite tensor case _elemByElem' t1@(InfiniteTensor index1 v1) t2@(FiniteTensor index2 v2) f op | Index.indexName index1 == Index.indexName index2 = op t1 t2 | Index.indexName index1 `Data.List.elem` indicesNames t2 = FiniteTensor index2 $ (\x -> _elemByElem' t1 x f op) <$> v2 | otherwise = InfiniteTensor index1 $ (\x -> _elemByElem' x t2 f op) <$> v1 -- Simple and finite tensor case _elemByElem' t1@(SimpleFinite index1 _) t2@(FiniteTensor index2 v2) f op | Index.indexName index1 == Index.indexName index2 = op t1 t2 | otherwise = FiniteTensor index2 $ (\x -> _elemByElem' t1 x f op) <$> v2 -- Finite and simple tensor case _elemByElem' t1@(FiniteTensor index1 v1) t2@(SimpleFinite index2 _) f op | Index.indexName index1 == Index.indexName index2 = op t1 t2 | otherwise = FiniteTensor index1 $ (\x -> _elemByElem' x t2 f op) <$> v1 -- Simple and infinite tensor case _elemByElem' t1@(SimpleFinite index1 _) t2@(InfiniteTensor index2 v2) f op | Index.indexName index1 == Index.indexName index2 = op t1 t2 | otherwise = InfiniteTensor index2 $ (\x -> _elemByElem' t1 x f op) <$> v2 -- Infinite and simple tensor case _elemByElem' t1@(InfiniteTensor index1 v1) t2@(SimpleFinite index2 _) f op | Index.indexName index1 == Index.indexName index2 = op t1 t2 | otherwise = InfiniteTensor index1 $ (\x -> _elemByElem' x t2 f op) <$> v1 -- Appying operator to error tensor simply pushes this error further _elemByElem' (Err msg) _ _ _ = Err msg _elemByElem' _ (Err msg) _ _ = Err msg {-| Apply a tensor operator elem by elem and merge scalars to simple tensor at the and -} {-# INLINE _elemByElem #-} _elemByElem :: Num a => Tensor a -- ^ First argument of operator -> Tensor a -- ^ Second argument of operator -> (a -> a -> a) -- ^ Operator on tensor elements if indices are different -> (Tensor a -> Tensor a -> Tensor a) -- ^ Tensor operator called if indices are the same -> Tensor a -- ^ Result tensor _elemByElem t1 t2 f op = let commonIndices = filter (`Data.List.elem` indicesNames t2) $ indicesNames t1 t1' = foldl' (|>>>) t1 commonIndices t2' = foldl' (|>>>) t2 commonIndices in mergeScalars $ _elemByElem' t1' t2' f op -- Zipping two tensors with a combinator, assuming they have the same indices {-# INLINE zipT #-} zipT :: Num a => (Tensor a -> Tensor a -> Tensor a) -- ^ Two tensors combinator -> (Tensor a -> a -> Tensor a) -- ^ Tensor and scalar combinator -> (a -> Tensor a -> Tensor a) -- ^ Scalar and tensor combinator -> (a -> a -> a) -- ^ Two scalars combinator -> Tensor a -- ^ First tensor to zip -> Tensor a -- ^ Second tensor to zip -> Tensor a -- ^ Result tensor -- Two simple tensors case zipT _ _ _ f (SimpleFinite index1 v1) (SimpleFinite index2 v2) = if index1 == index2 then SimpleFinite index1 $ Boxed.zipWith f v1 v2 else Err incompatibleTypes --Two finite tensors case zipT f _ _ _ (FiniteTensor index1 v1) (FiniteTensor index2 v2) = if index1 == index2 then FiniteTensor index1 $ Boxed.zipWith f v1 v2 else Err incompatibleTypes -- Two infinte tensors case zipT f _ _ _ (InfiniteTensor index1 v1) (InfiniteTensor index2 v2) = if index1 == index2 then InfiniteTensor index1 $ Data.List.zipWith f v1 v2 else Err incompatibleTypes -- Infinite and finite tensor case zipT f _ _ _ (InfiniteTensor _ v1) (FiniteTensor index2 v2) = FiniteTensor index2 $ Boxed.zipWith f (Boxed.fromList $ take (Boxed.length v2) v1) v2 -- Finite and infinite tensor case zipT f _ _ _ (FiniteTensor index1 v1) (InfiniteTensor _ v2) = FiniteTensor index1 $ Boxed.zipWith f v1 (Boxed.fromList $ take (Boxed.length v1) v2) -- Finite and simple tensor case zipT _ f _ _ (FiniteTensor index1 v1) (SimpleFinite index2 v2) = if index1 == index2 then FiniteTensor index1 $ Boxed.zipWith f v1 v2 else Err incompatibleTypes -- Simple and finite tensor case zipT _ _ f _ (SimpleFinite index1 v1) (FiniteTensor index2 v2) = if index1 == index2 then FiniteTensor index1 $ Boxed.zipWith f v1 v2 else Err incompatibleTypes -- Infinite and simple tensor case zipT _ f _ _ (InfiniteTensor _ v1) (SimpleFinite index2 v2) = FiniteTensor index2 $ Boxed.zipWith f (Boxed.fromList $ take (Boxed.length v2) v1) v2 -- Simple and infinite tensor case zipT _ _ f _ (SimpleFinite index1 v1) (InfiniteTensor _ v2) = FiniteTensor index1 $ Boxed.zipWith f v1 (Boxed.fromList $ take (Boxed.length v1) v2) -- Zipping error tensor simply pushes this erorr further zipT _ _ _ _ (Err msg) _ = Err msg zipT _ _ _ _ _ (Err msg) = Err msg -- Zipping something with scalar is impossible zipT _ _ _ _ _ _ = Err scalarIndices -- dot product of two tensors {-# INLINE dot #-} dot :: Num a => Tensor a -- ^ First dot product argument -> Tensor a -- ^ Second dot product argument -> Tensor a -- ^ Resulting dot product -- Two simple tensors product dot (SimpleFinite i1@(Finite.Covariant count1 _) ts1') (SimpleFinite i2@(Finite.Contravariant count2 _) ts2') | count1 == count2 = Scalar $ Boxed.sum $ Boxed.zipWith (*) ts1' ts2' | otherwise = contractionErr (Index.toTIndex i1) (Index.toTIndex i2) dot (SimpleFinite i1@(Finite.Contravariant count1 _) ts1') (SimpleFinite i2@(Finite.Contravariant count2 _) ts2') | count1 == count2 = SimpleFinite i1 $ Boxed.zipWith (*) ts1' ts2' | otherwise = contractionErr (Index.toTIndex i1) (Index.toTIndex i2) dot (SimpleFinite i1@(Finite.Covariant count1 _) ts1') (SimpleFinite i2@(Finite.Covariant count2 _) ts2') | count1 == count2 = SimpleFinite i1 $ Boxed.zipWith (*) ts1' ts2' | otherwise = contractionErr (Index.toTIndex i1) (Index.toTIndex i2) -- Two finite tensors product dot (FiniteTensor i1@(Finite.Covariant count1 _) ts1') (FiniteTensor i2@(Finite.Contravariant count2 _) ts2') | count1 == count2 = Boxed.sum $ Boxed.zipWith (*) ts1' ts2' | otherwise = contractionErr (Index.toTIndex i1) (Index.toTIndex i2) dot (FiniteTensor i1@(Finite.Contravariant count1 _) ts1') (FiniteTensor i2@(Finite.Contravariant count2 _) ts2') | count1 == count2 = FiniteTensor i1 $ Boxed.zipWith (*) ts1' ts2' | otherwise = contractionErr (Index.toTIndex i1) (Index.toTIndex i2) dot (FiniteTensor i1@(Finite.Covariant count1 _) ts1') (FiniteTensor i2@(Finite.Covariant count2 _) ts2') | count1 == count2 = FiniteTensor i1 $ Boxed.zipWith (*) ts1' ts2' | otherwise = contractionErr (Index.toTIndex i1) (Index.toTIndex i2) -- Simple tensor and finite tensor product dot (SimpleFinite i1@(Finite.Covariant count1 _) ts1') (FiniteTensor i2@(Finite.Contravariant count2 _) ts2') | count1 == count2 = Boxed.sum $ Boxed.zipWith (*.) ts1' ts2' | otherwise = contractionErr (Index.toTIndex i1) (Index.toTIndex i2) dot (SimpleFinite i1@(Finite.Contravariant count1 _) ts1') (FiniteTensor i2@(Finite.Contravariant count2 _) ts2') | count1 == count2 = FiniteTensor i1 $ Boxed.zipWith (*.) ts1' ts2' | otherwise = contractionErr (Index.toTIndex i1) (Index.toTIndex i2) dot (SimpleFinite i1@(Finite.Covariant count1 _) ts1') (FiniteTensor i2@(Finite.Covariant count2 _) ts2') | count1 == count2 = FiniteTensor i1 $ Boxed.zipWith (*.) ts1' ts2' | otherwise = contractionErr (Index.toTIndex i1) (Index.toTIndex i2) -- Finite tensor and simple tensor product dot (FiniteTensor i1@(Finite.Covariant count1 _) ts1') (SimpleFinite i2@(Finite.Contravariant count2 _) ts2') | count1 == count2 = Boxed.sum $ Boxed.zipWith (.*) ts1' ts2' | otherwise = contractionErr (Index.toTIndex i1) (Index.toTIndex i2) dot (FiniteTensor i1@(Finite.Contravariant count1 _) ts1') (SimpleFinite i2@(Finite.Contravariant count2 _) ts2') | count1 == count2 = FiniteTensor i1 $ Boxed.zipWith (.*) ts1' ts2' | otherwise = contractionErr (Index.toTIndex i1) (Index.toTIndex i2) dot (FiniteTensor i1@(Finite.Covariant count1 _) ts1') (SimpleFinite i2@(Finite.Covariant count2 _) ts2') | count1 == count2 = FiniteTensor i1 $ Boxed.zipWith (.*) ts1' ts2' | otherwise = contractionErr (Index.toTIndex i1) (Index.toTIndex i2) -- Simple tensor and infinite tensor product dot (SimpleFinite (Finite.Covariant count1 _) ts1') (InfiniteTensor (Infinite.Contravariant _) ts2') = Boxed.sum $ Boxed.zipWith (*.) ts1' (Boxed.fromList $ take count1 ts2') dot (SimpleFinite (Finite.Contravariant count1 _) ts1') (InfiniteTensor i2@(Infinite.Contravariant _) ts2') = InfiniteTensor i2 $ Boxed.toList $ Boxed.zipWith (*.) ts1' (Boxed.fromList $ take count1 ts2') dot (SimpleFinite (Finite.Covariant count1 _) ts1') (InfiniteTensor i2@(Infinite.Covariant _) ts2') = InfiniteTensor i2 $ Boxed.toList $ Boxed.zipWith (*.) ts1' (Boxed.fromList $ take count1 ts2') -- Infinite tensor and simple tensor product dot (InfiniteTensor (Infinite.Covariant _) ts1') (SimpleFinite (Finite.Contravariant count2 _) ts2') = Boxed.sum $ Boxed.zipWith (.*) (Boxed.fromList $ take count2 ts1') ts2' dot (InfiniteTensor i1@(Infinite.Contravariant _) ts1') (SimpleFinite (Finite.Contravariant count2 _) ts2') = InfiniteTensor i1 $ Boxed.toList $ Boxed.zipWith (.*) (Boxed.fromList $ take count2 ts1') ts2' dot (InfiniteTensor i1@(Infinite.Covariant _) ts1') (SimpleFinite (Finite.Covariant count2 _) ts2') = InfiniteTensor i1 $ Boxed.toList $ Boxed.zipWith (.*) (Boxed.fromList $ take count2 ts1') ts2' -- Finite tensor and infinite tensor product dot (FiniteTensor (Finite.Covariant count1 _) ts1') (InfiniteTensor (Infinite.Contravariant _) ts2') = Boxed.sum $ Boxed.zipWith (*) ts1' (Boxed.fromList $ take count1 ts2') dot (FiniteTensor (Finite.Contravariant count1 _) ts1') (InfiniteTensor i2@(Infinite.Contravariant _) ts2') = InfiniteTensor i2 $ Boxed.toList $ Boxed.zipWith (*) ts1' (Boxed.fromList $ take count1 ts2') dot (FiniteTensor (Finite.Covariant count1 _) ts1') (InfiniteTensor i2@(Infinite.Covariant _) ts2') = InfiniteTensor i2 $ Boxed.toList $ Boxed.zipWith (*) ts1' (Boxed.fromList $ take count1 ts2') -- Infinite tensor and finite tensor product dot (InfiniteTensor (Infinite.Covariant _) ts1') (FiniteTensor (Finite.Contravariant count2 _) ts2') = Boxed.sum $ Boxed.zipWith (*) (Boxed.fromList $ take count2 ts1') ts2' dot (InfiniteTensor i1@(Infinite.Contravariant _) ts1') (FiniteTensor (Finite.Contravariant count2 _) ts2') = InfiniteTensor i1 $ Boxed.toList $ Boxed.zipWith (*) (Boxed.fromList $ take count2 ts1') ts2' dot (InfiniteTensor i1@(Infinite.Covariant _) ts1') (FiniteTensor (Finite.Covariant count2 _) ts2') = InfiniteTensor i1 $ Boxed.toList $ Boxed.zipWith (*) (Boxed.fromList $ take count2 ts1') ts2' -- In other cases cannot happen! dot t1' t2' = contractionErr (tensorIndex t1') (tensorIndex t2') -- bit dot product of two tensors {-# INLINE bitDot #-} bitDot :: ( Num a, Bits a ) => Tensor a -- ^ First dot product argument -> Tensor a -- ^ Second dot product argument -> Tensor a -- ^ Resulting dot product -- Two finite tensors product bitDot (FiniteTensor i1@(Finite.Covariant count1 _) ts1') (FiniteTensor i2@(Finite.Contravariant count2 _) ts2') | count1 == count2 = Data.Foldable.foldl' (.|.) 0 $ Boxed.zipWith (.&.) ts1' ts2' | otherwise = contractionErr (Index.toTIndex i1) (Index.toTIndex i2) -- Two simple tensors product bitDot (SimpleFinite i1@(Finite.Covariant count1 _) ts1') (SimpleFinite i2@(Finite.Contravariant count2 _) ts2') | count1 == count2 = let dotProduct v1 v2 = Data.Foldable.foldl' (.|.) 0 $ Boxed.zipWith (.&.) v1 v2 in Scalar $ dotProduct ts1' ts2' | otherwise = contractionErr (Index.toTIndex i1) (Index.toTIndex i2) -- Simple tensor and finite tensor product bitDot (SimpleFinite i1@(Finite.Covariant count1 _) ts1') (FiniteTensor i2@(Finite.Contravariant count2 _) ts2') | count1 == count2 = Data.Foldable.foldl' (.|.) 0 $ Boxed.zipWith (\e t -> (e .&.) <$> t) ts1' ts2' | otherwise = contractionErr (Index.toTIndex i1) (Index.toTIndex i2) -- Finite tensor and simple tensor product bitDot (FiniteTensor i1@(Finite.Covariant count1 _) ts1') (SimpleFinite i2@(Finite.Contravariant count2 _) ts2') | count1 == count2 = Data.Foldable.foldl' (.|.) 0 $ Boxed.zipWith (\t e -> (.&. e) <$> t) ts1' ts2' | otherwise = contractionErr (Index.toTIndex i1) (Index.toTIndex i2) -- Simple tensor and infinite tensor product bitDot (SimpleFinite (Finite.Covariant count1 _) ts1') (InfiniteTensor (Infinite.Contravariant _) ts2') = Data.Foldable.foldl' (.|.) 0 $ Boxed.zipWith (\e t -> (e .&.) <$> t) ts1' (Boxed.fromList $ take count1 ts2') -- Infinite tensor and simple tensor product bitDot (InfiniteTensor (Infinite.Covariant _) ts1') (SimpleFinite (Finite.Contravariant count2 _) ts2') = Data.Foldable.foldl' (.|.) 0 $ Boxed.zipWith (\t e -> (.&. e) <$> t) (Boxed.fromList $ take count2 ts1') ts2' -- Finite tensor and infinite tensor product bitDot (FiniteTensor (Finite.Covariant count1 _) ts1') (InfiniteTensor (Infinite.Contravariant _) ts2') = Boxed.sum $ Boxed.zipWith (*) ts1' (Boxed.fromList $ take count1 ts2') -- Infinite tensor and finite tensor product bitDot (InfiniteTensor (Infinite.Covariant _) ts1') (FiniteTensor (Finite.Contravariant count2 _) ts2') = Boxed.sum $ Boxed.zipWith (*) (Boxed.fromList $ take count2 ts1') ts2' -- In other cases cannot happen! bitDot t1' t2' = contractionErr (tensorIndex t1') (tensorIndex t2') -- contraction error {-# INLINE contractionErr #-} contractionErr :: Index.TIndex -- ^ Index of first dot product parameter -> Index.TIndex -- ^ Index of second dot product parameter -> Tensor a -- ^ Erorr message contractionErr i1' i2' = Err $ "Tensor product: " ++ incompatibleTypes ++ " - index1 is " ++ show i1' ++ " and index2 is " ++ show i2' -- Tensors can be added, subtracted and multiplicated instance Num a => Num (Tensor a) where -- Adding - element by element {-# INLINE (+) #-} t1 + t2 = _elemByElem t1 t2 (+) $ zipT (+) (.+) (+.) (+) -- Subtracting - element by element {-# INLINE (-) #-} t1 - t2 = _elemByElem t1 t2 (-) $ zipT (-) (.-) (-.) (-) -- Multiplicating is treated as tensor product -- Tensor product applies Einstein summation convention {-# INLINE (*) #-} t1 * t2 = _elemByElem t1 t2 (*) dot -- Absolute value - element by element {-# INLINE abs #-} abs t = abs <$> t -- Signum operation - element by element {-# INLINE signum #-} signum t = signum <$> t -- Simple integer can be conveted to Scalar {-# INLINE fromInteger #-} fromInteger x = Scalar $ fromInteger x -- Bit operations on tensors instance ( Num a, Bits a ) => Bits (Tensor a) where -- Bit sum - elem by elem {-# INLINE (.|.) #-} t1 .|. t2 = _elemByElem t1 t2 (.|.) $ zipT (.|.) (\t e -> (.|. e) <$> t) (\e t -> (e .|.) <$> t) (.|.) -- Bit tensor product -- Summation and multiplication are replaced by its bit equivalents -- Two scalars are multiplicated by their values {-# INLINE (.&.) #-} t1 .&. t2 = _elemByElem t1 t2 (.&.) bitDot -- Bit exclusive sum (XOR) - elem by elem {-# INLINE xor #-} t1 `xor` t2 = _elemByElem t1 t2 xor $ zipT xor (\t e -> (`xor` e) <$> t) (\e t -> (e `xor`) <$> t) xor -- Bit complement {-# INLINE complement #-} complement = Multilinear.map complement -- Bit shift of all elements {-# INLINE shift #-} shift t n = Multilinear.map (`shift` n) t -- Bit rotating of all elements {-# INLINE rotate #-} rotate t n = Multilinear.map (`rotate` n) t -- Returns number of bits of elements of tensor, -1 for elements of undefined size {-# INLINE bitSize #-} bitSize (Scalar x) = fromMaybe (-1) $ bitSizeMaybe x bitSize (Err _) = -1 bitSize t = if isEmptyTensor t then (-1) else fromMaybe (-1) $ bitSizeMaybe $ firstElem t -- Returns number of bits of elements of tensor {-# INLINE bitSizeMaybe #-} bitSizeMaybe (Scalar x) = bitSizeMaybe x bitSizeMaybe (Err _) = Nothing bitSizeMaybe t = if isEmptyTensor t then Nothing else bitSizeMaybe $ firstElem t -- Returns true if tensors element are signed {-# INLINE isSigned #-} isSigned (Scalar x) = isSigned x isSigned (Err _) = False isSigned t = not (isEmptyTensor t) && isSigned (firstElem t) -- bit i is a scalar value with the ith bit set and all other bits clear. {-# INLINE bit #-} bit i = Scalar (bit i) -- Test bit - shoud retur True, if bit n if equal to 1. -- Tensors are entities with many elements, so this function always returns False. -- Do not use it, it is implemented only for legacy purposes. {-# INLINE testBit #-} testBit _ _ = False -- Return the number of set bits in the argument. This number is known as the population count or the Hamming weight. {-# INLINE popCount #-} popCount = popCountDefault -- Tensors can be divided by each other instance Fractional a => Fractional (Tensor a) where {-# INLINE (/) #-} -- Scalar division return result of division of its values Scalar x1 / Scalar x2 = Scalar $ x1 / x2 -- Tensor and scalar are divided value by value Scalar x1 / t2 = (x1 /) <$> t2 t1 / Scalar x2 = (/ x2) <$> t1 Err msg / _ = Err msg _ / Err msg = Err msg -- Two complex tensors cannot be (for now) simply divided -- // TODO - tensor division and inversion _ / _ = Err "TODO" -- A scalar can be generated from rational number {-# INLINE fromRational #-} fromRational x = Scalar $ fromRational x -- Real-number functions on tensors. -- Function of tensor is tensor of function of its elements -- E.g. exp [1,2,3,4] = [exp 1, exp2, exp3, exp4] instance Floating a => Floating (Tensor a) where {-| PI number -} {-# INLINE pi #-} pi = Scalar pi {-| Exponential function. (exp t)[i] = exp( t[i] ) -} {-# INLINE exp #-} exp t = exp <$> t {-| Natural logarithm. (log t)[i] = log( t[i] ) -} {-# INLINE log #-} log t = log <$> t {-| Sinus. (sin t)[i] = sin( t[i] ) -} {-# INLINE sin #-} sin t = sin <$> t {-| Cosinus. (cos t)[i] = cos( t[i] ) -} {-# INLINE cos #-} cos t = cos <$> t {-| Inverse sinus. (asin t)[i] = asin( t[i] ) -} {-# INLINE asin #-} asin t = asin <$> t {-| Inverse cosinus. (acos t)[i] = acos( t[i] ) -} {-# INLINE acos #-} acos t = acos <$> t {-| Inverse tangent. (atan t)[i] = atan( t[i] ) -} {-# INLINE atan #-} atan t = atan <$> t {-| Hyperbolic sinus. (sinh t)[i] = sinh( t[i] ) -} {-# INLINE sinh #-} sinh t = sinh <$> t {-| Hyperbolic cosinus. (cosh t)[i] = cosh( t[i] ) -} {-# INLINE cosh #-} cosh t = cosh <$> t {-| Inverse hyperbolic sinus. (asinh t)[i] = asinh( t[i] ) -} {-# INLINE asinh #-} asinh t = acosh <$> t {-| Inverse hyperbolic cosinus. (acosh t)[i] = acosh (t[i] ) -} {-# INLINE acosh #-} acosh t = acosh <$> t {-| Inverse hyperbolic tangent. (atanh t)[i] = atanh( t[i] ) -} {-# INLINE atanh #-} atanh t = atanh <$> t -- Multilinear operations instance Num a => Multilinear Tensor a where -- Add scalar right {-# INLINE (.+) #-} t .+ x = (+x) <$> t -- Subtract scalar right {-# INLINE (.-) #-} t .- x = (\p -> p - x) <$> t -- Multiplicate by scalar right {-# INLINE (.*) #-} t .* x = (*x) <$> t -- Add scalar left {-# INLINE (+.) #-} x +. t = (x+) <$> t -- Subtract scalar left {-# INLINE (-.) #-} x -. t = (x-) <$> t -- Multiplicate by scalar left {-# INLINE (*.) #-} x *. t = (x*) <$> t -- Two tensors sum {-# INLINE (.+.) #-} t1 .+. t2 = _elemByElem t1 t2 (+) $ zipT (+) (.+) (+.) (+) -- Two tensors difference {-# INLINE (.-.) #-} t1 .-. t2 = _elemByElem t1 t2 (-) $ zipT (+) (.+) (+.) (+) -- Tensor product {-# INLINE (.*.) #-} t1 .*. t2 = _elemByElem t1 t2 (+) dot -- List of all tensor indices {-# INLINE indices #-} indices x = case x of Scalar _ -> [] FiniteTensor i ts -> Index.toTIndex i : indices (head $ toList ts) InfiniteTensor i ts -> Index.toTIndex i : indices (head ts) SimpleFinite i _ -> [Index.toTIndex i] Err _ -> [] -- Get tensor order [ (contravariant,covariant)-type ] {-# INLINE order #-} order x = case x of Scalar _ -> (0,0) SimpleFinite index _ -> case index of Finite.Contravariant _ _ -> (1,0) Finite.Covariant _ _ -> (0,1) Finite.Indifferent _ _ -> (0,0) Err _ -> (-1,-1) _ -> let (cnvr, covr) = order $ firstTensor x in case tensorIndex x of Index.Contravariant _ _ -> (cnvr+1,covr) Index.Covariant _ _ -> (cnvr,covr+1) Index.Indifferent _ _ -> (cnvr,covr) -- Get size of tensor index or Left if index is infinite or tensor has no such index {-# INLINE size #-} size t iname = case t of Scalar _ -> error scalarIndices SimpleFinite index _ -> if Index.indexName index == iname then Finite.indexSize index else error indexNotFound FiniteTensor index _ -> if Index.indexName index == iname then Finite.indexSize index else size (firstTensor t) iname InfiniteTensor _ _ -> error infiniteIndex Err msg -> error msg -- Rename tensor indices {-# INLINE ($|) #-} Scalar x $| _ = Scalar x SimpleFinite (Finite.Contravariant isize _) ts $| (u:_, _) = SimpleFinite (Finite.Contravariant isize [u]) ts SimpleFinite (Finite.Covariant isize _) ts $| (_, d:_) = SimpleFinite (Finite.Covariant isize [d]) ts FiniteTensor (Finite.Contravariant isize _) ts $| (u:us, ds) = FiniteTensor (Finite.Contravariant isize [u]) $ ($| (us,ds)) <$> ts FiniteTensor (Finite.Covariant isize _) ts $| (us, d:ds) = FiniteTensor (Finite.Covariant isize [d]) $ ($| (us,ds)) <$> ts InfiniteTensor (Infinite.Contravariant _) ts $| (u:us, ds) = InfiniteTensor (Infinite.Contravariant [u]) $ ($| (us,ds)) <$> ts InfiniteTensor (Infinite.Covariant _) ts $| (us, d:ds) = InfiniteTensor (Infinite.Covariant [d]) $ ($| (us,ds)) <$> ts Err msg $| _ = Err msg t $| _ = t -- Raise an index {-# INLINE (/\) #-} Scalar x /\ _ = Scalar x FiniteTensor index ts /\ n | Index.indexName index == n = FiniteTensor (Finite.Contravariant (Finite.indexSize index) n) $ (/\ n) <$> ts | otherwise = FiniteTensor index $ (/\ n) <$> ts InfiniteTensor index ts /\ n | Index.indexName index == n = InfiniteTensor (Infinite.Contravariant n) $ (/\ n) <$> ts | otherwise = InfiniteTensor index $ (/\ n) <$> ts t1@(SimpleFinite index ts) /\ n | Index.indexName index == n = SimpleFinite (Finite.Contravariant (Finite.indexSize index) n) ts | otherwise = t1 Err msg /\ _ = Err msg -- Lower an index {-# INLINE (\/) #-} Scalar x \/ _ = Scalar x FiniteTensor index ts \/ n | Index.indexName index == n = FiniteTensor (Finite.Covariant (Finite.indexSize index) n) $ (\/ n) <$> ts | otherwise = FiniteTensor index $ (\/ n) <$> ts InfiniteTensor index ts \/ n | Index.indexName index == n = InfiniteTensor (Infinite.Covariant n) $ (\/ n) <$> ts | otherwise = InfiniteTensor index $ (\/ n) <$> ts t1@(SimpleFinite index ts) \/ n | Index.indexName index == n = SimpleFinite (Finite.Covariant (Finite.indexSize index) n) ts | otherwise = t1 Err msg \/ _ = Err msg {-| Transpose a tensor (switch all indices types) -} {-# INLINE transpose #-} transpose (Scalar x) = Scalar x transpose (FiniteTensor (Finite.Covariant count name) ts) = FiniteTensor (Finite.Contravariant count name) (Multilinear.transpose <$> ts) transpose (FiniteTensor (Finite.Contravariant count name) ts) = FiniteTensor (Finite.Covariant count name) (Multilinear.transpose <$> ts) transpose (FiniteTensor (Finite.Indifferent count name) ts) = FiniteTensor (Finite.Indifferent count name) (Multilinear.transpose <$> ts) transpose (InfiniteTensor (Infinite.Covariant name) ts) = InfiniteTensor (Infinite.Contravariant name) (Multilinear.transpose <$> ts) transpose (InfiniteTensor (Infinite.Contravariant name) ts) = InfiniteTensor (Infinite.Covariant name) (Multilinear.transpose <$> ts) transpose (InfiniteTensor (Infinite.Indifferent name) ts) = InfiniteTensor (Infinite.Indifferent name) (Multilinear.transpose <$> ts) transpose (SimpleFinite (Finite.Covariant count name) ts) = SimpleFinite (Finite.Contravariant count name) ts transpose (SimpleFinite (Finite.Contravariant count name) ts) = SimpleFinite (Finite.Covariant count name) ts transpose (SimpleFinite (Finite.Indifferent count name) ts) = SimpleFinite (Finite.Indifferent count name) ts transpose (Err msg) = Err msg {-| Shift tensor index right -} {-| Moves given index one level deeper in recursion -} {-# INLINE shiftRight #-} -- Error tensor has no indices to shift Err msg `shiftRight` _ = Err msg -- Scalar has no indices to shift Scalar x `shiftRight` _ = Scalar x -- Simple tensor has only one index which cannot be shifted t1@(SimpleFinite _ _) `shiftRight` _ = t1 -- Finite tensor is shifted by converting to list and transposing it t1@(FiniteTensor index1 ts1) `shiftRight` ind -- We don't shift this index | Data.List.length (indicesNames t1) > 1 && Index.indexName index1 /= ind = FiniteTensor index1 $ (|>> ind) <$> ts1 -- We found index to shift | Data.List.length (indicesNames t1) > 1 && Index.indexName index1 == ind = -- Next index let index2 = tensorFiniteIndex (ts1 Boxed.! 0) -- Elements to transpose dane = if isSimple (ts1 Boxed.! 0) then (Scalar <$>) <$> (tensorScalars <$> ts1) else tensorsFinite <$> ts1 -- Convert to list daneList = Boxed.toList <$> Boxed.toList dane -- and transpose tensor data (standard function available only for list) transposedList = Data.List.transpose daneList -- then reconvert to vector again transposed = Boxed.fromList <$> Boxed.fromList transposedList -- and reconstruct tensor with transposed elements in mergeScalars $ FiniteTensor index2 $ FiniteTensor index1 <$> transposed | otherwise = t1 -- Infinite tensor is shifted by transposing nested lists t1@(InfiniteTensor index1 ts1) `shiftRight` ind -- We don't shift this index | Data.List.length (indicesNames t1) > 1 && Index.indexName index1 /= ind = InfiniteTensor index1 $ (|>> ind) <$> ts1 -- We found index to shift | Data.List.length (indicesNames t1) > 1 && Index.indexName index1 == ind = -- Next index let index2 = tensorInfiniteIndex (head ts1) -- Elements to transpose dane = if isSimple (head ts1) then (Scalar <$>) <$> (Boxed.toList . tensorScalars <$> ts1) else tensorsInfinite <$> ts1 -- transpose tensor data (standard function available only for list) transposed = Data.List.transpose dane -- and reconstruct tensor with transposed elements in mergeScalars $ InfiniteTensor index2 $ InfiniteTensor index1 <$> transposed | otherwise = t1 {-| List allows for random access to tensor elements -} instance Num a => Accessible Tensor a where {-| Accessing tensor elements -} {-# INLINE el #-} -- Scalar has only one element el (Scalar x) _ = Scalar x -- simple tensor case el t1@(SimpleFinite index1 _) (inds,vals) = -- zip indices with their given values let indvals = zip inds vals -- find value for simple tensor index if given val = Data.List.find (\(n,_) -> [n] == Index.indexName index1) indvals -- if value for current index is given in if isJust val -- then get it from current tensor then t1 ! snd (fromJust val) -- otherwise return whole tensor - no filtering defined else t1 -- finite tensor case el t1@(FiniteTensor index1 v1) (inds,vals) = -- zip indices with their given values let indvals = zip inds vals -- find value for current index if given val = Data.List.find (\(n,_) -> [n] == Index.indexName index1) indvals -- and remove used index from indices list indvals1 = Data.List.filter (\(n,_) -> [n] /= Index.indexName index1) indvals -- indices unused so far inds1 = Data.List.map fst indvals1 -- and its corresponding values vals1 = Data.List.map snd indvals1 -- if value for current index was given in if isJust val -- then get it from current tensor and recursively process other indices then el (t1 ! snd (fromJust val)) (inds1,vals1) -- otherwise recursively access elements of all child tensors else FiniteTensor index1 $ (\t -> el t (inds,vals)) <$> v1 -- infinite tensor case el t1@(InfiniteTensor index1 v1) (inds,vals) = -- zip indices with their given values let indvals = zip inds vals -- find value for current index if given val = Data.List.find (\(n,_) -> [n] == Index.indexName index1) indvals -- and remove used index from indices list indvals1 = Data.List.filter (\(n,_) -> [n] /= Index.indexName index1) indvals -- indices unused so far inds1 = Data.List.map fst indvals1 -- and its corresponding values vals1 = Data.List.map snd indvals1 -- if value for current index was given in if isJust val -- then get it from current tensor and recursively process other indices then el (t1 ! snd (fromJust val)) (inds1,vals1) -- otherwise recursively access elements of all child tensors else InfiniteTensor index1 $ (\t -> el t (inds,vals)) <$> v1 -- accessing elements of erorr tensor simply pushes this error further el (Err msg) _ = Err msg {-| Mapping with indices. -} {-# INLINE iMap #-} iMap f t = iMap' t zeroList where zeroList = 0:zeroList iMap' (Scalar x) inds = Scalar $ f inds x iMap' (SimpleFinite index ts) inds = SimpleFinite index $ Boxed.imap (\i e -> f (inds ++ [i]) e) ts iMap' (FiniteTensor index ts) inds = FiniteTensor index $ Boxed.imap (\i e -> iMap' e (inds ++ [i])) ts iMap' (InfiniteTensor index ts) inds = InfiniteTensor index $ (\tind -> iMap' (fst tind) $ inds ++ [snd tind]) <$> zip ts [0..] iMap' (Err msg) _ = Err msg