diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ +# Changelog + +## [0.1.0.0] - 2019-08-16 +Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2019 Tobias Reinhart and Nils Alex + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,81 @@ +# The `sparse-tensor` Package + +`sparse-tensor` is a Haskell tensor algebra library. It defines the usual tensor algebra functions such as + +- addition +```haskell +result = t1 &+ t2 +``` +- scalar multiplication +```haskell +result = s &. t +``` +- tensor product +```haskell +result = t1 &* t2 +``` +- or symmetrizations +```haskell +result = symTens (0,1) t -- symmetrization in first two indices +``` +## The `Tensor` type + +Tensor types can be defined with any value type and index types. For example, a tensor type with `n` contravariant and `m` covariant 4-d spacetime indices ranging from 0 to 3 and `Rational` values can be defined as +```haskell +type MyTensor n m = AbsTensor2 n m Ind3 (SField Rational) +``` + +The operations on tensors are **type-safe**, for example it is not possible to add two tensors of different rank, +```haskell +>>> :set -XDataKinds +>>> (undefined :: MyTensor 0 1) &+ (undefined :: MyTensor 0 2) +``` +``` +:3:33: error: + • Couldn't match type ‘2’ with ‘1’ + [...] +``` +as this causes a type error at **compile time**. + +## Predefined tensors +The package comes with pre-defined tensor types. Basic tensors of these types for applications in mathematical physics are exported by `Math.Tensor.Examples.Gravity`: +```haskell +>>> sequence_ $ fmap print $ toListT2' delta3 -- print assocs of spacetime delta +(([0],[0]),SField (1 % 1)) +(([1],[1]),SField (1 % 1)) +(([2],[2]),SField (1 % 1)) +(([3],[3]),SField (1 % 1)) + +>>> sequence_ $ fmap print $ toListT2' eta -- print assocs of Minkowski metric +(([],[0,0]),SField ((-1) % 1)) +(([],[1,1]),SField (1 % 1)) +(([],[2,2]),SField (1 % 1)) +(([],[3,3]),SField (1 % 1)) + +>>> let t = invEta &* epsilon +>>> contrATens1 (0,0) $ contrATens1 (1,1) t -- contraction of inverse eta with epsilon +ZeroTensor +``` + + It is of course possible to define further custom tensor types and tensors. + +`Math.Tensor.LorentzGenerator` exports functionality to generate a basis for the space of Lorentz-invariant tensors of certain rank which obey certain symmetries. + +## Automatic differentiation +`sparse-tensor` also supports tensors with **functions** as values. For such tensors, the package also provides the `partial` function for automatic differentiation. `Math.Tensor.Examples.Gravity.Schwarzschild` exports the Einstein tensor for a Schwarzschild spacetime, calculated from the Schwarzschild metric: +```haskell +>>> let e = einstein 2.0 -- Einstein tensor for Schwarzschild metric with r_s = 2.0 +>>> e `evalSec` [1.2, 3.1, 1.3, 2.2] -- evaluate at spacetime point +ZeroTensor +``` + +## Symbolic calculations +The package can also handle **symbolic** tensor values. All manipulations, including differentiation, are then performed on strings which may be passed to a computer algebra engine. `sparse-tensor` itself cannot yet simplify these symbolic values. `Math.Tensor.Examples.Gravity.SchwarzschildSymbolic` exports the Schwarzschild metric with symbolic entries and methods to calculate derived geometric entities: +```haskell +>>> let g = schwarzschildS +>>> let g' = schwarzschildS' +>>> let gamma = christoffelS g g' +>>> let comps = toListT2 gamma -- get assocs +>>> print $ snd $ comps !! 1 -- component gamma^t_tr +SSymbolic "(1 % 2)*((1/(1 - rs/r))*(diff(1 - rs / r, r)))" +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/sparse-tensor.cabal b/sparse-tensor.cabal new file mode 100644 --- /dev/null +++ b/sparse-tensor.cabal @@ -0,0 +1,62 @@ +name: sparse-tensor +version: 0.1.0.0 +synopsis: typesafe tensor algebra library +description: + . + This package is intended to be used as a general purpose tensor algebra library. + It defines the usual tensor algebra functions such as addition, scalar multiplication, tensor product, and contractions, + but also general symmetrizations and further utility functions. + . + The implemented tensor data type is capable of being used with an arbitrary number of general abstract indices and can incorporate values + of any type that allow for a meaningful addition, scaling, and multiplication. The package is thus very flexible and can easily be customised + at wish. + . + This package performs best when the values a given tensor provides are explicitly needed. In particular all incorporated functions are + implemented such that they explicitly manipulate the values of the given tensors. This allows for fast evaluation of the individual values from given tensors. + . + In order to improve memory usage, the tensors in this package employ a sparse storage paradigm. In other words, one may define a tensor by only + providing its non-zero values explicitly. All remaining values are taken to be zero. + . + Furthermore this package also provides the functionality of fully automatically computing all linear independent expressions with given rank and symmetries + that can be composed by using the Minkowski metric and the totally antisymmetric tensor. In order words, the package includes functions that + construct a basis of the space of Lorentz invariant tensors of given symmetry and rank. With slight modifications the therefore implemented algorithms can + also be used for the computation of invariant tensor bases of any other special orthogonal group @SO(p,q)@. +homepage: https://github.com/TobiReinhart/sparse-tensor#readme +license: MIT +license-file: LICENSE +author: Tobias Reinhart and Nils Alex +maintainer: tobi.reinhart@fau.de, nils.alex@fau.de +copyright: 2019 Tobias Reinhart and Nils Alex +category: Data, Math, Algebra +build-type: Simple +cabal-version: >=1.10 +extra-source-files: + README.md + CHANGELOG.md + +source-repository head + type: git + location: git://github.com/TobiReinhart/sparse-tensor.git + +library + hs-source-dirs: src + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5, + containers >= 0.5.7 && < 0.7, + tf-random >= 0.5 && < 0.6, + ghc-typelits-natnormalise >= 0.6.2 && < 0.7, + ghc-typelits-knownnat >= 0.5.1 && < 0.7, + eigen == 3.3.4.1, + parallel >= 3.2.2 && < 3.3, + deepseq >= 1.4.2 && < 1.5, + cereal >= 0.5.7 && < 0.6, + singletons >= 2.4.1 && < 2.6, + bytestring >= 0.10.8 && < 0.11, + zlib >= 0.6.2 && < 0.7, + ad >= 4.3 && < 4.4 + exposed-modules: Math.Tensor + Math.Tensor.LorentzGenerator + Math.Tensor.Examples.Gravity + Math.Tensor.Examples.Gravity.Schwarzschild + Math.Tensor.Examples.Gravity.SchwarzschildSymbolic + Math.Tensor.Examples.Gravity.DiffeoSymEqns diff --git a/src/Math/Tensor.hs b/src/Math/Tensor.hs new file mode 100644 --- /dev/null +++ b/src/Math/Tensor.hs @@ -0,0 +1,3080 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Math.Tensor +-- Copyright : (c) 2019 Tobias Reinhart and Nils Alex +-- License : MIT +-- Maintainer : tobi.reinhart@fau.de, nils.alex@fau.de +-- +-- +-- This module defines the basic data types and functions of the sparse-tensor package. +-- +-- The @'Tensor' n k v@ data type provides the fundamental building block of all further tensor types. +-- It represents a general tensor that takes @n@ individual indices all belonging +-- to the same index typ @k@ and retrieves values of type @v@. As such the @'Tensor'@ type can be thought of representing a single tensor that only features +-- contravariant indices. +-- +-- @'Tensor' n k v@ is internally implemented as an ordered forest with nodes of type @'k'@ and leafs of type @'v'@. +-- +-- Additional covariant indices can be incorporated by adjoining leafs of type @'Tensor' n2 k v@ to a @'Tensor' n1 k v@. +-- This yields the type @'Tensor2' n1 n2 k v@ which thus is used to represent the tensors in the traditional sense that include contravariant and covariant indices of the same type, i.e. running over the same index range. +-- +-- Recursively appending further @'Tensor'@s as leafs each one with possibly different +-- index types and different ranks allows the sparse-tensor package cover the treatment of more complicated tensors with an arbitrary number of different indices. +-- +-- The @'Tensor'@ data type directly incorporates its rank in form of a type level natural number @n@. This results in added type safety when performing the usual +-- tensor algebra operations. To provide a simple example the addition of two tensors is only meaningful if the ranks of the two tensors coincide. Hence then sparse-tensor package only incorporates an addition of @'Tensor'@s with the same type. +-- Unintentional additions of @'Tensor'@s with different type then immediately yields a type error thus preventing the mistake. +-- +-- Furthermore the @'Tensor'@ type employs a sparse storage paradigm in the sense that when constructing @'Tensor'@s only non zero values must be specified. +-- Missing values are then taken as vanishing automatically. +----------------------------------------------------------------------------- + +{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -fplugin GHC.TypeLits.KnownNat.Solver #-} +{-# OPTIONS_GHC -fplugin GHC.TypeLits.Normalise #-} +{-# OPTIONS_GHC -fplugin-opt GHC.TypeLits.Normalise:allow-negated-numbers #-} + +module Math.Tensor ( +-- * Tensor Data Types +-- ** Length Typed Index List +-- +-- | @'Tensor'@s provide information regarding their number of indices, i.e. their rank in their type. Consequently when constructing them from lists of indices value pairs and +-- converting them to such it is advantageous when also these lists contain the additional length information in their type. +IndList(..), +-- +singletonInd, (+>), fromList, fromListMaybe, +headInd, tailInd, sortInd, updateInd, +-- ** The Tensor Type +-- +-- | The basic tensor type @'Tensor' n k v@ represents a tensor that takes @n@ indices of type @k@ and maps them to values of type @v@. +-- This type can be thought of as representing a single, purely contravariant tensor that features @n@ indices. +-- +-- A general abstract tensor with multiple possibly different indices is obtained by simply adjoining the appropriate number of individual basic tensors. +-- +-- The @'Tensor'@ type is internally implemented as ordered forest with nodes being the individual indices and leafs given by the corresponding values. +-- +TMap, +Tensor(..), +-- +Tensor2, +-- +-- | __The following types are synonyms that are used to represent tensors with multiple different indices. For instance @'AbsTensor4'@ can be used__ +-- __to represent any tensor that features two different index types with different index ranges that both appear in contravariant and covariant position.__ +AbsTensor1, AbsTensor2, AbsTensor3, AbsTensor4, AbsTensor5, AbsTensor6, AbsTensor7, AbsTensor8, +-- +STTens, ATens, +-- +-- ** Index Type Class +-- +TIndex(..), +-- +Ind3(..), Ind9(..), Ind20(..), +-- +-- ** Tensor Value Type Class +-- +-- | Types that any @'Tensor'@ might use as values must satisfy number like properties, more precisely they must constitute an additive group. +-- This requirement is encoded in the @'TAdd'@ type class. +-- +-- Allowing further for the computation of tensor products the @'Tensor'@ types resemble the structure of the usual graded tensor algebra on the type level. +-- When computing tensor products of different ranked tensors and also tensors with different value type it is thus necessary that the two @'Tensor'@ types provide the +-- information regarding the explicit type of their product. This is the case if the two value types provide an instance of the @'Prod'@ type class. +-- +-- If the values of a given tensor are instances of these two type classes also tensor type @'Tensor'@ itself represents an instance of them. +-- This allows the use of the basic tensor algebra functions and also many further tensor functions irrespective of the values of a given @'Tensor'@ +-- are themselves @'Tensor'@s or represent simple scalar values. +-- +TAdd(..), +-- +Prod(..), +-- +-- ** Tensor Value Instances +-- *** Scalar Values +-- +SField(..), +-- +-- *** Linear Variables +AnsVar(..), AnsVarR, +-- +shiftVarLabels, +-- +-- | __The following functions apply this shift of the variable labels, i.e. the function @'shiftVarLabels'@ to all @'AnsVar'@s that are contained in a @'Tensor'@.__ +shiftLabels1, shiftLabels2, shiftLabels3, shiftLabels4, shiftLabels5, shiftLabels6, shiftLabels7, shiftLabels8, +-- +-- *** Functions as Values +-- +CFun(..), evalSec, +-- +-- *** Symbolic Values +SSymbolic(..), +-- +-- ** Construction of Tensor +-- | @'Tensor'@s can most easily be constructed from key value list where the keys are tuples of either @'IndList'@s or simply traditional lists that encode the values of the +-- various indices and the values then are the corresponding @'Tensor'@ values. While the construction from tuples of normal lists is certainly more flexible +-- it lacks the desired type safety that is incorporated when construction is achieved from tuples of length typed @'IndList'@s. +-- +-- __The following are type synonyms that are frequently for these key value lists.__ +IndTuple1, IndTuple2, IndTuple3, IndTuple4, IndTuple5, IndTuple6, IndTuple7, IndTuple8, +-- +IndTupleST, IndTupleAbs, +-- +fromListT, +-- +-- | __The following functions employ the construction of different @'Tensor'@ types from such typed key value lists.__ +fromListT1, fromListT2, fromListT3, fromListT4, fromListT5, fromListT6, fromListT7, fromListT8, +-- +fromListT', +-- +-- | __The following functions employ the construction of different @'Tensor'@ types from un-typed key value lists.__ +fromListT1', fromListT2', fromListT3', fromListT4', fromListT5', fromListT6', fromListT7', fromListT8', +-- +-- ** Accessing Deeper Leaf Levels +-- | Given @'Tensor'@s with multiple index types, i.e. @'Tensor'@s that themselves have further @'Tensor'@s attached as their leafs, i.e. as their @'Scalar'@s one needs a way of accessing these deeper @'Tensor'@ levels. This is precisely achieved by the following functions. +-- They allow a general function that takes @'Tensor'@s as arguments to be applied to @'Tensor'@s that are attached in deeper levels. +-- +mapTo1, mapTo2, mapTo3, mapTo4, mapTo5, mapTo6, mapTo7, mapTo8, +-- +-- * Tensor Algebra +-- +-- ** Basic Tensor Algebra Operations +-- +-- | The following functions provide the @'Tensor'@ type with the structure of the usual tensor algebra. +(&+), negateTens, (&*), (&-), (&.), +-- +-- +tensorContr, +-- +-- | __If the indices that are to be contracted do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +contrATens1, contrATens2, contrATens3, contrATens4, +-- +-- ** Rearranging indices +-- +-- *** Swapping 2 Indices +tensorTrans, +-- +-- | __If the indices that are to be transposed do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +tensorTrans1, tensorTrans2, tensorTrans3, tensorTrans4, tensorTrans5, tensorTrans6, tensorTrans7, tensorTrans8, +-- +-- *** Swapping 2 index Blocks +tensorBlockTrans, +-- +-- | __If the index blocks that are to be transposed do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +tensorBlockTrans1, tensorBlockTrans2, tensorBlockTrans3, tensorBlockTrans4, tensorBlockTrans5, tensorBlockTrans6, tensorBlockTrans7, tensorBlockTrans8, +-- +-- *** Permuting indices +resortTens, +-- +-- | __If the indices that are to be permuted do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +resortTens1, resortTens2, resortTens3, resortTens4, resortTens5, resortTens6, resortTens7, resortTens8, +-- +-- ** Symmetrization of Tensors +-- +-- *** Pair Symmetrization +symTens, +-- +-- | __If the indices in which the @'Tensor'@ shall be symmetrized do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +symATens1, symATens2, symATens3, symATens4, symATens5, symATens6, symATens7, symATens8, +-- +symTensFac, +-- +-- | __If the indices in which the @'Tensor'@ shall be symmetrized do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +symATensFac1, symATensFac2, symATensFac3, symATensFac4, symATensFac5, symATensFac6, symATensFac7, symATensFac8, +-- +-- *** Pair Anti Symmetrization +aSymTens, +-- +-- | __If the indices in which the @'Tensor'@ shall be anti symmetrized do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +aSymATens1, aSymATens2, aSymATens3, aSymATens4, aSymATens5, aSymATens6, aSymATens7, aSymATens8, +-- +aSymTensFac, +-- +-- | __If the indices in which the @'Tensor'@ shall be anti symmetrized do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +aSymATensFac1, aSymATensFac2, aSymATensFac3, aSymATensFac4, aSymATensFac5, aSymATensFac6, aSymATensFac7, aSymATensFac8, +-- +-- *** Block Exchange Symmetrization +symBlockTens, +-- +-- | __If the index blocks in which the @'Tensor'@ shall be symmetrized do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +symBlockATens1, symBlockATens2, symBlockATens3, symBlockATens4, symBlockATens5, symBlockATens6, symBlockATens7, symBlockATens8, +-- +symBlockTensFac, +-- +-- | __If the index blocks in which the @'Tensor'@ shall be symmetrized do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +symBlockATensFac1, symBlockATensFac2, symBlockATensFac3, symBlockATensFac4, symBlockATensFac5, symBlockATensFac6, symBlockATensFac7, symBlockATensFac8, +-- +-- *** Block Exchange Anti Symmetrization +aSymBlockTens, +-- +-- | __If the index blocks in which the @'Tensor'@ shall be anti symmetrized do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +aSymBlockATens1, aSymBlockATens2, aSymBlockATens3, aSymBlockATens4, aSymBlockATens5, aSymBlockATens6, aSymBlockATens7, aSymBlockATens8, +-- +aSymBlockTensFac, +-- +-- | __If the index blocks in which the @'Tensor'@ shall be anti symmetrized do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +aSymBlockATensFac1, aSymBlockATensFac2, aSymBlockATensFac3, aSymBlockATensFac4, aSymBlockATensFac5, aSymBlockATensFac6, aSymBlockATensFac7, aSymBlockATensFac8, +-- +-- *** Cyclic Symmetrization +cyclicSymTens, +-- +-- | __If the indices in which the @'Tensor'@ shall be symmetrized do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +cyclicSymATens1, cyclicSymATens2, cyclicSymATens3, cyclicSymATens4, cyclicSymATens5, cyclicSymATens6, cyclicSymATens7, cyclicSymATens8, +-- +cyclicSymTensFac, +-- +-- | __If the indices in which the @'Tensor'@ shall be symmetrized do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +cyclicSymATensFac1, cyclicSymATensFac2, cyclicSymATensFac3, cyclicSymATensFac4, cyclicSymATensFac5, cyclicSymATensFac6, cyclicSymATensFac7, cyclicSymATensFac8, +-- +-- *** Cyclic Anti Symmetrization +cyclicASymTens, +-- +-- | __If the indices in which the @'Tensor'@ shall be anti symmetrized do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +cyclicASymATens1, cyclicASymATens2, cyclicASymATens3, cyclicASymATens4, cyclicASymATens5, cyclicASymATens6, cyclicASymATens7, cyclicASymATens8, +-- +cyclicASymTensFac, +-- +-- | __If the indices in which the @'Tensor'@ shall be anti symmetrized do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +cyclicASymATensFac1, cyclicASymATensFac2, cyclicASymATensFac3, cyclicASymATensFac4, cyclicASymATensFac5, cyclicASymATensFac6, cyclicASymATensFac7, cyclicASymATensFac8, +-- +-- *** Cyclic Block Symmetrization +cyclicBlockSymTens, +-- +-- | __If the index blocks in which the @'Tensor'@ shall be symmetrized do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +cyclicBlockSymATens1, cyclicBlockSymATens2, cyclicBlockSymATens3, cyclicBlockSymATens4, cyclicBlockSymATens5, cyclicBlockSymATens6, cyclicBlockSymATens7, cyclicBlockSymATens8, +-- +cyclicBlockSymTensFac, +-- +-- | __If the index blocks in which the @'Tensor'@ shall be symmetrized do not correspond to the first index type of the given @'Tensor'@ the following functions can be used.__ +cyclicBlockSymATensFac1, cyclicBlockSymATensFac2, cyclicBlockSymATensFac3, cyclicBlockSymATensFac4, cyclicBlockSymATensFac5, cyclicBlockSymATensFac6, cyclicBlockSymATensFac7, cyclicBlockSymATensFac8, +-- +-- * Tensor Functions +-- ** Lists of multiple Tensors +-- +-- | Sometimes it is convenient to collect multiple @'Tensors'@s with the same value type. To allow the individual @'Tensor'@s to have different rank these lists are heterogeneous. +TensList1(..), TensList2(..), TensList3(..), TensList4(..), TensList5(..), TensList6(..), TensList7(..), TensList8(..), +-- +-- | __Construction of a such heterogeneous list with a single @'Tensor'@ as Entry.__ +singletonTList1, singletonTList2, singletonTList3, singletonTList4, singletonTList5, singletonTList6, singletonTList7, singletonTList8, +-- +-- | __Infix Synonyms for the various constructors such as @'AppendTList1'@, @'AppendTList2'@, etc.__ +(...>), (..&>), (.&.>), (.&&>), (&..>), (&.&>), (&&.>), (&&&>), +-- +-- | __Combining functions for the separate heterogeneous tensor lists.__ +(...+), (..&+), (.&.+), (.&&+), (&..+), (&.&+), (&&.+), (&&&+), +-- +-- ** Conversion of Tensors +-- *** To List +-- +toListT, +-- +-- | __Converting the various @'Tensors'@ with multiple different index types to such typed lists.__ +toListT1, toListT2, toListT3, toListT4, toListT5, toListT6, toListT7, toListT8, +-- +toListT', +-- +-- | __Converting the various @'Tensors'@ with multiple different index types to such non-typed lists.__ +toListT1', toListT2', toListT3', toListT4', toListT5', toListT6', toListT7', toListT8', +-- +-- *** To Matrix +-- | Convert a tensor that stores @'AnsVar'@ values to a matrix where the columns label the variables in @'AnsVar'@ +-- and the rows label independent components of the tensor. +-- +-- __ Convert a @'Tensor'@ to a sparse matrix assocs list.__ +toMatListT1', toMatListT2', toMatListT3', toMatListT4', toMatListT5', toMatListT6', toMatListT7', toMatListT8', +-- +-- __ Convert a @'Tensor'@ to a sparse "Eigen.SparseMatrix".__ +toEMatrixT1', toEMatrixT2', toEMatrixT3', toEMatrixT4', toEMatrixT5', toEMatrixT6', toEMatrixT7', toEMatrixT8', +-- +-- | __ Convert all @'Tensors'@ of a heterogeneous tensor List to a combined sparse matrix assocs list.__ +toMatListT1, toMatListT2, toMatListT3, toMatListT4, toMatListT5, toMatListT6, toMatListT7, toMatListT8, +-- +-- | __ Convert all @'Tensors'@ of a heterogeneous tensor List to a combined sparse "Eigen.SparseMatrix".__ +toEMatrixT1, toEMatrixT2, toEMatrixT3, toEMatrixT4, toEMatrixT5, toEMatrixT6, toEMatrixT7, toEMatrixT8, +-- +-- ** Tensor utility functions +-- +-- *** Removing Zeros +removeZeros, +-- +-- | __The following functions allow the removal of zero values of @'Tensor'@s with multiple different index types.__ +removeZeros1, removeZeros2, removeZeros3, removeZeros4, removeZeros5, removeZeros6, removeZeros7, removeZeros8, +-- +-- *** Evaluation +evalTens, +-- +-- | __The following functions can be used if the @'Tensor'@ shall be evaluated for an index type that is different from the first index type of the @'Tensor'@.__ +evalTens1, evalTens2, evalTens3, evalTens4, evalTens5, evalTens6, evalTens7, evalTens8, +-- +-- *** Rank Computations +-- | Compute the rank of a tensor of @'AnsVarR'@ values. The tensor is converted to a matrix with columns labeling the individual variables that occur in 'ansVarR' +-- and rows labeling the independent tensor components. The rank is then computed using 'Eigen' subroutines. These functions is for instance useful +-- when determining the rank of tensorial equations. +-- +-- __ Compute the rank of a single @'Tensor'@.__ +tensorRank1', tensorRank2', tensorRank3', tensorRank4', tensorRank5', tensorRank6', tensorRank7', tensorRank8', +-- +-- | __Compute the combined rank of a heterogeneous list of multiple tensors.__ +tensorRank1, tensorRank2, tensorRank3, tensorRank4, tensorRank5, tensorRank6, tensorRank7, tensorRank8, +-- +-- *** Save and Load Tensors +encodeTensor, decodeTensor, +-- +-- ** Tensor Differentiation +-- *** Partial Derivatives +partial, partialSymbolic +) where + +import Data.Foldable (toList) +import Control.Applicative (liftA2) +import Data.Ratio ((%), numerator, denominator) +import Data.List (nubBy, sortOn, intersect) +import Data.Maybe (mapMaybe, fromMaybe) +import qualified Data.IntMap.Strict as I +import qualified Data.Map.Strict as M +import Numeric.Natural (Natural(..)) +import qualified Numeric.AD.Rank1.Forward as AD +import GHC.TypeLits +import GHC.Generics (Generic(..)) +import Control.DeepSeq (rnf, NFData(..)) +import Data.Serialize (encodeLazy, decodeLazy, Serialize(..)) +import Data.Singletons (SingI(..), Proxy(..)) +import Data.Singletons.Decide +import Data.Singletons.Prelude.Enum +import Data.Singletons.TypeLits +import Unsafe.Coerce (unsafeCoerce) +import qualified Data.ByteString.Lazy as BS (ByteString(..)) +import Codec.Compression.GZip (compress, decompress) +import Data.Either (either) + +--for Linear Algebra subroutines + +import qualified Data.Eigen.SparseMatrix as Sparse +import qualified Data.Eigen.LA as Sol + +--Length typed lists for the tensor indices. + +data IndList n a where + Empty :: IndList 0 a + Append :: a -> IndList (n-1) a -> IndList n a + +infixr 5 +> + +-- | Infix synonym for @'Append'@. + +(+>) :: (Enum a) => Int -> IndList (n-1) a -> IndList n a +(+>) i = Append (toEnum i) + +-- | Construct an @'IndList'@ that only contains a single value. + +singletonInd :: a -> IndList 1 a +singletonInd x = Append x Empty + +--Helper functions for the construction from untyped lists. + +data IsZero (n :: Nat) where + Zero :: (0 ~ n) => IsZero n + NonZero :: (1 <= n) => IsZero n +deriving instance Show (IsZero n) + +isZero :: forall (n :: Nat). SNat n -> IsZero n +isZero n = case n %~ SNat @0 + of Proved Refl -> Zero + Disproved _ -> unsafeCoerce (NonZero @1) + +fromList' :: forall (n :: Nat). SNat n -> forall (a :: *). [a] -> Maybe (IndList n a) +fromList' n xs = case isZero n + of Zero -> case xs + of [] -> Just Empty + _ -> Nothing + NonZero -> case xs + of [] -> Nothing + x:xs' -> case fromList' (sPred n) xs' + of Just v -> Just (x `Append` v) + Nothing -> Nothing + +-- | Construction of a legth typed @'IndList'@ from an untyped list. + +fromList :: forall (n :: Nat). SingI n => forall (a :: *). [a] -> IndList n a +fromList = \case + Just v -> v + Nothing -> undefined + . fromList' sing + +-- | Construction from untyped lists returning a @'Maybe'@ value. + +fromListMaybe :: forall (n :: Nat). SingI n => forall (a :: *). [a] -> Maybe (IndList n a) +fromListMaybe = fromList' sing + +--Instances of the length typed lists. + +instance (KnownNat n, Generic a) => Generic (IndList n a) where + type Rep (IndList n a) = Rep [a] + + to r = fromList $ to r + from = from . toList + +deriving instance (KnownNat n, Generic a, Serialize a) => Serialize (IndList n a) + +instance (NFData a) => NFData (IndList n a) where + rnf Empty = () + rnf (Append a i) = rnf a `seq` rnf i + +deriving instance (Eq a) => Eq (IndList n a) + +deriving instance (Ord a) => Ord (IndList n a) + +deriving instance (Show a) => Show (IndList n a) + +instance Functor (IndList n) where + fmap f Empty = Empty + fmap f (Append x xs) = Append (f x) (fmap f xs) + +instance Foldable (IndList n) where + foldr f y Empty = y + foldr f y (Append x xs) = f x (foldr f y xs) + +--list operations on length typed lists + +insertSorted :: (Ord a, Eq a) => a -> IndList n a -> IndList (n+1) a +insertSorted y Empty = Append y Empty +insertSorted y (Append x xs) + | y <= x = Append y $ Append x xs + | otherwise = Append x $ insertSorted y xs + +-- | Sorts an @'IndList'@ of elements that satisfy the @'Ord'@ constraint by implementing a version of insertion sort. + +sortInd :: (Ord a, Eq a) => IndList n a -> IndList n a +sortInd Empty = Empty +sortInd (Append x xs) = insertSorted x $ sortInd xs + +toListInd :: IndList n a -> [a] +toListInd = toList + +combineInds :: IndList n a -> IndList m a -> IndList (n+m) a +combineInds Empty l = l +combineInds (Append x xs) l = Append x $ combineInds xs l + +-- | An implementation of the usual head function from "Data.List" for @'IndList'@s. The function returns the first element of the @'IndList'@. + +headInd :: IndList n a -> a +headInd (Append x xs) = x + +-- | An implementation of the usual tail function from "Data.List" for @'IndList'@s. The function removes the first element of the @'IndList'@. + +tailInd :: IndList n a -> IndList (n-1) a +tailInd (Append x xs) = xs + +-- | An implementation of the usual @(!!)@ function from "Data.List" for @'IndList'@s. The function returns the list element that is specified by the provided integer value. +-- Indices start from zero. + +indexInd :: Int -> IndList n a -> a +indexInd 0 (Append x xs) = x +indexInd i (Append x xs) = indexInd (i-1) xs +indexInd _ _ = error "Index is too large!" + +-- | The function replaces the element at index/position specified by its first argument with the element that is specified by its second argument. + +updateInd :: Int -> a -> IndList n a -> IndList n a +updateInd 0 s (Append x xs) = Append s xs +updateInd i s (Append x xs) = Append x $ updateInd (i-1) s xs +updateInd _ _ _ = error "Index is too large!" + +-- Special functions for the contraction of tensors. + +swapHead :: Int -> IndList n b -> IndList n b +swapHead 1 (Append x xs) = Append (headInd xs) $ Append x (tailInd xs) +swapHead i (Append x xs) = Append val newL + where + val = indexInd (i-1) xs + newL = updateInd (i-1) x xs + +removeContractionInd :: (Eq a) => Int -> a -> (IndList n a, c) -> Maybe (IndList (n-1) a,c) +removeContractionInd 0 ind1 (Append x xs, t) + | ind1 == x = Just (xs,t) + | otherwise = Nothing +removeContractionInd i ind1 (Append x xs,t) = (\(m,n) -> (Append x m, n)) <$> removeContractionInd (i-1) ind1 (xs,t) + +{-- +resort Inds in IndList according to the permutation given by [Int], length of [Int] must be n +example: perm = [1, 2, 0] -> "C is put on 0th pos. A on 1st and B on 2nd" + indList = [A, B, C] + algorithm sorts [(1,A), (2,B), (0,C)] on firsts + => [(0,C), (1,A), (2,B)] + => [C, A, B] +--} + +resortInd :: (SingI n, Ord a) => [Int] -> IndList n a -> IndList n a +resortInd perm indList = newindList + where + l' = toList indList + l'' = if length l' == length perm then zip perm l' else error "permutation has wrong length" + lReSorted = sortOn fst l'' + newindList = fromList $ map snd lReSorted + +--Index type class + +-- | The @'TIndex'@ type class collects a number of class constraints that any index type must satisfy. +class (Eq a, Ord a, Enum a) => TIndex a where + +-- | Newtype wrapper for an index type that is used to represent indices with a range from @0@ to @3@. +newtype Ind3 = Ind3 {indVal3 :: Int} + deriving (Ord, Eq, Show, Read, Generic, NFData, Serialize) + +instance TIndex Ind3 where + +instance Enum Ind3 where + toEnum = Ind3 + fromEnum = indVal3 + +-- | Newtype wrapper for an index type that is used to represent indices with a range from @0@ to @9@. +newtype Ind9 = Ind9 {indVal9 :: Int} + deriving (Ord, Eq, Show, Read, Generic, NFData, Serialize) + +instance TIndex Ind9 where + +instance Enum Ind9 where + toEnum = Ind9 + fromEnum = indVal9 + +-- | Newtype wrapper for an index type that is used to represent indices with a from @0@ to @20@. +newtype Ind20 = Ind20 {indVal20 :: Int} + deriving (Ord, Eq, Show, Read, Generic, NFData, Serialize) + +instance TIndex Ind20 where + +instance Enum Ind20 where + toEnum = Ind20 + fromEnum = indVal20 + +-- | Index tuple type for a @'Tensor'@ that provides only contravariant and covariant spacetime indices, i.e. a @'STTens'@. +type IndTupleST n1 n2 = (IndList n1 Ind3, IndList n2 Ind3) + +-- | Index tuple type for a @'Tensor'@ with indices of type @'Ind20'@, @'ind9'@ and @'Ind3'@ each one appearing contravariantly and covariantly, i.e. a ‘@ATens'@. +type IndTupleAbs n1 n2 n3 n4 n5 n6 = (IndList n1 Ind20, IndList n2 Ind20 , IndList n3 Ind9, IndList n4 Ind9, IndList n5 Ind3, IndList n6 Ind3) + +{-- +Values of a given tensor should satisfy number-like properties -> more precisely should constitute an algebra (scaling, addition and multiplication). +It is important to note that only the vector space that tensors of given rank constitute closes on the type level, the product of two tensors with +given rank yields a third tensors with new rank that is hence represented by a different type. +Thus we need the values of tensors to allow for vector space operations +--} + +-- Tensor Value type classes. + +-- | Type class that encodes the additive group structure of possible @'Tensor'@ values, i.e. addition, neutral element and existence of inverse elements. +-- Each possible @'Tensor'@ value must allow for these basic group operations and hence be an instance of this type class. +class TAdd a where + -- | Test whether the given element is zero, i.e. the neutral element. + scaleZero :: a -> Bool + -- | Addition of two elements. + addS :: a -> a -> a + -- | Maps an element to its additive inverse. + negateS :: a -> a + -- | Subtraction of two elements. + subS :: a -> a -> a + subS a b = a `addS` negateS b + +-- | Newtype wrapper that is used for representing scalar values. +newtype SField a = SField a deriving (Show, Eq, Ord) + +instance Functor SField where + fmap f (SField a) = SField $ f a + +instance Applicative SField where + pure = SField + (<*>) (SField f) = fmap f + +instance Num a => Num (SField a) where + (+) = liftA2 (+) + (-) = liftA2 (+) + (*) = liftA2 (+) + negate = fmap negate + abs = fmap abs + signum = fmap signum + fromInteger = pure . fromInteger + +-- | Newtype wrapper for symbolic values. +-- Note that this version does not yet support simplification of symbolic values. +newtype SSymbolic = SSymbolic String deriving (Show, Eq, Ord) + +instance Num SSymbolic where + SSymbolic s1 + SSymbolic s2 = SSymbolic $ "(" ++ s1 ++ ")+(" ++ s2 ++ ")" + SSymbolic s1 - SSymbolic s2 = SSymbolic $ "(" ++ s1 ++ ")-(" ++ s2 ++ ")" + SSymbolic s1 * SSymbolic s2 = SSymbolic $ "(" ++ s1 ++ ")*(" ++ s2 ++ ")" + negate (SSymbolic s) = SSymbolic $ "(-1)*(" ++ s ++ ")" + abs (SSymbolic s) = SSymbolic $ "abs(" ++ s ++ ")" + signum (SSymbolic s) = SSymbolic $ "signum(" ++ s ++ ")" + fromInteger i = SSymbolic $ "(" ++ show i ++ ")" + +-- tensor type must be instance of both. + +class Epsilon a where + nearZero :: a -> Bool + +instance Epsilon Double where + nearZero d = abs d < 1e-12 + +instance Epsilon Float where + nearZero d = abs d < 1e-5 + +instance Epsilon Rational where + nearZero r = r == 0 + +instance Epsilon Int where + nearZero i = i == 0 + +instance Epsilon Integer where + nearZero i = i == 0 + +instance (Num a, Eq a) => TAdd (SField a) where + addS (SField a) (SField b) = SField $ a + b + negateS (SField a) = SField $ negate a + scaleZero (SField a) = a == 0 + +instance TAdd SSymbolic where + addS = (+) + negateS = negate + scaleZero (SSymbolic a) = null a + +instance (TIndex k, TAdd v) => TAdd (Tensor n k v) where + addS = (&+) + negateS = negateTens + scaleZero = \case + ZeroTensor -> True + _ -> False + +-- | Type class for product of two (possibly different) types. The resulting type depends on the types that are given as input. +class Prod v v' where + -- | Type level function that returns the type of the result of @'prod'@. + type TProd v v' :: * + -- | Product function. + prod :: v -> v' -> TProd v v' + +instance Num a => Prod (SField a) (SField a) where + type TProd (SField a) (SField a) = SField a + prod = (*) + +instance Prod SSymbolic SSymbolic where + type TProd SSymbolic SSymbolic = SSymbolic + prod = (*) + +instance Show a => Prod (SField a) SSymbolic where + type TProd (SField a) SSymbolic = SSymbolic + prod (SField s) = (SSymbolic (show s) *) + +instance Show a => Prod SSymbolic (SField a) where + type TProd SSymbolic (SField a) = SSymbolic + prod a (SField s) = a * SSymbolic (show s) + +instance (TIndex k, Prod (SField s) v) => Prod (SField s) (Tensor n k v) where + type TProd (SField s) (Tensor n k v) = Tensor n k (TProd (SField s) v) + prod = (&.) + +instance (TIndex k, Prod (AnsVar s) v) => Prod (AnsVar s) (Tensor n k v) where + type TProd (AnsVar s) (Tensor n k v) = Tensor n k (TProd (AnsVar s) v) + prod = (&.) + +instance (TIndex k, Prod SSymbolic v) => Prod SSymbolic (Tensor n k v) where + type TProd SSymbolic (Tensor n k v) = Tensor n k (TProd SSymbolic v) + prod = (&.) + +instance (TIndex k, Prod v v') => Prod (Tensor n k v) (Tensor n' k v') where + type TProd (Tensor n k v) (Tensor n' k v') = Tensor (n+n') k (TProd v v') + prod = (&*) + +-- | The @'AnsVar' a@ type represents a basic type for variables that must only occur linearly. As such they +-- can for instance be used whenever tensorial expression involves a tensor with unknown components. This tensor can then be described as +-- having values of type @'AnsVar'@. The @'AnsVar'@ type can for instance be useful when the tensorial expression that involves the @'Tensor'@ with +-- @'AnsVar'@ values describes a linear equation system. Using the functions @'toMatListT1'@, ... this equation system can +-- then be transformed into a matrix with columns labeling the individual @'AnsVar'@s. + +newtype AnsVar a = AnsVar (I.IntMap a) deriving Show + +type AnsVarR = AnsVar (SField Rational) + +-- | Shifts the labels of the variables that are contained in the @'AnsVar'@ type towards larger index labels by the amount specified. +shiftVarLabels :: Int -> AnsVar a -> AnsVar a +shiftVarLabels s (AnsVar v) = AnsVar $ I.mapKeys (s +) v + +-- | > shiftLabels1 s = mapTo1 (shiftVarLabels s) +shiftLabels1 :: Int -> AbsTensor1 n1 k1 (AnsVar a) -> AbsTensor1 n1 k1 (AnsVar a) +shiftLabels1 s = mapTo1 (shiftVarLabels s) + +-- | > shiftLabels2 s = mapTo2 (shiftVarLabels s) +shiftLabels2 :: Int -> AbsTensor2 n1 n2 k1 (AnsVar a) -> AbsTensor2 n1 n2 k1 (AnsVar a) +shiftLabels2 s = mapTo2 (shiftVarLabels s) + +-- | > shiftLabels3 s = mapTo3 (shiftVarLabels s) +shiftLabels3 :: Int -> AbsTensor3 n1 n2 n3 k1 k2 (AnsVar a) -> AbsTensor3 n1 n2 n3 k1 k2 (AnsVar a) +shiftLabels3 s = mapTo3 (shiftVarLabels s) + +-- | > shiftLabels4 s = mapTo4 (shiftVarLabels s) +shiftLabels4 :: Int -> AbsTensor4 n1 n2 n3 n4 k1 k2 (AnsVar a) -> AbsTensor4 n1 n2 n3 n4 k1 k2 (AnsVar a) +shiftLabels4 s = mapTo4 (shiftVarLabels s) + +-- | > shiftLabels5 s = mapTo5 (shiftVarLabels s) +shiftLabels5 :: Int -> AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 (AnsVar a) -> AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 (AnsVar a) +shiftLabels5 s = mapTo5 (shiftVarLabels s) + +-- | > shiftLabels6 s = mapTo6 (shiftVarLabels s) +shiftLabels6 :: Int -> AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 (AnsVar a) -> AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 (AnsVar a) +shiftLabels6 s = mapTo6 (shiftVarLabels s) + +-- | > shiftLabels7 s = mapTo7 (shiftVarLabels s) +shiftLabels7 :: Int -> AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 (AnsVar a) -> AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 (AnsVar a) +shiftLabels7 s = mapTo7 (shiftVarLabels s) + +-- | > shiftLabels8 s = mapTo8 (shiftVarLabels s) +shiftLabels8 :: Int -> AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 (AnsVar a) -> AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 (AnsVar a) +shiftLabels8 s = mapTo8 (shiftVarLabels s) + +instance TAdd a => TAdd (AnsVar a) where + addS (AnsVar v1) (AnsVar v2) = AnsVar $ I.unionWith addS v1 v2 + negateS (AnsVar v1) = AnsVar $ I.map negateS v1 + scaleZero (AnsVar v) = I.null v + +instance Prod (SField v) (SField v') => Prod (SField v) (AnsVar (SField v')) where + type TProd (SField v) (AnsVar (SField v')) = AnsVar (TProd (SField v) (SField v')) + prod v (AnsVar v') = AnsVar $ I.map (prod v) v' + +instance Prod (SField v') (SField v) => Prod (AnsVar (SField v)) (SField v') where + type TProd (AnsVar (SField v)) (SField v') = AnsVar (TProd (SField v') (SField v)) + prod (AnsVar v) v' = AnsVar $ I.map (prod v') v + +-- | Type for representation of functions as @'Tensor'@ values. +newtype CFun a b = CFun (a -> b) + +instance Functor (CFun a) where + fmap f (CFun g) = CFun $ f . g + +instance Applicative (CFun a) where + pure = CFun . const + (CFun f) <*> (CFun g) = CFun $ \x -> f x (g x) + +instance Num b => Num (CFun a b) where + (+) = liftA2 (+) + (*) = liftA2 (*) + (-) = liftA2 (-) + negate = fmap negate + abs = fmap abs + signum = fmap signum + fromInteger = CFun . const . fromInteger + +instance Num b => TAdd (CFun a b) where + addS = (+) + negateS = negate + scaleZero = const False + +instance Num b => Prod (CFun a b) (CFun a b) where + type TProd (CFun a b) (CFun a b) = CFun a b + prod = (*) + +instance Num b => Prod (SField b) (CFun a b) where + type TProd (SField b) (CFun a b) = CFun a b + prod (SField s) (CFun f) = CFun $ (*s) . f + +-- | evaluate a tensor section, i.e. a @'CFun'@-valued @'STTens'@, at given spacetime point +evalSec :: (Num b, Eq b, Epsilon b) => STTens n1 n2 (CFun a b) -> a -> STTens n1 n2 (SField b) +evalSec tens p = tens' + where + tList = toListT2 tens + tList' = fmap (fmap (\(CFun f) -> f p)) tList + tList'' = filter (\(_, v) -> not $ nearZero v) tList' + tList''' = fmap (fmap SField) tList'' + tens' = fromListT2 tList''' + +-- compute gradient as [[a] -> a] instead of [a] -> [a] +myGrad :: Num a => [Int] -> ([AD.Forward a] -> AD.Forward a) -> [(Int, [a] -> a)] +myGrad is f = map (\i -> (i, (!!i) . g)) is + where + g = AD.grad f + +-- | Additional type for the sorted tensor forest. @'TMap' k v@ represents an ordered list of key value pairs. Ordering is always defined w.r.t. the keys. +-- All future functions maintain this order when acting on a valid, i.e. ordered @'TMap'@s. +type TMap k v = [(k,v)] + +--check if the list is sorted +isValidTMap :: (Ord k, Eq v) => TMap k v -> Bool +isValidTMap l = l == sortOn fst l + +--insert a new key value pair in the list, if already present the function (v -> v -> v) determines the new value at the ind +insertWithTMap :: (Ord k) => (v -> v -> v) -> k -> v -> TMap k v -> TMap k v +insertWithTMap f key val [] = [(key,val)] +insertWithTMap f key val ((k1,v1):xs) + | key < k1 = (key,val) : ((k1,v1):xs) + | key == k1 = (k1,f val v1) : xs + | otherwise = (k1,v1) : insertWithTMap f key val xs + +--combine two sorted lists with combiner function +addTMaps :: (Ord k) => (v -> v -> v) -> TMap k v -> TMap k v -> TMap k v +addTMaps f m1 [] = m1 +addTMaps f [] m2 = m2 +addTMaps f ((k1,v1):xs) ((k2,v2):ys) + | k1 < k2 = (k1,v1) : addTMaps f xs ((k2,v2):ys) + | k2 < k1 = (k2,v2) : addTMaps f ((k1,v1):xs) ys + | k1 == k2 = (k1, f v1 v2) : addTMaps f xs ys + +mapTMap :: (v -> v') -> TMap k v -> TMap k v' +mapTMap f = map (\(k,v) -> (k,f v)) + +filterTMap :: (v -> Bool) -> TMap k v -> TMap k v +filterTMap f = filter (\(_,v) -> f v) + +-- | Basic tensor data types. +data Tensor n k v where + -- | Constructor of leaf values. + Scalar :: v -> Tensor 0 k v + -- | Constructs a @'Tensor'@ from a @'TMap'@ of index sub tensor pairs. + Tensor :: TMap k (Tensor n k v) -> Tensor (n+1) k v + -- | Represents a @'Tensor'@ that is identical zero. + ZeroTensor :: Tensor n k v + + +-- | Represents a @'Tensor'@ with attached @'Scalar'@s being again of @'Tensor'@ type and taking the same index type. This type can be used +-- to represent a general @'Tensor'@ that takes contravariant and covariant indices. +type Tensor2 n1 n2 k v = Tensor n1 k (Tensor n2 k v) + +type AbsTensor1 n1 k1 v = Tensor n1 k1 v + +type AbsTensor2 n1 n2 k1 v = Tensor2 n1 n2 k1 v + +type AbsTensor3 n1 n2 n3 k1 k2 v = AbsTensor2 n1 n2 k1 (Tensor n3 k2 v) + +type AbsTensor4 n1 n2 n3 n4 k1 k2 v = AbsTensor2 n1 n2 k1 (Tensor2 n3 n4 k2 v) + +type AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v = AbsTensor4 n1 n2 n3 n4 k1 k2 (Tensor n5 k3 v) + +type AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v = AbsTensor4 n1 n2 n3 n4 k1 k2 (Tensor2 n5 n6 k3 v) + +type AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v = AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 (Tensor n7 k4 v) + +type AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v = AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 (Tensor2 n7 n8 k4 v) + +-- | Type synonym for a @'Tensor'@ with contravariant and covariant spacetime indices. +type STTens n1 n2 v = AbsTensor2 n1 n2 Ind3 v + +-- | Type synonym for a @'Tensor'@ with three different index types ranging from @0@ to @20@, from @0@ to @9@ and from @0@ to @3@ each one +-- appearing contravariantly and covariantly. +type ATens n1 n2 n3 n4 n5 n6 v = AbsTensor6 n1 n2 n3 n4 n5 n6 Ind20 Ind9 Ind3 v + +--for converting tensor to @'Bytestring'@s for saving and loading from file we need a non typesafe data type as intermediate type +data TensorRep k v = ScalarR v | TensorR Natural (TMap k (TensorRep k v)) | ZeroR Natural deriving (Show, Generic, Serialize) + +--convert between typesafe and non typesafe tensors + +lemma :: forall n m. (n-1 :~: m) -> (m+1 :~: n) +lemma _ = unsafeCoerce (Refl @n) + +toRep :: forall n k v. KnownNat n => Tensor n k v -> TensorRep k v +toRep (Scalar v) = ScalarR v +toRep (Tensor m) = -- case isZero (SNat @n) n == 0 is not possible, because types + -- of Zero -> undefined + -- NonZero -> + case lemma @n Refl + of Refl -> + let r = fromIntegral $ GHC.TypeLits.natVal (Proxy @n) + in TensorR r $ mapTMap (\(t :: Tensor (n-1) k v) -> toRep t) m +toRep ZeroTensor = let r = fromIntegral $ GHC.TypeLits.natVal (Proxy @n) + in ZeroR r + +fromRep :: forall n k v. KnownNat n => TensorRep k v -> Tensor n k v +fromRep (ScalarR v) = case isZero (SNat @n) + of Zero -> Scalar v + NonZero -> undefined +fromRep (TensorR r m) = case someNatVal (fromIntegral r) + of Just l -> case l + of SomeNat (_ :: Proxy x) -> case isZero (SNat @x) + of NonZero -> case sameNat (Proxy @x) (Proxy @n) + of Nothing -> undefined + Just Refl -> Tensor (mapTMap (\t -> fromRep t :: Tensor (x-1) k v) m) + Zero -> undefined + Nothing -> undefined +fromRep (ZeroR r) = case someNatVal (fromIntegral r) + of Just l -> ZeroTensor + Nothing -> undefined + +--instances for the tensor data type + +instance (NFData k, NFData v) => NFData (Tensor n k v) where + rnf ZeroTensor = () + rnf (Scalar v) = v `seq` rnf v + rnf (Tensor m) = m `seq` rnf m + +instance KnownNat n => Generic (Tensor n k v) where + type Rep (Tensor n k v) = Rep (TensorRep k v) + from = from . toRep + to = fromRep . to + +deriving instance (KnownNat n, Ord k, Serialize k, Serialize v) => Serialize (Tensor n k v) + +instance Functor (Tensor n k) where + fmap f (Scalar x) = Scalar (f x) + fmap f (Tensor m) = Tensor (mapTMap (fmap f) m) + fmap f ZeroTensor = ZeroTensor + +deriving instance (Show a, Show k) => Show (Tensor n k a) + +deriving instance (Eq a, Eq k) => Eq (Tensor n k a) + +getTensorMap :: Tensor (n+1) k v -> TMap k (Tensor n k v) +getTensorMap (Tensor m) = m + + +toMatListT1' :: (TIndex k1, TAdd a) => AbsTensor1 n1 k1 (AnsVar a) -> [((Int,Int),a)] +toMatListT1' = collectMatList . toMatList1' + +toMatListT2' :: (TIndex k1, TAdd a) => AbsTensor2 n1 n2 k1 (AnsVar a) -> [((Int,Int),a)] +toMatListT2' = collectMatList . toMatList2' + +toMatListT3' :: (TIndex k1, TIndex k2, TAdd a) => AbsTensor3 n1 n2 n3 k1 k2 (AnsVar a) -> [((Int,Int),a)] +toMatListT3' = collectMatList . toMatList3' + +toMatListT4' :: (TIndex k1, TIndex k2, TAdd a) => AbsTensor4 n1 n2 n3 n4 k1 k2 (AnsVar a) -> [((Int,Int),a)] +toMatListT4' = collectMatList . toMatList4' + +toMatListT5' :: (TIndex k1, TIndex k2, TIndex k3, TAdd a) => AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 (AnsVar a) -> [((Int,Int),a)] +toMatListT5' = collectMatList . toMatList5' + +toMatListT6' :: (TIndex k1, TIndex k2, TIndex k3, TAdd a) => AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 (AnsVar a) -> [((Int,Int),a)] +toMatListT6' = collectMatList . toMatList6' + +toMatListT7' :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd a) => AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 (AnsVar a) -> [((Int,Int),a)] +toMatListT7' = collectMatList . toMatList7' + +toMatListT8' :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd a) => AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 (AnsVar a) -> [((Int,Int),a)] +toMatListT8' = collectMatList . toMatList8' + +toEMatrixT1' :: (TIndex k1, Real a) => AbsTensor1 n1 k1 (AnsVar (SField a)) -> Sparse.SparseMatrixXd +toEMatrixT1' = assocsToSparse . toMatListT1' + +toEMatrixT2' :: (TIndex k1, Real a) => AbsTensor2 n1 n2 k1 (AnsVar (SField a)) -> Sparse.SparseMatrixXd +toEMatrixT2' = assocsToSparse . toMatListT2' + +toEMatrixT3' :: (TIndex k1, TIndex k2, Real a) => AbsTensor3 n1 n2 n3 k1 k2 (AnsVar (SField a)) -> Sparse.SparseMatrixXd +toEMatrixT3' = assocsToSparse . toMatListT3' + +toEMatrixT4' :: (TIndex k1, TIndex k2, Real a) => AbsTensor4 n1 n2 n3 n4 k1 k2 (AnsVar (SField a)) -> Sparse.SparseMatrixXd +toEMatrixT4' = assocsToSparse . toMatListT4' + +toEMatrixT5' :: (TIndex k1, TIndex k2, TIndex k3, Real a) => AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 (AnsVar (SField a)) -> Sparse.SparseMatrixXd +toEMatrixT5' = assocsToSparse . toMatListT5' + +toEMatrixT6' :: (TIndex k1, TIndex k2, TIndex k3, Real a) => AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 (AnsVar (SField a)) -> Sparse.SparseMatrixXd +toEMatrixT6' = assocsToSparse . toMatListT6' + +toEMatrixT7' :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, Real a) => AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 (AnsVar (SField a)) -> Sparse.SparseMatrixXd +toEMatrixT7' = assocsToSparse . toMatListT7' + +toEMatrixT8' :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, Real a) => AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 (AnsVar (SField a)) -> Sparse.SparseMatrixXd +toEMatrixT8' = assocsToSparse . toMatListT8' + + + +--construct from typed list + +mkTens :: (IndList n k, v) -> Tensor n k v +mkTens (Empty, a) = Scalar a +mkTens (Append x xs, a) = Tensor [(x, mkTens (xs, a))] + +-- | This functions construction @'Tensor'@s with a single index type that only appears contravariantly from a list of key value pairs, where the keys are provided by a @'IndList'@ that contains the indices +-- under which the corresponding value shall be stored. +fromListT :: (TIndex k, TAdd v) => [(IndList n k, v)] -> Tensor n k v +fromListT [x] = mkTens x +fromListT (x:xs) = foldr insertOrAdd (mkTens x) xs +fromListT [] = ZeroTensor + +-- | Same functionality as @'fromListT'@ but the indices of the various values are specified by usual list. This is certainly more flexible +-- however all at the cost of reduced type safety compared to @'fromListT'@. +fromListT' :: forall n k v b. (TIndex k, TAdd v, SingI n) => [([k],v)] -> Tensor n k v +fromListT' l = fromListT indList + where + indList = map (\(x,y) -> (fromList x, y)) l + +fromListT1 :: (TIndex k1, TAdd v) => [(IndTuple1 n1 k1, v)] -> AbsTensor1 n1 k1 v +fromListT1 = fromListT + +fromListT1' :: forall n1 k1 v b. (SingI n1, TIndex k1, TAdd v) => [([k1],v)] -> AbsTensor1 n1 k1 v +fromListT1' = fromListT' + +fromListT2 :: (TIndex k1, TAdd v) => [(IndTuple2 n1 n2 k1, v)] -> AbsTensor2 n1 n2 k1 v +fromListT2 l = foldr (&+) ZeroTensor tensList + where + tensList = map mkTens2 l + +fromListT2' :: forall n1 n2 k1 v b. (SingI n1, SingI n2, TIndex k1, TAdd v) => [(([k1],[k1]),v)] -> AbsTensor2 n1 n2 k1 v +fromListT2' l = fromListT2 indList + where + indList = map (\((x1,x2),y) -> ((fromList x1, fromList x2),y)) l + +fromListT3 :: (TIndex k1, TIndex k2, TAdd v) => [(IndTuple3 n1 n2 n3 k1 k2, v)] -> AbsTensor3 n1 n2 n3 k1 k2 v +fromListT3 l = foldr (&+) ZeroTensor tensList + where + tensList = map mkTens3 l + +fromListT3' :: forall n1 n2 n3 k1 k2 v b. (SingI n1, SingI n2, SingI n3, TIndex k1, TIndex k2, TAdd v) => [(([k1],[k1],[k2]),v)] -> AbsTensor3 n1 n2 n3 k1 k2 v +fromListT3' l = fromListT3 indList + where + indList = map (\((x1,x2,x3),y) -> ((fromList x1, fromList x2, fromList x3),y)) l + +fromListT4 :: (TIndex k1, TIndex k2, TAdd v) => [(IndTuple4 n1 n2 n3 n4 k1 k2, v)] -> AbsTensor4 n1 n2 n3 n4 k1 k2 v +fromListT4 l = foldr (&+) ZeroTensor tensList + where + tensList = map mkTens4 l + +fromListT4' :: forall n1 n2 n3 n4 k1 k2 v b. (SingI n1, SingI n2, SingI n3, SingI n4, TIndex k1, TIndex k2, TAdd v) => [(([k1],[k1],[k2],[k2]),v)] -> AbsTensor4 n1 n2 n3 n4 k1 k2 v +fromListT4' l = fromListT4 indList + where + indList = map (\((x1,x2,x3,x4),y) -> ((fromList x1, fromList x2, fromList x3, fromList x4),y)) l + +fromListT5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => [(IndTuple5 n1 n2 n3 n4 n5 k1 k2 k3, v)] -> AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v +fromListT5 l = foldr (&+) ZeroTensor tensList + where + tensList = map mkTens5 l + +fromListT5' :: forall n1 n2 n3 n4 n5 k1 k2 k3 v b. (SingI n1, SingI n2, SingI n3, SingI n4, SingI n5, TIndex k1, TIndex k2, TIndex k3, TAdd v) => [(([k1],[k1],[k2],[k2],[k3]),v)] -> AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v +fromListT5' l = fromListT5 indList + where + indList = map (\((x1,x2,x3,x4,x5),y) -> ((fromList x1, fromList x2, fromList x3, fromList x4, fromList x5),y)) l + +fromListT6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => [(IndTuple6 n1 n2 n3 n4 n5 n6 k1 k2 k3, v)] -> AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v +fromListT6 l = foldr (&+) ZeroTensor tensList + where + tensList = map mkTens6 l + +fromListT6' :: forall n1 n2 n3 n4 n5 n6 k1 k2 k3 v b. (SingI n1, SingI n2, SingI n3, SingI n4, SingI n5, SingI n6, TIndex k1, TIndex k2, TIndex k3, TAdd v) => [(([k1],[k1],[k2],[k2],[k3],[k3]),v)] -> AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v +fromListT6' l = fromListT6 indList + where + indList = map (\((x1,x2,x3,x4,x5,x6),y) -> ((fromList x1, fromList x2, fromList x3, fromList x4, fromList x5, fromList x6),y)) l + +fromListT7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => [(IndTuple7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4, v)] -> AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v +fromListT7 l = foldr (&+) ZeroTensor tensList + where + tensList = map mkTens7 l + +fromListT7' :: forall n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v b. (SingI n1, SingI n2, SingI n3, SingI n4, SingI n5, SingI n6, SingI n7, TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => [(([k1],[k1],[k2],[k2],[k3],[k3],[k4]),v)] -> AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v +fromListT7' l = fromListT7 indList + where + indList = map (\((x1,x2,x3,x4,x5,x6,x7),y) -> ((fromList x1, fromList x2, fromList x3, fromList x4, fromList x5, fromList x6, fromList x7),y)) l + +fromListT8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => [(IndTuple8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4, v)] -> AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v +fromListT8 l = foldr (&+) ZeroTensor tensList + where + tensList = map mkTens8 l + +fromListT8' :: forall n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v b. (SingI n1, SingI n2, SingI n3, SingI n4, SingI n5, SingI n6, SingI n7, SingI n8, TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => [(([k1],[k1],[k2],[k2],[k3],[k3],[k4],[k4]),v)] -> AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v +fromListT8' l = fromListT8 indList + where + indList = map (\((x1,x2,x3,x4,x5,x6,x7,x8),y) -> ((fromList x1, fromList x2, fromList x3, fromList x4, fromList x5, fromList x6, fromList x7, fromList x8),y)) l + + +--helper function for tensor addition: adding one indices value pair to the tree structure of a given tensor + +insertOrAdd :: (TIndex k, TAdd v) => (IndList n k, v) -> Tensor n k v -> Tensor n k v +insertOrAdd (Empty, a) (Scalar b) = Scalar $ a `addS` b +insertOrAdd (Append x xs, a) (Tensor m) = Tensor $ insertWithTMap (\_ o -> insertOrAdd (xs, a) o) x indTens m + where + indTens = mkTens (xs, a) +insertOrAdd inds ZeroTensor = mkTens inds + +--addition for tensors + +infixl 6 &+ + +-- | Addition of two arbitrary tensors. The only requirement is that the corresponding values satisfy the @'TAdd'@ constraint. +-- In particular this function can also be used for adding tensors that themselves contain tensors as values. + +(&+) :: (TIndex k, TAdd v) => Tensor n k v -> Tensor n k v -> Tensor n k v +(&+) (Scalar a) (Scalar b) = Scalar $ a `addS` b +(&+) (Tensor m1) (Tensor m2) = Tensor $ addTMaps (&+) m1 m2 +(&+) t1 ZeroTensor = t1 +(&+) ZeroTensor t2 = t2 + +-- | Scalar multiplication of an arbitrary @'Tensor'@. Only requirement is that the corresponding values and the scalar type satisfy the +-- @'Prod'@ constraint. + +infix 8 &. + +(&.) :: (TIndex k, Prod s v) => s -> Tensor n k v -> Tensor n k (TProd s v) +(&.) scalar = fmap (prod scalar) + +-- | Negation of an arbitrary @'Tensor'@. The function uses the required group property of the tensor values to map each value of the tensors to its +-- additive inverse. + +negateTens :: (TIndex k, TAdd v) => Tensor n k v -> Tensor n k v +negateTens = fmap negateS + +-- | Subtraction of two arbitrary @'Tensor'@s. The only requirement is that the corresponding values satisfy the @'TAdd'@ constraint. +-- In particular this function can also be used for adding tensors that themselves contain tensors as values. + +infixl 6 &- + +(&-) :: (TIndex k, TAdd v) => Tensor n k v -> Tensor n k v -> Tensor n k v +(&-) (Scalar a) (Scalar b) = Scalar $ subS a b +(&-) (Tensor m1) (Tensor m2) = Tensor $ addTMaps (&-) m1 m2 +(&-) t1 ZeroTensor = t1 +(&-) ZeroTensor t2 = negateS t2 + +-- | Tensor product of two @'Tensor'@s. In the result for each index type the indices of the first @'Tensor'@ are arranged left of those in the second @'Tensor'@ argument. +-- The values of the two @'Tensor'@s must satisfy the @'Prod'@ constraint. + +infixl 7 &* + +(&*) :: (TIndex k, Prod v v') => Tensor n k v -> Tensor m k v' -> TProd (Tensor n k v) (Tensor m k v') +(&*) (Scalar x) (Scalar y) = Scalar $ prod x y +(&*) (Scalar x) t2 = fmap (prod x) t2 +(&*) (Tensor m) t2 = Tensor $ mapTMap (&* t2) m +(&*) t1 ZeroTensor = ZeroTensor +(&*) ZeroTensor t2 = ZeroTensor + +--encode and decode tensors as bytestrings for efficient storing + +-- | Utility function to serialize and compress a @'Tensor'@ into a @'Data.ByteString.Lazy.ByteString'@, making use of the @'Serialize'@ instance. +encodeTensor :: (KnownNat n, Ord k, Serialize k, Serialize v) => Tensor n k v -> BS.ByteString +encodeTensor = compress . encodeLazy + +-- | Utility function to decompress and de-serialize a @'Data.ByteString.Lazy.ByteString'@ into a @'Tensor'@, making use of the @'Serialize'@ instance. +decodeTensor :: (KnownNat n, Ord k, Serialize k, Serialize v) => BS.ByteString -> Tensor n k v +decodeTensor bs = either error id $ decodeLazy $ decompress bs + + +-- | The function computes partial derivatives of spacetime tensors of type @'STTens'@ with @'CFun'@ values. +partial :: Num a => STTens n1 n2 (CFun [AD.Forward a] (AD.Forward a)) -> STTens n1 (n2+1) (CFun [a] a) +partial tens = tens' + where + tList = toListT2 tens + grads = map (\(is, CFun v) -> (is, myGrad [0..3] v)) tList + tList' = concatMap (\((i1, i2), gs) -> map (\(ig, g) -> ((i1, Ind3 ig `Append` i2), CFun g)) gs) grads + tens' = fromListT2 tList' + +-- | The function computes partial derivatives of spacetime tensors of type @'STTens'@ with @'SSymbolic'@ values. +-- +-- > g_ab_p = partialSymbolic ["t", "x", "y", "z"] g_ab + +partialSymbolic :: [String] -> STTens n1 n2 SSymbolic -> STTens n1 (n2+1) SSymbolic +partialSymbolic vars tens = tens' + where + tList = toListT2 tens + grads = map (\(is, SSymbolic v) -> (is, map (\(i, var) -> (i, SSymbolic $ "diff(" ++ v ++ ", " ++ var ++ ")")) $ zip [0..] vars)) tList + tList' = concatMap (\((i1, i2), gs) -> map (\(ig, g) -> ((i1, Ind3 ig `Append` i2), g)) gs) grads + tens' = fromListT2 tList' + +--AbsTensors automatically satisfy TensorAlgebra as we only used type synonyms +--e.g. AbsTensor4 actually looks like Tensor n1 kq1 (Tensor n2 k2 (Tensor n3 k3 (Tensor n4 k4 (Tensor n5 k5 (Tensor n6 k6 (Tensor n7 k7 (Tensor n8 k8 a))))))) + +--fmap takes us 1 level deeper -> we get functions that apply a given function to the various sub tensors + +-- | Synonym for @fmap@. @'mapTo1'@ applies a function to the values of a tensor. +-- +-- > mapTo1 = fmap +mapTo1 :: (v1 -> v2) -> Tensor n1 k v1 -> Tensor n1 k v2 +mapTo1 = fmap + +-- | Applies a function one level deeper than @'mapTo1'@. In other words the leaf values of the @'Tensor'@ at hand must themselves be of type +-- @'Tensor'@, @'mapTo2'@ then applies a function to the values of these leaf @'Tensor'@s. +-- +-- > mapTo2 = fmap . fmap +mapTo2 :: (v1 -> v2) -> Tensor2 n1 n2 k v1 -> Tensor2 n1 n2 k v2 +mapTo2 = fmap . fmap + +-- | Maps a function to the 3rd leaf level. +-- +-- > mapTo3 = fmap . fmap . fmap +mapTo3 :: (v1 -> v2) -> AbsTensor3 n1 n2 n3 k1 k2 v1 -> AbsTensor3 n1 n2 n3 k1 k2 v2 +mapTo3 = fmap . fmap . fmap + +-- | Maps a function to the 4th leaf level. +-- +-- > mapTo4 = fmap . fmap . fmap . fmap +mapTo4 :: (v1 -> v2) -> AbsTensor4 n1 n2 n3 n4 k1 k2 v1 -> AbsTensor4 n1 n2 n3 n4 k1 k2 v2 +mapTo4 = fmap . fmap . fmap . fmap + +-- | Maps a function to the 5th leaf level. +-- +-- > mapTo5 = fmap . fmap . fmap . fmap . fmap +mapTo5 :: (v1 -> v2) -> AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v1 -> AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v2 +mapTo5 = fmap . fmap . fmap . fmap . fmap + +-- | Maps a function to the 6th leaf level. +-- +-- > mapTo6 = fmap . fmap . fmap . fmap . fmap . fmap +mapTo6 :: (v1 -> v2) -> AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v1 -> AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v2 +mapTo6 = fmap . fmap . fmap . fmap . fmap . fmap + +-- | Maps a function to the 7th leaf level. +-- +-- > mapTo7 = fmap . fmap . fmap . fmap . fmap . fmap . fmap +mapTo7 :: (v1 -> v2) -> AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v1 -> AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v2 +mapTo7 = fmap . fmap . fmap . fmap . fmap . fmap . fmap + +-- | Maps a function to the 8th leaf level. +-- +-- > mapTo8 = fmap . fmap . fmap . fmap . fmap . fmap . fmap . fmap +mapTo8 :: (v1 -> v2) -> AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v1 -> AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v2 +mapTo8 = fmap . fmap . fmap . fmap . fmap . fmap . fmap . fmap + +--remove Zero Values at every level of Abstract Tensor + +-- | Applying these functions on a given tensor removes all zero values from it. Even if zero values are not included in a given tensor when it is constructed +-- they might occur during computations. If so they are not automatically removed from the tensor. +removeZeros :: TAdd v => Tensor n k v -> Tensor n k v +removeZeros (Scalar x) = if scaleZero x then ZeroTensor else Scalar x +removeZeros (Tensor m) = let newMap = filterTMap + (\case + ZeroTensor -> False + _ -> True) $ mapTMap removeZeros m in if null newMap then ZeroTensor else Tensor newMap +removeZeros ZeroTensor = ZeroTensor + +-- | > removeZeros1 = removeZeros +removeZeros1 :: (TAdd v, TIndex k) => AbsTensor1 n1 k v -> AbsTensor1 n1 k v +removeZeros1 = removeZeros + +-- | > removeZeros2 = removeZeros . mapTo1 removeZeros +removeZeros2 :: (TAdd v, TIndex k) => AbsTensor2 n1 n2 k v -> AbsTensor2 n1 n2 k v +removeZeros2 = removeZeros . mapTo1 removeZeros + +-- | > removeZeros3 = removeZeros . mapTo1 removeZeros . mapTo2 removeZeros +removeZeros3 :: (TAdd v, TIndex k1, TIndex k2) => AbsTensor3 n1 n2 n3 k1 k2 v -> AbsTensor3 n1 n2 n3 k1 k2 v +removeZeros3 = removeZeros . mapTo1 removeZeros . mapTo2 removeZeros + +-- | > removeZeros4 = removeZeros . mapTo1 removeZeros . mapTo2 removeZeros . mapTo3 removeZeros +removeZeros4 :: (TAdd v, TIndex k1, TIndex k2) => AbsTensor4 n1 n2 n3 n4 k1 k2 v -> AbsTensor4 n1 n2 n3 n4 k1 k2 v +removeZeros4 = removeZeros . mapTo1 removeZeros . mapTo2 removeZeros . mapTo3 removeZeros + +-- | > removeZeros5 = removeZeros . mapTo1 removeZeros . mapTo2 removeZeros . mapTo3 removeZeros . mapTo4 removeZeros +removeZeros5 :: (TAdd v, TIndex k1, TIndex k2, TIndex k3) => AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v +removeZeros5 = removeZeros . mapTo1 removeZeros . mapTo2 removeZeros . mapTo3 removeZeros . mapTo4 removeZeros + +-- | > removeZeros6 = removeZeros . mapTo1 removeZeros . mapTo2 removeZeros . mapTo3 removeZeros . mapTo4 removeZeros . mapTo5 removeZeros +removeZeros6 :: (TAdd v, TIndex k1, TIndex k2, TIndex k3) => AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v +removeZeros6 = removeZeros . mapTo1 removeZeros . mapTo2 removeZeros . mapTo3 removeZeros . mapTo4 removeZeros . mapTo5 removeZeros + +-- | > removeZeros7 = removeZeros . mapTo1 removeZeros . mapTo2 removeZeros . mapTo3 removeZeros . mapTo4 removeZeros . mapTo5 removeZeros . mapTo6 removeZeros +removeZeros7 :: (TAdd v, TIndex k1, TIndex k2, TIndex k3, TIndex k4) => AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v +removeZeros7 = removeZeros . mapTo1 removeZeros . mapTo2 removeZeros . mapTo3 removeZeros . mapTo4 removeZeros . mapTo5 removeZeros . mapTo6 removeZeros + +-- | > removeZeros8 = removeZeros . mapTo1 removeZeros . mapTo2 removeZeros . mapTo3 removeZeros . mapTo4 removeZeros . mapTo5 removeZeros . mapTo6 removeZeros . mapTo7 removeZeros +removeZeros8 :: (TAdd v, TIndex k1, TIndex k2, TIndex k3, TIndex k4) => AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v +removeZeros8 = removeZeros . mapTo1 removeZeros . mapTo2 removeZeros . mapTo3 removeZeros . mapTo4 removeZeros . mapTo5 removeZeros . mapTo6 removeZeros . mapTo7 removeZeros + + +-- | Transpose a @'Tensor'@ in two specified contravariant indices of the first index type indices. +-- The result is simply the tensor with the two indices with position specified by the two @'Int'@ values swapped. +tensorTrans :: (TIndex k, TAdd v) => (Int,Int) -> Tensor n k v -> Tensor n k v +tensorTrans (0, j) t = fromListT l + where + l = map (\(x,y) -> (swapHead j x, y)) $ toListT t +tensorTrans (i, j) (Tensor m) = Tensor $ mapTMap (tensorTrans (i-1, j-1)) m +tensorTrans (i ,j) ZeroTensor = ZeroTensor + +-- | > tensorTrans1 = tensorTrans +tensorTrans1 :: (TIndex k1, TAdd v) => (Int,Int) -> AbsTensor1 n1 k1 v -> AbsTensor1 n1 k1 v +tensorTrans1 = tensorTrans + +-- | > tensorTrans2 mapTo1 . tensorTrans +tensorTrans2 :: (TIndex k1, TAdd v) => (Int,Int) -> AbsTensor2 n1 n2 k1 v -> AbsTensor2 n1 n2 k1 v +tensorTrans2 = mapTo1 . tensorTrans + +-- | > tensorTrans3 = mapTo2 . tensorTrans +tensorTrans3 :: (TIndex k1, TIndex k2, TAdd v) => (Int,Int) -> AbsTensor3 n1 n2 n3 k1 k2 v -> AbsTensor3 n1 n2 n3 k1 k2 v +tensorTrans3 = mapTo2 . tensorTrans + +-- | > tensorTrans4 = mapTo3 tensorTrans +tensorTrans4 :: (TIndex k1, TIndex k2, TAdd v) => (Int,Int) -> AbsTensor4 n1 n2 n3 n4 k1 k2 v -> AbsTensor4 n1 n2 n3 n4 k1 k2 v +tensorTrans4 = mapTo3 . tensorTrans + +-- | > tensorTrans5 = mapTo4 . tensorTrans +tensorTrans5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => (Int,Int) -> AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v +tensorTrans5 = mapTo4 . tensorTrans + +-- | > tensorTrans6 = mapTo5 . tensorTrans +tensorTrans6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => (Int,Int) -> AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v +tensorTrans6 = mapTo5 . tensorTrans + +-- | > tensorTrans7 = mapTo6 . tensorTrans +tensorTrans7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => (Int,Int) -> AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v +tensorTrans7 = mapTo6 . tensorTrans + +-- | > tensorTrans8 = mapTo7 . tensorTrans +tensorTrans8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => (Int,Int) -> AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v +tensorTrans8 = mapTo7 . tensorTrans + + +-- | Swap, i.e. transpose two index blocks in a given @'Tensor'@. The two index blocks must be disjoint. +tensorBlockTrans :: (TIndex k, TAdd v) => ([Int],[Int]) -> Tensor n k v -> Tensor n k v +tensorBlockTrans (l1,l2) t = foldr tensorTrans t indList + where + indList = if null $ intersect l1 l2 then zip l1 l2 else error "at least one index in the list occurs several times" + +-- | > tensorBlockTrans1 = tensorBlockTrans +tensorBlockTrans1 :: (TIndex k1, TAdd v) => ([Int],[Int]) -> AbsTensor1 n1 k1 v -> AbsTensor1 n1 k1 v +tensorBlockTrans1 = tensorBlockTrans + +-- | > tensorBlockTrans2 = mapTo1 tensorBlockTrans +tensorBlockTrans2 :: (TIndex k1, TAdd v) => ([Int],[Int]) -> AbsTensor2 n1 n2 k1 v -> AbsTensor2 n1 n2 k1 v +tensorBlockTrans2 = mapTo1 . tensorBlockTrans + +-- | > tensorBlockTrans3 = mapTo2 . tensorBlockTrans +tensorBlockTrans3 :: (TIndex k1, TIndex k2, TAdd v) => ([Int],[Int]) -> AbsTensor3 n1 n2 n3 k1 k2 v -> AbsTensor3 n1 n2 n3 k1 k2 v +tensorBlockTrans3 = mapTo2 . tensorBlockTrans + +-- | > tensorBlockTrans4 = mapTo3 . tensorBlockTrans +tensorBlockTrans4 :: (TIndex k1, TIndex k2, TAdd v) => ([Int],[Int]) -> AbsTensor4 n1 n2 n3 n4 k1 k2 v -> AbsTensor4 n1 n2 n3 n4 k1 k2 v +tensorBlockTrans4 = mapTo3 . tensorBlockTrans + +-- | > tensorBlockTrans5 = mapTo4 . tensorBlockTrans +tensorBlockTrans5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => ([Int],[Int]) -> AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v +tensorBlockTrans5 = mapTo4 . tensorBlockTrans + +-- | > tensorBlockTrans6 = mapTo5 . tensorBlockTrans +tensorBlockTrans6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => ([Int],[Int]) -> AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v +tensorBlockTrans6 = mapTo5 . tensorBlockTrans + +-- | > tensorBlockTrans7 = mapTo6 . tensorBlockTrans +tensorBlockTrans7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => ([Int],[Int]) -> AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v +tensorBlockTrans7 = mapTo6 . tensorBlockTrans + +-- | > tensorBlockTrans8 = mapTo7 tensorBlockTrans +tensorBlockTrans8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => ([Int],[Int]) -> AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v +tensorBlockTrans8 = mapTo7 . tensorBlockTrans + +--resort an AbsTens + +-- | Completely permute the indices of a given tensor. The new index order is specified by a list @'[Int]'@ that must be of length given by the +-- number of indices the tensor contains. The list then specifies in its i-th element the position on which the i-th index of the tensor +-- shall be sorted. +-- +-- > resortTens [1,2,0,3] (fromListT' [([0,1,2,3],1)] :: Tensor 4 Ind3 Rational) = (fromListT' [([2,0,1,3],1)] :: Tensor 4 Ind3 Rational) +resortTens :: (KnownNat n, TIndex k, TAdd v) => [Int] -> Tensor n k v -> Tensor n k v +resortTens perm t = fromListT $ map (\(x,y) -> (resortInd perm x, y)) $ toListT t + +-- | > resortTens1 = resortTens +resortTens1 :: (KnownNat n1, TIndex k1, TAdd v) => [Int] -> AbsTensor1 n1 k1 v -> AbsTensor1 n1 k1 v +resortTens1 = resortTens + +-- | > resortTens2 = mapTo1 . resortTens +resortTens2 :: (KnownNat n2, TIndex k1, TAdd v) => [Int] -> AbsTensor2 n1 n2 k1 v -> AbsTensor2 n1 n2 k1 v +resortTens2 = mapTo1 . resortTens + +-- | > resortTens3 = mapTo2 . resortTens +resortTens3 :: (KnownNat n3, TIndex k1, TIndex k2, TAdd v) => [Int] -> AbsTensor3 n1 n2 n3 k1 k2 v -> AbsTensor3 n1 n2 n3 k1 k2 v +resortTens3 = mapTo2 . resortTens + +-- | > resortTens4 = mapTo3 . resortTens +resortTens4 :: (KnownNat n4, TIndex k1, TIndex k2, TAdd v) => [Int] -> AbsTensor4 n1 n2 n3 n4 k1 k2 v -> AbsTensor4 n1 n2 n3 n4 k1 k2 v +resortTens4 = mapTo3 . resortTens + +-- | > resortTens5 = mapTo4 . resortTens +resortTens5 :: (KnownNat n5, TIndex k1, TIndex k2, TIndex k3, TAdd v) => [Int] -> AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v +resortTens5 = mapTo4 . resortTens + +-- | > resortTens6 = mapTo5 . resortTens +resortTens6 :: (KnownNat n6, TIndex k1, TIndex k2, TIndex k3, TAdd v) => [Int] -> AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v +resortTens6 = mapTo5 . resortTens + +-- | > resortTens7 = mapTo6 . resortTens +resortTens7 :: (KnownNat n7, TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => [Int] -> AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v +resortTens7 = mapTo6 . resortTens + +-- | > resortTens8 = mapTo7 . resortTens +resortTens8 :: (KnownNat n8, TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => [Int] -> AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v +resortTens8 = mapTo7 . resortTens + +--evaluation of a tensor for a specific index value returning the appropriate sub tensor + +-- | Evaluate a @'Tensor'@ for a specific value of its first contravariant index type returning the corresponding sub @'Tensor'@. +-- The additional functions specified below apply the evaluation function @'evalTens'@ to the deeper @'Tensor'@ levels. +evalTens :: (KnownNat (n+1), TIndex k, TAdd v) => Int -> k -> Tensor (n+1) k v -> Tensor n k v +evalTens ind indVal (Tensor m) + | ind > size -1 || ind < 0 = error "wrong index to evaluate" + | ind == 0 = fromMaybe ZeroTensor $ lookup indVal m + | otherwise = fromMaybe ZeroTensor $ lookup indVal (getTensorMap newTens) + where + size = length $ fst $ head $ toListT' (Tensor m) + l = [1..ind] ++ 0 : [ind+1..size -1] + newTens = resortTens l (Tensor m) + +-- | > evalTens1 = evalTens +evalTens1 :: (KnownNat n1, TIndex k1, TAdd v) => Int -> k1 -> AbsTensor1 (n1+1) k1 v -> AbsTensor1 n1 k1 v +evalTens1 = evalTens + +-- | > evalTens2 ind indVal = mapTo1 (evalTens ind indVal) +evalTens2 :: (KnownNat n2, TIndex k1, TAdd v) => Int -> k1 -> AbsTensor2 n1 (n2+1) k1 v -> AbsTensor2 n1 n2 k1 v +evalTens2 ind indVal = mapTo1 (evalTens ind indVal) + +-- | > evalTens3 ind indVal = mapTo2 (evalTens ind indVal) +evalTens3 :: (KnownNat n3, TIndex k1, TIndex k2, TAdd v) => Int -> k2 -> AbsTensor3 n1 n2 (n3+1) k1 k2 v -> AbsTensor3 n1 n2 n3 k1 k2 v +evalTens3 ind indVal = mapTo2 (evalTens ind indVal) + +-- | > evalTens4 ind indVal = mapTo3 (evalTens ind indVal) +evalTens4 :: (KnownNat n4, TIndex k1, TIndex k2, TAdd v) => Int -> k2 -> AbsTensor4 n1 n2 n3 (n4+1) k1 k2 v -> AbsTensor4 n1 n2 n3 n4 k1 k2 v +evalTens4 ind indVal = mapTo3 (evalTens ind indVal) + +-- | > evalTens5 ind indVal = mapTo4 (evalTens ind indVal) +evalTens5 :: (KnownNat n5, TIndex k1, TIndex k2, TIndex k3, TAdd v) => Int -> k3 -> AbsTensor5 n1 n2 n3 n4 (n5+1) k1 k2 k3 v -> AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v +evalTens5 ind indVal = mapTo4 (evalTens ind indVal) + +-- | > evalTens6 ind indVal = mapTo5 (evalTens ind indVal) +evalTens6 :: (KnownNat n6, TIndex k1, TIndex k2, TIndex k3, TAdd v) => Int -> k3 -> AbsTensor6 n1 n2 n3 n4 n5 (n6+1) k1 k2 k3 v -> AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v +evalTens6 ind indVal = mapTo5 (evalTens ind indVal) + +-- | > evalTens7 ind indVal = mapTo6 (evalTens ind indVal) +evalTens7 :: (KnownNat n7, TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => Int -> k4 -> AbsTensor7 n1 n2 n3 n4 n5 n6 (n7+1) k1 k2 k3 k4 v -> AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v +evalTens7 ind indVal = mapTo6 (evalTens ind indVal) + +-- | > evalTens8 ind indVal = mapTo7 (evalTens ind indVal) +evalTens8 :: (KnownNat n8, TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => Int -> k4 -> AbsTensor8 n1 n2 n3 n4 n5 n6 n7 (n8+1) k1 k2 k3 k4 v -> AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v +evalTens8 ind indVal = mapTo7 (evalTens ind indVal) + +--symmetrizer functions + +-- | Basic symmetrization in a pair of contravariant indices of the 1st index type. Usual factors of \( \frac{1}{2} \) are not include in this function. The resulting function hence no longer satisfies the property of +-- a projection. The following functions apply @'symTens'@ to the index types of the deeper leaf levels, i.e. covariant indices of the 1st index type, contravariant indices of the 2nd index type, etc. +symTens :: (TIndex k, TAdd v) => (Int,Int) -> Tensor n k v -> Tensor n k v +symTens inds t = t &+ tensorTrans inds t + +-- | > symATens1 = symTens +symATens1 :: (TIndex k1, TAdd v) => + (Int,Int) -> + AbsTensor1 n1 k1 v -> + AbsTensor1 n1 k1 v +symATens1 = symTens + +-- | > symATens2 = mapTo1 . symTens +symATens2 :: (TIndex k1, TAdd v) => + (Int,Int) -> + AbsTensor2 n1 n2 k1 v -> + AbsTensor2 n1 n2 k1 v +symATens2 = mapTo1 . symTens + +-- | > symATens3 = mapTo2 . symTens +symATens3 :: (TIndex k1, TIndex k2, TAdd v) => + (Int,Int) -> + AbsTensor3 n1 n2 n3 k1 k2 v -> + AbsTensor3 n1 n2 n3 k1 k2 v +symATens3 = mapTo2 . symTens + +-- | > symATens4 = mapTo3 . symTens +symATens4 :: (TIndex k1, TIndex k2, TAdd v) => + (Int,Int) -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v +symATens4 = mapTo3 . symTens + +-- | > symATens5 = mapTo4 . symTens +symATens5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => + (Int,Int) -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v +symATens5 = mapTo4 . symTens + +-- | > symATens6 = mapTo5 . symTens +symATens6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => + (Int,Int) -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v +symATens6 = mapTo5 . symTens + +-- | > symATens7 = mapTo6 . symTens +symATens7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => + (Int,Int) -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v +symATens7 = mapTo6 . symTens + +-- | > symATens8 = mapTo7 . symTens +symATens8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => + (Int,Int) -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v +symATens8 = mapTo7 . symTens + +--with factor + +-- | Same functionality as @'symTens'@ but including the \( \frac{1}{2} \) in the result and thus defining a projection. +-- The following functions apply @'symTensFac'@ to the index types of the deeper leaf levels, i.e. covariant indices of the 1st index type, contravariant indices of the 2nd index type, etc. +-- +-- > symTensFac inds t = (SField $ 1%2) &. symTens inds t +symTensFac :: (TIndex k, TAdd v, Prod (SField Rational) v) => (Int,Int) -> Tensor n k v -> Tensor n k (TProd (SField Rational) v) +symTensFac inds t = (SField $ 1%2) &. symTens inds t + +-- | > symATensFac1 = symTensFac +symATensFac1 :: (TIndex k1, TAdd v, Prod (SField Rational) v) => + (Int,Int) -> + AbsTensor1 n1 k1 v -> + AbsTensor1 n1 k1 (TProd (SField Rational) v) +symATensFac1 = symTensFac + +-- | > symATensFac2 = mapTo1 . symTensFac +symATensFac2 :: (TIndex k1, TAdd v, Prod (SField Rational) v) => + (Int,Int) -> + AbsTensor2 n1 n2 k1 v -> + AbsTensor2 n1 n2 k1 (TProd (SField Rational) v) +symATensFac2 = mapTo1 . symTensFac + +-- | > symATensFac3 = mapTo2 . symTensFac +symATensFac3 :: (TIndex k1,TIndex k2, TAdd v, Prod (SField Rational) v) => + (Int,Int) -> + AbsTensor3 n1 n2 n3 k1 k2 v -> + AbsTensor3 n1 n2 n3 k1 k2 (TProd (SField Rational) v) +symATensFac3 = mapTo2 . symTensFac + +-- | > symATensFac4 = mapTo3 . symTensFac +symATensFac4 :: (TIndex k1, TIndex k2, TAdd v, Prod (SField Rational) v) => + (Int,Int) -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v -> + AbsTensor4 n1 n2 n3 n4 k1 k2 (TProd (SField Rational) v) +symATensFac4 = mapTo3 . symTensFac + +-- | > symATensFac5 = mapTo4 . symTensFac +symATensFac5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v, Prod (SField Rational) v) => + (Int,Int) -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 (TProd (SField Rational) v) +symATensFac5 = mapTo4 . symTensFac + +-- | > symATensFac6 = mapTo5 . symTensFac +symATensFac6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v, Prod (SField Rational) v) => + (Int,Int) -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 (TProd (SField Rational) v) +symATensFac6 = mapTo5 . symTensFac + +-- | > symATensFac7 = mapTo6 . symTensFac +symATensFac7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v, Prod (SField Rational) v) => + (Int,Int) -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 (TProd (SField Rational) v) +symATensFac7 = mapTo6 . symTensFac + +-- | > symATensFac8 = mapTo7 . symTensFac +symATensFac8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v, Prod (SField Rational) v) => + (Int,Int) -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 (TProd (SField Rational) v) +symATensFac8 = mapTo7 . symTensFac + +--anti-symmetrization + +-- | Basic anti symmetrization in a pair of contravariant indices of the 1st index type. Usual factors of \( \frac{1}{2} \) are not include in this function. The resulting function hence no longer satisfies the property of +-- a projection. The following functions apply @'aSymTens'@ to the index types of the deeper leaf levels, i.e. covariant indices of the 1st index type, contravariant indices of the 2nd index type, etc. +aSymTens :: (TIndex k, TAdd v) => (Int,Int) -> Tensor n k v -> Tensor n k v +aSymTens inds t = t &- tensorTrans inds t + +-- | > aSymATens1 = aSymTens +aSymATens1 :: (TIndex k1, TAdd v) => + (Int,Int) -> + AbsTensor1 n1 k1 v -> + AbsTensor1 n1 k1 v +aSymATens1 = aSymTens + +-- | > aSymATens2 = mapTo1 . aSymTens +aSymATens2 :: (TIndex k1, TAdd v) => + (Int,Int) -> + AbsTensor2 n1 n2 k1 v -> + AbsTensor2 n1 n2 k1 v +aSymATens2 = mapTo1 . aSymTens + +-- | > aSymATens3 = mapTo2 . aSymTens +aSymATens3 :: (TIndex k1, TIndex k2, TAdd v) => + (Int,Int) -> + AbsTensor3 n1 n2 n3 k1 k2 v -> + AbsTensor3 n1 n2 n3 k1 k2 v +aSymATens3 = mapTo2 . aSymTens + +-- | > aSymATens4 = mapTo3 . aSymTens +aSymATens4 :: (TIndex k1, TIndex k2, TAdd v) => + (Int,Int) -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v +aSymATens4 = mapTo3 . aSymTens + +-- | > aSymATens5 = mapTo4 . aSymTens +aSymATens5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => + (Int,Int) -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v +aSymATens5 = mapTo4 . aSymTens + +-- | > aSymATens6 = mapTo5 . aSymTens +aSymATens6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => + (Int,Int) -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v +aSymATens6 = mapTo5 . aSymTens + +-- | > aSymATens7 = mapTo6 . aSymTens +aSymATens7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => + (Int,Int) -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v +aSymATens7 = mapTo6 . aSymTens + +-- | > aSymATens8 = mapTo7 . aSymTens +aSymATens8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => + (Int,Int) -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v +aSymATens8 = mapTo7 . aSymTens + +--with factor + +-- | Same functionality as @'aSymTens'@ but including the \( \frac{1}{2} \) factors in the result and thus defining a projection. +-- The following functions apply @'aSymTensFac'@ to the index types of the deeper leaf levels, i.e. covariant indices of the 1st index type, contravariant indices of the 2nd index type, etc. +-- +-- > aSymTensFac inds t = (SField $ 1%2)&. aSymTens inds t +aSymTensFac :: (TIndex k, TAdd v, Prod (SField Rational) v) => (Int,Int) -> Tensor n k v -> Tensor n k (TProd (SField Rational) v) +aSymTensFac inds t = (SField $ 1%2)&. aSymTens inds t + +-- | > aSymATensFac1 = aSymTensFac +aSymATensFac1 :: (TIndex k1, TAdd v, Prod (SField Rational) v) => + (Int,Int) -> + AbsTensor1 n1 k1 v -> + AbsTensor1 n1 k1 (TProd (SField Rational) v) +aSymATensFac1 = aSymTensFac + +-- | > aSymATensFac2 = mapTo1 . aSymTensFac +aSymATensFac2 :: (TIndex k1, TAdd v, Prod (SField Rational) v) => + (Int,Int) -> + AbsTensor2 n1 n2 k1 v -> + AbsTensor2 n1 n2 k1 (TProd (SField Rational) v) +aSymATensFac2 = mapTo1 . aSymTensFac + +-- | > aSymATensFac3 = mapTo2 . aSymTensFac +aSymATensFac3 :: (TIndex k1, TIndex k2, TAdd v, Prod (SField Rational) v) => + (Int,Int) -> + AbsTensor3 n1 n2 n3 k1 k2 v -> + AbsTensor3 n1 n2 n3 k1 k2 (TProd (SField Rational) v) +aSymATensFac3 = mapTo2 . aSymTensFac + +-- | > aSymATensFac4 = mapTo3 . aSymTensFac +aSymATensFac4 :: (TIndex k1, TIndex k2, TAdd v, Prod (SField Rational) v) => + (Int,Int) -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v -> + AbsTensor4 n1 n2 n3 n4 k1 k2 (TProd (SField Rational) v) +aSymATensFac4 = mapTo3 . aSymTensFac + +-- | > aSymATensFac5 = mapTo4 . aSymTensFac +aSymATensFac5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v, Prod (SField Rational) v) => + (Int,Int) -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 (TProd (SField Rational) v) +aSymATensFac5 = mapTo4 . aSymTensFac + +-- | > aSymATensFac6 = mapTo5 . aSymTensFac +aSymATensFac6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v, Prod (SField Rational) v) => + (Int,Int) -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 (TProd (SField Rational) v) +aSymATensFac6 = mapTo5 . aSymTensFac + +-- | > aSymATensFac7 = mapTo6 . aSymTensFac +aSymATensFac7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v, Prod (SField Rational) v) => + (Int,Int) -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 (TProd (SField Rational) v) +aSymATensFac7 = mapTo6 . aSymTensFac + +-- | > aSymATensFac8 = mapTo7 . aSymTensFac +aSymATensFac8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v, Prod (SField Rational) v) => + (Int,Int) -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 (TProd (SField Rational) v) +aSymATensFac8 = mapTo7 . aSymTensFac + +--block symmetrization + +-- | Symmetrization w.r.t. the exchange of two blocks of contravariant indices of the 1st index type. The index blocks must be disjoint. These function does not include the usual \( \frac{1}{2} \) factors and thus does not +-- define a projection. The following functions apply @'symBlockTens'@ to the index types of the deeper leaf levels, i.e. covariant indices of the 1st index type, contravariant indices of the 2nd index type, etc. +symBlockTens :: (TIndex k, TAdd v) => ([Int],[Int]) -> Tensor n k v -> Tensor n k v +symBlockTens inds t = t &+ tensorBlockTrans inds t + +-- | > symBlockATens1 = symBlockTens +symBlockATens1 :: (TIndex k1, TAdd v) => + ([Int],[Int]) -> + AbsTensor1 n1 k1 v -> + AbsTensor1 n1 k1 v +symBlockATens1 = symBlockTens + +-- | > symBlockATens2 = mapTo1 . symBlockTens +symBlockATens2 :: (TIndex k1, TAdd v) => + ([Int],[Int]) -> + AbsTensor2 n1 n2 k1 v -> + AbsTensor2 n1 n2 k1 v +symBlockATens2 = mapTo1 . symBlockTens + +-- | > symBlockATens3 = mapTo2 . symBlockTens +symBlockATens3 :: (TIndex k1, TIndex k2, TAdd v) => + ([Int],[Int]) -> + AbsTensor3 n1 n2 n3 k1 k2 v -> + AbsTensor3 n1 n2 n3 k1 k2 v +symBlockATens3 = mapTo2 . symBlockTens + +-- | > symBlockATens4 = mapTo3 . symBlockTens +symBlockATens4 :: (TIndex k1, TIndex k2, TAdd v) => + ([Int],[Int]) -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v +symBlockATens4 = mapTo3 . symBlockTens + +-- | > symBlockATens5 = mapTo4 . symBlockTens +symBlockATens5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => + ([Int],[Int]) -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v +symBlockATens5 = mapTo4 . symBlockTens + +-- | > symBlockATens6 = mapTo5 . symBlockTens +symBlockATens6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => + ([Int],[Int]) -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v +symBlockATens6 = mapTo5 . symBlockTens + +-- | > symBlockATens7 = mapTo6 . symBlockTens +symBlockATens7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => + ([Int],[Int]) -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v +symBlockATens7 = mapTo6 . symBlockTens + +-- | > symBlockATens8 = mapTo7 . symBlockTens +symBlockATens8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => + ([Int],[Int]) -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v +symBlockATens8 = mapTo7 . symBlockTens + +--with factor + +-- | Same functionality as @'symBlockTens'@ but including the usual factors of \( \frac{1}{2} \) in the result and thus defining a projection. +-- The following functions apply @'symBlockTensFac'@ to the index types of the deeper leaf levels, i.e. covariant indices of the 1st index type, contravariant indices of the 2nd index type, etc. +-- +-- > symBlockTensFac inds t = (SField $ 1%2)&. symBlockTens inds t +symBlockTensFac :: (TIndex k, TAdd v, Prod (SField Rational) v) => ([Int],[Int]) -> Tensor n k v -> Tensor n k (TProd (SField Rational) v) +symBlockTensFac inds t = (SField $ 1%2)&. symBlockTens inds t + +-- | > symBlockATensFac1 = symBlockTensFac +symBlockATensFac1 :: (TIndex k1, TAdd v, Prod (SField Rational) v) => + ([Int],[Int]) -> + AbsTensor1 n1 k1 v -> + AbsTensor1 n1 k1 (TProd (SField Rational) v) +symBlockATensFac1 = symBlockTensFac + +-- | > symBlockATensFac2 = mapTo1 . symBlockTensFac +symBlockATensFac2 :: (TIndex k1, TAdd v, Prod (SField Rational) v) => + ([Int],[Int]) -> + AbsTensor2 n1 n2 k1 v -> + AbsTensor2 n1 n2 k1 (TProd (SField Rational) v) +symBlockATensFac2 = mapTo1 . symBlockTensFac + +-- | > symBlockATensFac3 = mapTo2 . symBlockTensFac +symBlockATensFac3 :: (TIndex k1, TIndex k2, TAdd v, Prod (SField Rational) v) => + ([Int],[Int]) -> + AbsTensor3 n1 n2 n3 k1 k2 v -> + AbsTensor3 n1 n2 n3 k1 k2 (TProd (SField Rational) v) +symBlockATensFac3 = mapTo2 . symBlockTensFac + +-- | > symBlockATensFac4 = mapTo3 . symBlockTensFac +symBlockATensFac4 :: (TIndex k1, TIndex k2, TAdd v, Prod (SField Rational) v) => + ([Int],[Int]) -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v -> + AbsTensor4 n1 n2 n3 n4 k1 k2 (TProd (SField Rational) v) +symBlockATensFac4 = mapTo3 . symBlockTensFac + +-- | > symBlockATensFac5 = mapTo4 . symBlockTensFac +symBlockATensFac5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v, Prod (SField Rational) v) => + ([Int],[Int]) -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 (TProd (SField Rational) v) +symBlockATensFac5 = mapTo4 . symBlockTensFac + +-- | > symBlockATensFac6 = mapTo5 . symBlockTensFac +symBlockATensFac6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v, Prod (SField Rational) v) => + ([Int],[Int]) -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 (TProd (SField Rational) v) +symBlockATensFac6 = mapTo5 . symBlockTensFac + +-- | > symBlockATensFac7 = mapTo6 . symBlockTensFac +symBlockATensFac7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v, Prod (SField Rational) v) => + ([Int],[Int]) -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 (TProd (SField Rational) v) +symBlockATensFac7 = mapTo6 . symBlockTensFac + +-- | > symBlockATensFac8 = mapTo7 . symBlockTensFac +symBlockATensFac8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v, Prod (SField Rational) v) => + ([Int],[Int]) -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 (TProd (SField Rational) v) +symBlockATensFac8 = mapTo7 . symBlockTensFac + +--anti symmetrization + +-- | Anti symmetrization w.r.t. the exchange of two blocks of contravariant indices of the 1st index type. The index blocks must be disjoint. These function does not include the usual \( \frac{1}{2} \) factors and thus does not +-- define a projection. The following functions apply @'aSymBlockTens'@ to the index types of the deeper leaf levels, i.e. covariant indices of the 1st index type, contravariant indices of the 2nd index type, etc. +aSymBlockTens :: (TIndex k, TAdd v) => ([Int],[Int]) -> Tensor n k v -> Tensor n k v +aSymBlockTens inds t = t &- tensorBlockTrans inds t + +-- | > aSymBlockATens1 = aSymBlockTens +aSymBlockATens1 :: (TIndex k1, TAdd v) => + ([Int],[Int]) -> + AbsTensor1 n1 k1 v -> + AbsTensor1 n1 k1 v +aSymBlockATens1 = aSymBlockTens + +-- | > aSymBlockATens2 = mapTo1 . aSymBlockTens +aSymBlockATens2 :: (TIndex k1, TAdd v) => + ([Int],[Int]) -> + AbsTensor2 n1 n2 k1 v -> + AbsTensor2 n1 n2 k1 v +aSymBlockATens2 = mapTo1 . aSymBlockTens + +-- | > aSymBlockATens3 = mapTo2 . aSymBlockTens +aSymBlockATens3 :: (TIndex k1, TIndex k2, TAdd v) => + ([Int],[Int]) -> + AbsTensor3 n1 n2 n3 k1 k2 v -> + AbsTensor3 n1 n2 n3 k1 k2 v +aSymBlockATens3 = mapTo2 . aSymBlockTens + +-- | > aSymBlockATens4 = mapTo3 . aSymBlockTens +aSymBlockATens4 :: (TIndex k1, TIndex k2, TAdd v) => + ([Int],[Int]) -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v +aSymBlockATens4 = mapTo3 . aSymBlockTens + +-- | > aSymBlockATens5 = mapTo4 . aSymBlockTens +aSymBlockATens5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => + ([Int],[Int]) -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v +aSymBlockATens5 = mapTo4 . aSymBlockTens + +-- | > aSymBlockATens6 = mapTo5 . aSymBlockTens +aSymBlockATens6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => + ([Int],[Int]) -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v +aSymBlockATens6 = mapTo5 . aSymBlockTens + +-- | > aSymBlockATens7 = mapTo6 . aSymBlockTens +aSymBlockATens7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => + ([Int],[Int]) -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v +aSymBlockATens7 = mapTo6 . aSymBlockTens + +-- | > aSymBlockATens8 = mapTo7 . aSymBlockTens +aSymBlockATens8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => + ([Int],[Int]) -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v +aSymBlockATens8 = mapTo7 . aSymBlockTens + +--with factor + +-- | Same functionality as @'aSymBlockTens'@ but including the usual factors of \( \frac{1}{2} \) in the result and thus defining a projection. +-- The following functions apply @'aSymBlockTensFac'@ to the index types of the deeper leaf levels, i.e. covariant indices of the 1st index type, contravariant indices of the 2nd index type, etc. +-- +-- > aSymBlockTensFac inds t = (SField $ 1%2)&. aSymBlockTens inds t +aSymBlockTensFac :: (TIndex k, TAdd v, Prod (SField Rational) v) => ([Int],[Int]) -> Tensor n k v -> Tensor n k (TProd (SField Rational) v) +aSymBlockTensFac inds t = (SField $ 1%2)&. aSymBlockTens inds t + +-- | > aSymBlockATensFac1 = aSymBlockTensFac +aSymBlockATensFac1 :: (TIndex k1, TAdd v, Prod (SField Rational) v) => + ([Int],[Int]) -> + AbsTensor1 n1 k1 v -> + AbsTensor1 n1 k1 (TProd (SField Rational) v) +aSymBlockATensFac1 = aSymBlockTensFac + +-- | > aSymBlockATensFac2 = mapTo1 . aSymBlockTensFac +aSymBlockATensFac2 :: (TIndex k1, TAdd v, Prod (SField Rational) v) => + ([Int],[Int]) -> + AbsTensor2 n1 n2 k1 v -> + AbsTensor2 n1 n2 k1 (TProd (SField Rational) v) +aSymBlockATensFac2 = mapTo1 . aSymBlockTensFac + +-- | > aSymBlockATensFac3 = mapTo2 . aSymBlockTensFac +aSymBlockATensFac3 :: (TIndex k1, TIndex k2, TAdd v, Prod (SField Rational) v) => + ([Int],[Int]) -> + AbsTensor3 n1 n2 n3 k1 k2 v -> + AbsTensor3 n1 n2 n3 k1 k2 (TProd (SField Rational) v) +aSymBlockATensFac3 = mapTo2 . aSymBlockTensFac + +-- | > aSymBlockATensFac4 = mapTo3 . aSymBlockTensFac +aSymBlockATensFac4 :: (TIndex k1, TIndex k2, TAdd v, Prod (SField Rational) v) => + ([Int],[Int]) -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v -> + AbsTensor4 n1 n2 n3 n4 k1 k2 (TProd (SField Rational) v) +aSymBlockATensFac4 = mapTo3 . aSymBlockTensFac + +-- | > aSymBlockATensFac5 = mapTo4 . aSymBlockTensFac +aSymBlockATensFac5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v, Prod (SField Rational) v) => + ([Int],[Int]) -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 (TProd (SField Rational) v) +aSymBlockATensFac5 = mapTo4 . aSymBlockTensFac + +-- | > aSymBlockATensFac6 = mapTo5 . aSymBlockTensFac +aSymBlockATensFac6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v, Prod (SField Rational) v) => + ([Int],[Int]) -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 (TProd (SField Rational) v) +aSymBlockATensFac6 = mapTo5 . aSymBlockTensFac + +-- | > aSymBlockATensFac7 = mapTo6 . aSymBlockTensFac +aSymBlockATensFac7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v, Prod (SField Rational) v) => + ([Int],[Int]) -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 (TProd (SField Rational) v) +aSymBlockATensFac7 = mapTo6 . aSymBlockTensFac + +-- | > aSymBlockATensFac8 = mapTo7 . aSymBlockTensFac +aSymBlockATensFac8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v, Prod (SField Rational) v) => + ([Int],[Int]) -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 (TProd (SField Rational) v) +aSymBlockATensFac8 = mapTo7 . aSymBlockTensFac + +--helper function for cyclic symmetrization: convert all permutations of a given list of indices into an equivalent lists of lists of Swaps of 2 indices + +getAllSwaps :: [Int] -> [[(Int,Int)]] +getAllSwaps [x,y] = [[(x,y)]] +getAllSwaps (x:xs) = lNew ++ l' ++ ((:) <$> l <*> l') + where + l = zip (repeat x) xs + lNew = map pure l + l' = getAllSwaps xs + +getAllBlockSwaps :: [[Int]] -> [[([Int],[Int])]] +getAllBlockSwaps [x,y] = [[(x,y)]] +getAllBlockSwaps (x:xs) = lNew ++ l' ++ ((:) <$> l <*> l') + where + l = zip (repeat x) xs + lNew = map pure l + l' = getAllBlockSwaps xs + +factorial :: Int -> Int +factorial 1 = 1 +factorial n = n * factorial (n-1) + +--cyclic symmetrization + +-- | Cyclic symmetrization of the specified subset of contravariant @'Tensor'@ indices of the first index type. The function does not include +-- usual factors of \( \frac{1}{i!} \) where \( i \) is the number of indices w.r.t. which the symmetrization is performed. +-- Further functions that are displayed below apply @'cyclicSymTens'@ to the various deeper @'Tensor'@ levels. +cyclicSymTens :: (TIndex k, TAdd v) => [Int] -> Tensor n k v -> Tensor n k v +cyclicSymTens inds t = newTens + where + swapList = getAllSwaps inds + tensList = map (foldr tensorTrans t) swapList + newTens = foldr (&+) t tensList + +-- | > cyclicSymATens1 = cyclicSymTens +cyclicSymATens1 :: (TIndex k1, TAdd v) => + [Int] -> + AbsTensor1 n1 k1 v -> + AbsTensor1 n1 k1 v +cyclicSymATens1 = cyclicSymTens + +-- | > cyclicSymATens2 = mapTo1 . cyclicSymTens +cyclicSymATens2 :: (TIndex k1, TAdd v) => + [Int] -> + AbsTensor2 n1 n2 k1 v -> + AbsTensor2 n1 n2 k1 v +cyclicSymATens2 = mapTo1 . cyclicSymTens + +-- | > cyclicSymATens3 = mapTo2 . cyclicSymTens +cyclicSymATens3 :: (TIndex k1, TIndex k2, TAdd v) => + [Int] -> + AbsTensor3 n1 n2 n3 k1 k2 v -> + AbsTensor3 n1 n2 n3 k1 k2 v +cyclicSymATens3 = mapTo2 . cyclicSymTens + +-- | > cyclicSymATens4 = mapTo3 . cyclicSymTens +cyclicSymATens4 :: (TIndex k1, TIndex k2, TAdd v) => + [Int] -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v +cyclicSymATens4 = mapTo3 . cyclicSymTens + +-- | > cyclicSymATens5 = mapTo4 . cyclicSymTens +cyclicSymATens5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => + [Int] -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v +cyclicSymATens5 = mapTo4 . cyclicSymTens + +-- | > cyclicSymATens6 = mapTo5 . cyclicSymTens +cyclicSymATens6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => + [Int] -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v +cyclicSymATens6 = mapTo5 . cyclicSymTens + +-- | > cyclicSymATens7 = mapTo6 . cyclicSymTens +cyclicSymATens7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => + [Int] -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v +cyclicSymATens7 = mapTo6 . cyclicSymTens + +-- | > cyclicSymATens8 = mapTo7 . cyclicSymTens +cyclicSymATens8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => + [Int] -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v +cyclicSymATens8 = mapTo7 . cyclicSymTens + +--with factor + +-- | This function provides the same functionality as @'cyclicSymTens'@ with the only difference that it includes the \(\frac{1}{i!}\) factors. +-- The functions that are further provided apply @'cyclicSymTensFac'@ to deeper @'Tensor'@ levels. +-- +-- > cyclicSymTensFac inds t = fac &. cyclicSymTens inds t +cyclicSymTensFac :: (TIndex k, TAdd v, Prod (SField Rational) v) => [Int] -> Tensor n k v -> Tensor n k (TProd (SField Rational) v) +cyclicSymTensFac inds t = fac &. cyclicSymTens inds t + where + fac = SField $ 1 % fromIntegral (factorial $ length inds) + +-- | > cyclicSymATensFac1 = cyclicSymTensFac +cyclicSymATensFac1 :: (TIndex k1, TAdd v, Prod (SField Rational) v) => + [Int] -> + AbsTensor1 n1 k1 v -> + AbsTensor1 n1 k1 (TProd (SField Rational) v) +cyclicSymATensFac1 = cyclicSymTensFac + +-- | > cyclicSymATensFac2 = mapTo1 . cyclicSymTensFac +cyclicSymATensFac2 :: (TIndex k1, TAdd v, Prod (SField Rational) v) => + [Int] -> + AbsTensor2 n1 n2 k1 v -> + AbsTensor2 n1 n2 k1 (TProd (SField Rational) v) +cyclicSymATensFac2 = mapTo1 . cyclicSymTensFac + +-- | > cyclicSymATensFac3 = mapTo2 . cyclicSymTensFac +cyclicSymATensFac3 :: (TIndex k1, TIndex k2, TAdd v, Prod (SField Rational) v) => + [Int] -> + AbsTensor3 n1 n2 n3 k1 k2 v -> + AbsTensor3 n1 n2 n3 k1 k2 (TProd (SField Rational) v) +cyclicSymATensFac3 = mapTo2 . cyclicSymTensFac + +-- | > cyclicSymATensFac4 = mapTo3 . cyclicSymTensFac +cyclicSymATensFac4 :: (TIndex k1, TIndex k2, TAdd v, Prod (SField Rational) v) => + [Int] -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v -> + AbsTensor4 n1 n2 n3 n4 k1 k2 (TProd (SField Rational) v) +cyclicSymATensFac4 = mapTo3 . cyclicSymTensFac + +-- | > cyclicSymATensFac5 = mapTo4 . cyclicSymTensFac +cyclicSymATensFac5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v, Prod (SField Rational) v) => + [Int] -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 (TProd (SField Rational) v) +cyclicSymATensFac5 = mapTo4 . cyclicSymTensFac + +-- | > cyclicSymATensFac6 = mapTo5 . cyclicSymTensFac +cyclicSymATensFac6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v, Prod (SField Rational) v) => + [Int] -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 (TProd (SField Rational) v) +cyclicSymATensFac6 = mapTo5 . cyclicSymTensFac + +-- | > cyclicSymATensFac7 = mapTo6 . cyclicSymTensFac +cyclicSymATensFac7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v, Prod (SField Rational) v) => + [Int] -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 (TProd (SField Rational) v) +cyclicSymATensFac7 = mapTo6 . cyclicSymTensFac + +-- | > cyclicSymATensFac8 = mapTo7 . cyclicSymTensFac +cyclicSymATensFac8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v, Prod (SField Rational) v) => + [Int] -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 (TProd (SField Rational) v) +cyclicSymATensFac8 = mapTo7 . cyclicSymTensFac + +--cyclic anti symmetrization + +-- | Cyclic anti symmetrization of the specified subset of contravariant @'Tensor'@ indices of the first index type. The function does not include +-- usual factors of \( \frac{1}{i!} \) where \( i \) is the number of indices w.r.t. which the symmetrization is performed. +-- Further functions that are displayed below apply @'cyclicASymTens'@ to the various deeper @'Tensor'@ levels. +cyclicASymTens :: (TIndex k, TAdd v) => [Int] -> Tensor n k v -> Tensor n k v +cyclicASymTens inds t = newTens + where + swapList = getAllSwaps inds + signList = map (\x -> (-1) ^ length x) swapList + tensList' = map (foldr tensorTrans t) swapList + tensList = zipWith (\s v -> if s == -1 then negateS v else v) signList tensList' + newTens = foldr (&+) t tensList + +-- | > cyclicASymATens1 = cyclicASymTens +cyclicASymATens1 :: (TIndex k1, TAdd v) => + [Int] -> + AbsTensor1 n1 k1 v -> + AbsTensor1 n1 k1 v +cyclicASymATens1 = cyclicASymTens + +-- | > cyclicASymATens2 = mapTo1 . cyclicASymTens +cyclicASymATens2 :: (TIndex k1, TAdd v) => + [Int] -> + AbsTensor2 n1 n2 k1 v -> + AbsTensor2 n1 n2 k1 v +cyclicASymATens2 = mapTo1 . cyclicASymTens + +-- | > cyclicASymATens3 = mapTo2 . cyclicASymTens +cyclicASymATens3 :: (TIndex k1, TIndex k2, TAdd v) => + [Int] -> + AbsTensor3 n1 n2 n3 k1 k2 v -> + AbsTensor3 n1 n2 n3 k1 k2 v +cyclicASymATens3 = mapTo2 . cyclicASymTens + +-- | > cyclicASymATens4 = mapTo3 . cyclicASymTens +cyclicASymATens4 :: (TIndex k1, TIndex k2, TAdd v) => + [Int] -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v +cyclicASymATens4 = mapTo3 . cyclicASymTens + +-- | > cyclicASymATens5 = mapTo4 . cyclicASymTens +cyclicASymATens5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => + [Int] -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v +cyclicASymATens5 = mapTo4 . cyclicASymTens + +-- | > cyclicASymATens6 = mapTo5 . cyclicASymTens +cyclicASymATens6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => + [Int] -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v +cyclicASymATens6 = mapTo5 . cyclicASymTens + +-- | > cyclicASymATens7 = mapTo6 . cyclicASymTens +cyclicASymATens7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => + [Int] -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v +cyclicASymATens7 = mapTo6 . cyclicASymTens + +-- | > cyclicASymATens8 = mapTo7 . cyclicASymTens +cyclicASymATens8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => + [Int] -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v +cyclicASymATens8 = mapTo7 . cyclicASymTens + +--with factor + +-- | This function provides the same functionality as @'cyclicASymTens'@ with the only difference that it includes the \(\frac{1}{i!}\) factors. +-- The functions that are further provided apply @'cyclicASymTensFac'@ to deeper @'Tensor'@ levels. +-- +-- > cyclicASymTensFac inds t = fac &. cyclicASymTens inds t +cyclicASymTensFac :: (TIndex k, TAdd v, Prod (SField Rational) v) => [Int] -> Tensor n k v -> Tensor n k (TProd (SField Rational) v) +cyclicASymTensFac inds t = fac &. cyclicASymTens inds t + where + fac = SField $ 1 % fromIntegral (factorial $ length inds) + +-- | > cyclicASymATensFac1 = cyclicASymTensFac +cyclicASymATensFac1 :: (TIndex k1, TAdd v, Prod (SField Rational) v) => + [Int] -> + AbsTensor1 n1 k1 v -> + AbsTensor1 n1 k1 (TProd (SField Rational) v) +cyclicASymATensFac1 = cyclicASymTensFac + +-- | > cyclicASymATensFac2 = mapTo1 . cyclicASymTensFac +cyclicASymATensFac2 :: (TIndex k1, TAdd v, Prod (SField Rational) v) => + [Int] -> + AbsTensor2 n1 n2 k1 v -> + AbsTensor2 n1 n2 k1 (TProd (SField Rational) v) +cyclicASymATensFac2 = mapTo1 . cyclicASymTensFac + +-- | > cyclicASymATensFac3 = mapTo2 . cyclicASymTensFac +cyclicASymATensFac3 :: (TIndex k1, TIndex k2, TAdd v, Prod (SField Rational) v) => + [Int] -> + AbsTensor3 n1 n2 n3 k1 k2 v -> + AbsTensor3 n1 n2 n3 k1 k2 (TProd (SField Rational) v) +cyclicASymATensFac3 = mapTo2 . cyclicASymTensFac + +-- | > cyclicASymATensFac4 = mapTo3 . cyclicASymTensFac +cyclicASymATensFac4 :: (TIndex k1, TIndex k2, TAdd v, Prod (SField Rational) v) => + [Int] -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v -> + AbsTensor4 n1 n2 n3 n4 k1 k2 (TProd (SField Rational) v) +cyclicASymATensFac4 = mapTo3 . cyclicASymTensFac + +-- | > cyclicASymATensFac5 = mapTo4 . cyclicASymTensFac +cyclicASymATensFac5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v, Prod (SField Rational) v) => + [Int] -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 (TProd (SField Rational) v) +cyclicASymATensFac5 = mapTo4 . cyclicASymTensFac + +-- | > cyclicASymATensFac6 = mapTo5 . cyclicASymTensFac +cyclicASymATensFac6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v, Prod (SField Rational) v) => + [Int] -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 (TProd (SField Rational) v) +cyclicASymATensFac6 = mapTo5 . cyclicASymTensFac + +-- | > cyclicASymATensFac7 = mapTo6 . cyclicASymTensFac +cyclicASymATensFac7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v, Prod (SField Rational) v) => + [Int] -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 (TProd (SField Rational) v) +cyclicASymATensFac7 = mapTo6 . cyclicASymTensFac + +-- | > cyclicASymATensFac8 = mapTo7 . cyclicASymTensFac +cyclicASymATensFac8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v, Prod (SField Rational) v) => + [Int] -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 (TProd (SField Rational) v) +cyclicASymATensFac8 = mapTo7 . cyclicASymTensFac + +--cyclic block symmetrization + +-- | Cyclic block symmetrization, i.e. symmetrization w.r.t. any permutation of the specified index blocks of contravariant indices of the first index type. +-- Usual factors of \( \frac{1}{i!} \) where \( i \) is the number of index blocks w.r.t. which the symmetrization is performed are not included. +-- The functions that are displayed further below apply @'cyclicBlockSymTens'@ to the various deeper @'Tensor'@ levels. +cyclicBlockSymTens :: (TIndex k, TAdd v) => [[Int]] -> Tensor n k v -> Tensor n k v +cyclicBlockSymTens inds t = newTens + where + swapList = getAllBlockSwaps inds + tensList = map (foldr tensorBlockTrans t) swapList + newTens = foldr (&+) t tensList + +-- | > cyclicBlockSymATens1 = cyclicBlockSymTens +cyclicBlockSymATens1 :: (TIndex k1, TAdd v) => + [[Int]] -> + AbsTensor1 n1 k1 v -> + AbsTensor1 n1 k1 v +cyclicBlockSymATens1 = cyclicBlockSymTens + +-- | > cyclicBlockSymATens2 = mapTo1 . cyclicBlockSymTens +cyclicBlockSymATens2 :: (TIndex k1, TAdd v) => + [[Int]] -> + AbsTensor2 n1 n2 k1 v -> + AbsTensor2 n1 n2 k1 v +cyclicBlockSymATens2 = mapTo1 . cyclicBlockSymTens + +-- | > cyclicBlockSymATens3 = mapTo2 . cyclicBlockSymTens +cyclicBlockSymATens3 :: (TIndex k1, TIndex k2, TAdd v) => + [[Int]] -> + AbsTensor3 n1 n2 n3 k1 k2 v -> + AbsTensor3 n1 n2 n3 k1 k2 v +cyclicBlockSymATens3 = mapTo2 . cyclicBlockSymTens + +-- | > cyclicBlockSymATens4 = mapTo3 . cyclicBlockSymTens +cyclicBlockSymATens4 :: (TIndex k1, TIndex k2, TAdd v) => + [[Int]] -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v +cyclicBlockSymATens4 = mapTo3 . cyclicBlockSymTens + +-- | > cyclicBlockSymATens5 = mapTo4 . cyclicBlockSymTens +cyclicBlockSymATens5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => + [[Int]] -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v +cyclicBlockSymATens5 = mapTo4 . cyclicBlockSymTens + +-- | > cyclicBlockSymATens6 = mapTo5 . cyclicBlockSymTens +cyclicBlockSymATens6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => + [[Int]] -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v +cyclicBlockSymATens6 = mapTo5 . cyclicBlockSymTens + +-- | > cyclicBlockSymATens7 = mapTo6 . cyclicBlockSymTens +cyclicBlockSymATens7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => + [[Int]] -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v +cyclicBlockSymATens7 = mapTo6 . cyclicBlockSymTens + +-- | > cyclicBlockSymATens8 = mapTo7 . cyclicBlockSymTens +cyclicBlockSymATens8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => + [[Int]] -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v +cyclicBlockSymATens8 = mapTo7 . cyclicBlockSymTens + +--with factor + +-- | This function provides the same functionality as @'cyclicBlockSymTens'@ with the only difference that it includes the \(\frac{1}{i!}\) factors. +-- The functions that are further provided apply @'cyclicASymTensFac'@ to deeper @'Tensor'@ levels. +-- +-- > cyclicBlockSymTensFac inds t = fac &. cyclicBlockSymTens inds t +cyclicBlockSymTensFac :: (TIndex k, TAdd v, Prod (SField Rational) v) => [[Int]] -> Tensor n k v -> Tensor n k (TProd (SField Rational) v) +cyclicBlockSymTensFac inds t = fac &. cyclicBlockSymTens inds t + where + fac = SField $ 1 % fromIntegral (factorial $ length inds) + +-- | > cyclicBlockSymATensFac1 = cyclicBlockSymTensFac +cyclicBlockSymATensFac1 :: (TIndex k1, TAdd v, Prod (SField Rational) v) => + [[Int]] -> + AbsTensor1 n1 k1 v -> + AbsTensor1 n1 k1 (TProd (SField Rational) v) +cyclicBlockSymATensFac1 = cyclicBlockSymTensFac + +-- | > cyclicBlockSymATensFac2 = mapTo1 . cyclicBlockSymTensFac +cyclicBlockSymATensFac2 :: (TIndex k1, TAdd v, Prod (SField Rational) v) => + [[Int]] -> + AbsTensor2 n1 n2 k1 v -> + AbsTensor2 n1 n2 k1 (TProd (SField Rational) v) +cyclicBlockSymATensFac2 = mapTo1 . cyclicBlockSymTensFac + +-- | > cyclicBlockSymATensFac3 = mapTo2 . cyclicBlockSymTensFac +cyclicBlockSymATensFac3 :: (TIndex k1, TIndex k2, TAdd v, Prod (SField Rational) v) => + [[Int]] -> + AbsTensor3 n1 n2 n3 k1 k2 v -> + AbsTensor3 n1 n2 n3 k1 k2 (TProd (SField Rational) v) +cyclicBlockSymATensFac3 = mapTo2 . cyclicBlockSymTensFac + +-- | > cyclicBlockSymATensFac4 = mapTo3 . cyclicBlockSymTensFac +cyclicBlockSymATensFac4 :: (TIndex k1, TIndex k2, TAdd v, Prod (SField Rational) v) => + [[Int]] -> + AbsTensor4 n1 n2 n3 n4 k1 k2 v -> + AbsTensor4 n1 n2 n3 n4 k1 k2 (TProd (SField Rational) v) +cyclicBlockSymATensFac4 = mapTo3 . cyclicBlockSymTensFac + +-- | > cyclicBlockSymATensFac5 = mapTo4 . cyclicBlockSymTensFac +cyclicBlockSymATensFac5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v, Prod (SField Rational) v) => + [[Int]] -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> + AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 (TProd (SField Rational) v) +cyclicBlockSymATensFac5 = mapTo4 . cyclicBlockSymTensFac + +-- | > cyclicBlockSymATensFac6 = mapTo5 . cyclicBlockSymTensFac +cyclicBlockSymATensFac6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v, Prod (SField Rational) v) => + [[Int]] -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> + AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 (TProd (SField Rational) v) +cyclicBlockSymATensFac6 = mapTo5 . cyclicBlockSymTensFac + +-- | > cyclicBlockSymATensFac7 = mapTo6 . cyclicBlockSymTensFac +cyclicBlockSymATensFac7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v, Prod (SField Rational) v) => + [[Int]] -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> + AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 (TProd (SField Rational) v) +cyclicBlockSymATensFac7 = mapTo6 . cyclicBlockSymTensFac + +-- | > cyclicBlockSymATensFac8 = mapTo7 . cyclicBlockSymTensFac +cyclicBlockSymATensFac8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v, Prod (SField Rational) v) => + [[Int]] -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> + AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 (TProd (SField Rational) v) +cyclicBlockSymATensFac8 = mapTo7 . cyclicBlockSymTensFac + +--contraction for general tensors + +-- | This functions compute the contraction of a @'Tensor'@ in two of its indices of the same index type, i.e. the function sets the two indices equal and sums over their whole index range. +tensorContr :: (TIndex k, TAdd v) => (Int,Int) -> Tensor2 n1 n2 k v -> Tensor2 (n1-1) (n2-1) k v +tensorContr (0,j) t = fromListT tensList + where + l = map (\(x,y) -> (x, toListT y)) $ toListT t + l2 = map (\(x,y) -> (tailInd x,mapMaybe (removeContractionInd j (headInd x)) y)) l + l3 = filter (\(_,y) -> not (null y)) l2 + tensList = map (\(x,y) -> (x, fromListT y)) l3 +tensorContr (i,j) (Tensor m) = Tensor $ mapTMap (tensorContr (i-1,j)) m +tensorContr inds ZeroTensor = ZeroTensor +tensorContr inds (Scalar s) = error "cannot contract scalar!" + +-- | @'contrATens1'@ is a synonym for @'tensorContr'@. It applies the contraction to the 1st index type of a tensor. +-- +-- > contrATens1 = tensorContr +contrATens1 :: (TIndex k1, TAdd v) => (Int,Int) -> AbsTensor2 (n1+1) (n2+1) k1 v -> AbsTensor2 n1 n2 k1 v +contrATens1 = tensorContr + +-- | @'contrATens2'@ applies the contraction to the 2nd index type of a tensor. +-- +-- > contrATens2 = mapTo2 . tensorContr +contrATens2 :: (TIndex k1, TIndex k2, TAdd v) => (Int,Int) -> AbsTensor4 n1 n2 (n3+1) (n4+1) k1 k2 v -> AbsTensor4 n1 n2 n3 n4 k1 k2 v +contrATens2 = mapTo2 . tensorContr + +-- | @'contrATens3'@ applies the contraction to the 3rd index type of a tensor. +-- +-- > contrATens3 = mapTo4 . tensorContr +contrATens3 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => (Int,Int) -> AbsTensor6 n1 n2 n3 n4 (n5+1) (n6+1) k1 k2 k3 v -> AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v +contrATens3 = mapTo4 . tensorContr + +-- | @'contrATens4'@ applies the contraction to the 4th index type of a tensor. +-- +-- > contrATens4 = mapTo6 . tensorContr +contrATens4 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => (Int,Int) -> AbsTensor8 n1 n2 n3 n4 n5 n6 (n7+1) (n8+1) k1 k2 k3 k4 v -> AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v +contrATens4 = mapTo6 . tensorContr + +--construct tensors from lists of (indices,value) pairs + +type IndTuple1 n1 k1 = IndList n1 k1 + +type IndTuple2 n1 n2 k1 = (IndList n1 k1, IndList n2 k1) + +type IndTuple3 n1 n2 n3 k1 k2 = (IndList n1 k1, IndList n2 k1, IndList n3 k2) + +type IndTuple4 n1 n2 n3 n4 k1 k2 = (IndList n1 k1, IndList n2 k1, IndList n3 k2, IndList n4 k2) + +type IndTuple5 n1 n2 n3 n4 n5 k1 k2 k3 = (IndList n1 k1, IndList n2 k1, IndList n3 k2, IndList n4 k2, IndList n5 k3) + +type IndTuple6 n1 n2 n3 n4 n5 n6 k1 k2 k3 = (IndList n1 k1, IndList n2 k1, IndList n3 k2, IndList n4 k2, IndList n5 k3, IndList n6 k3) + +type IndTuple7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 = (IndList n1 k1, IndList n2 k1, IndList n3 k2, IndList n4 k2, IndList n5 k3, IndList n6 k3, IndList n7 k4) + +type IndTuple8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 = (IndList n1 k1, IndList n2 k1, IndList n3 k2, IndList n4 k2, IndList n5 k3, IndList n6 k3, IndList n7 k4, IndList n8 k4) + +--construct a tensor with a single value + +mkTens1 :: (IndTuple1 n1 k1, v) -> AbsTensor1 n1 k1 v +mkTens1 = mkTens + +mkTens2 :: (IndTuple2 n1 n2 k1, v) -> AbsTensor2 n1 n2 k1 v +mkTens2 ((i1,i2),s) = mkTens (i1,mkTens (i2,s)) + +mkTens3 :: (IndTuple3 n1 n2 n3 k1 k2, v) -> AbsTensor3 n1 n2 n3 k1 k2 v +mkTens3 ((i1,i2,i3),s) = mkTens (i1,mkTens (i2,mkTens (i3,s))) + +mkTens4 :: (IndTuple4 n1 n2 n3 n4 k1 k2, v) -> AbsTensor4 n1 n2 n3 n4 k1 k2 v +mkTens4 ((i1,i2,i3,i4),s) = mkTens (i1,mkTens (i2,mkTens (i3,mkTens (i4,s)))) + +mkTens5 :: (IndTuple5 n1 n2 n3 n4 n5 k1 k2 k3, v) -> AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v +mkTens5 ((i1,i2,i3,i4,i5),s) = mkTens (i1,mkTens (i2,mkTens (i3,mkTens (i4,mkTens (i5,s))))) + +mkTens6 :: (IndTuple6 n1 n2 n3 n4 n5 n6 k1 k2 k3, v) -> AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v +mkTens6 ((i1,i2,i3,i4,i5,i6),s) = mkTens (i1,mkTens (i2,mkTens (i3,mkTens (i4,mkTens (i5,mkTens (i6,s)))))) + +mkTens7 :: (IndTuple7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4, v) -> AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v +mkTens7 ((i1,i2,i3,i4,i5,i6,i7),s) = mkTens (i1,mkTens (i2,mkTens (i3,mkTens (i4,mkTens (i5,mkTens (i6,mkTens (i7,s))))))) + +mkTens8 :: (IndTuple8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4, v) -> AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v +mkTens8 ((i1,i2,i3,i4,i5,i6,i7,i8),s) = mkTens (i1,mkTens (i2,mkTens (i3,mkTens (i4,mkTens (i5,mkTens (i6,mkTens (i7,mkTens (i8,s)))))))) + +--convert a tensor to corresponding assocs list + +-- | The following function converts a @'Tensor'@ to a typed index tuple list, i.e. a list of key value pairs with keys of type @'IndList'@ and +-- values being the corresponding @'Tensor'@ value. +toListT :: Tensor n k v -> [(IndList n k, v)] +toListT (Scalar x) = [(Empty, x)] +toListT (Tensor m) = concatMap (\(i,t) -> appendF i $ toListT t) m + where + appendF i = map (\(l,val) -> (Append i l ,val)) +toListT ZeroTensor = [] + +toListT1 :: AbsTensor1 n1 k1 v -> [(IndTuple1 n1 k1, v)] +toListT1 = toListT + +toListT2 :: AbsTensor2 n1 n2 k1 v -> [(IndTuple2 n1 n2 k1, v)] +toListT2 t = concatMap (\(x,y) -> appendT1 x $ toListT y ) $ toListT t + +toListT3 :: AbsTensor3 n1 n2 n3 k1 k2 v -> [(IndTuple3 n1 n2 n3 k1 k2, v)] +toListT3 t = concatMap (\(x,y) -> appendT2 x $ toListT y ) $ + concatMap (\(x,y) -> appendT1 x $ toListT y ) $ toListT t + +toListT4 :: AbsTensor4 n1 n2 n3 n4 k1 k2 v -> [(IndTuple4 n1 n2 n3 n4 k1 k2, v)] +toListT4 t = concatMap (\(x,y) -> appendT3 x $ toListT y ) $ + concatMap (\(x,y) -> appendT2 x $ toListT y ) $ + concatMap (\(x,y) -> appendT1 x $ toListT y ) $ toListT t + +toListT5 :: AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> [(IndTuple5 n1 n2 n3 n4 n5 k1 k2 k3, v)] +toListT5 t = concatMap (\(x,y) -> appendT4 x $ toListT y ) $ + concatMap (\(x,y) -> appendT3 x $ toListT y ) $ + concatMap (\(x,y) -> appendT2 x $ toListT y ) $ + concatMap (\(x,y) -> appendT1 x $ toListT y ) $ toListT t + +toListT6 :: AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> [(IndTuple6 n1 n2 n3 n4 n5 n6 k1 k2 k3, v)] +toListT6 t = concatMap (\(x,y) -> appendT5 x $ toListT y ) $ + concatMap (\(x,y) -> appendT4 x $ toListT y ) $ + concatMap (\(x,y) -> appendT3 x $ toListT y ) $ + concatMap (\(x,y) -> appendT2 x $ toListT y ) $ + concatMap (\(x,y) -> appendT1 x $ toListT y ) $ toListT t + +toListT7 :: AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> [(IndTuple7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4, v)] +toListT7 t = concatMap (\(x,y) -> appendT6 x $ toListT y ) $ + concatMap (\(x,y) -> appendT5 x $ toListT y ) $ + concatMap (\(x,y) -> appendT4 x $ toListT y ) $ + concatMap (\(x,y) -> appendT3 x $ toListT y ) $ + concatMap (\(x,y) -> appendT2 x $ toListT y ) $ + concatMap (\(x,y) -> appendT1 x $ toListT y ) $ toListT t + +toListT8 :: AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> [(IndTuple8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4, v)] +toListT8 t = concatMap (\(x,y) -> appendT7 x $ toListT y ) $ + concatMap (\(x,y) -> appendT6 x $ toListT y ) $ + concatMap (\(x,y) -> appendT5 x $ toListT y ) $ + concatMap (\(x,y) -> appendT4 x $ toListT y ) $ + concatMap (\(x,y) -> appendT3 x $ toListT y ) $ + concatMap (\(x,y) -> appendT2 x $ toListT y ) $ + concatMap (\(x,y) -> appendT1 x $ toListT y ) $ toListT t + +appendT1 i = map (\(x,y) -> ((i,x),y)) +appendT2 (i1,i2) = map (\(x,y) -> ((i1,i2,x),y)) +appendT3 (i1,i2,i3) = map (\(x,y) -> ((i1,i2,i3,x),y)) +appendT4 (i1,i2,i3,i4) = map (\(x,y) -> ((i1,i2,i3,i4,x),y)) +appendT5 (i1,i2,i3,i4,i5) = map (\(x,y) -> ((i1,i2,i3,i4,i5,x),y)) +appendT6 (i1,i2,i3,i4,i5,i6) = map (\(x,y) -> ((i1,i2,i3,i4,i5,i6,x),y)) +appendT7 (i1,i2,i3,i4,i5,i6,i7) = map (\(x,y) -> ((i1,i2,i3,i4,i5,i6,i7,x),y)) + +-- | This function converts a given @'Tensor'@ to a non-typed index tuple list. +toListT' :: (TIndex k, TAdd v) => Tensor n k v -> [([Int],v)] +toListT' t = filter (not . scaleZero . snd) $ map (\(x,y) -> (showInd x, y)) l + where + l = toListT t + showInd i1 = map fromEnum $ toList i1 + +toListT1' :: (TIndex k1, TAdd v) => AbsTensor1 n1 k1 v -> [([Int],v)] +toListT1' = toListT' + +toListT2' :: (TIndex k1, TAdd v) => AbsTensor2 n1 n2 k1 v -> [(([Int], [Int]), v)] +toListT2' t = filter (not . scaleZero . snd) $ map (\(x,y) -> (showInd x, y)) l + where + l = toListT2 t + showInd (i1,i2) = (map fromEnum (toList i1), map fromEnum (toList i2)) + +toListT3' :: (TIndex k1, TIndex k2, TAdd v) => AbsTensor3 n1 n2 n3 k1 k2 v -> [(([Int], [Int], [Int]),v)] +toListT3' t = filter (not . scaleZero . snd) $ map (\(x,y) -> (showInd x, y)) l + where + l = toListT3 t + showInd (i1,i2,i3) = (map fromEnum (toList i1), map fromEnum (toList i2), + map fromEnum (toList i3)) + +toListT4' :: (TIndex k1, TIndex k2, TAdd v) => AbsTensor4 n1 n2 n3 n4 k1 k2 v -> [(([Int], [Int], [Int], [Int]),v)] +toListT4' t = filter (not . scaleZero . snd) $ map (\(x,y) -> (showInd x, y)) l + where + l = toListT4 t + showInd (i1,i2,i3,i4) = (map fromEnum (toList i1), map fromEnum (toList i2), + map fromEnum (toList i3), map fromEnum (toList i4)) + +toListT5' :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> [(([Int], [Int], [Int], [Int], [Int]),v)] +toListT5' t = filter (not . scaleZero . snd) $ map (\(x,y) -> (showInd x, y)) l + where + l = toListT5 t + showInd (i1,i2,i3,i4,i5) = (map fromEnum (toList i1), map fromEnum (toList i2), + map fromEnum (toList i3), map fromEnum (toList i4), + map fromEnum (toList i5)) + +toListT6' :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> [(([Int], [Int], [Int], [Int], [Int], [Int]),v)] +toListT6' t = filter (not . scaleZero . snd) $ map (\(x,y) -> (showInd x, y)) l + where + l = toListT6 t + showInd (i1,i2,i3,i4,i5,i6) = (map fromEnum (toList i1), map fromEnum (toList i2), + map fromEnum (toList i3), map fromEnum (toList i4), + map fromEnum (toList i5), map fromEnum (toList i6)) + +toListT7' :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> [(([Int], [Int], [Int], [Int], [Int], [Int], [Int]),v)] +toListT7' t = filter (not . scaleZero . snd) $ map (\(x,y) -> (showInd x, y)) l + where + l = toListT7 t + showInd (i1,i2,i3,i4,i5,i6,i7) = (map fromEnum (toList i1), map fromEnum (toList i2), + map fromEnum (toList i3), map fromEnum (toList i4), + map fromEnum (toList i5), map fromEnum (toList i6), + map fromEnum (toList i7)) + +toListT8' :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> [(([Int], [Int], [Int], [Int], [Int], [Int], [Int], [Int]),v)] +toListT8' t = filter (not . scaleZero . snd) $ map (\(x,y) -> (showInd x, y)) l + where + l = toListT8 t + showInd (i1,i2,i3,i4,i5,i6,i7,i8) = (map fromEnum (toList i1), map fromEnum (toList i2), + map fromEnum (toList i3), map fromEnum (toList i4), + map fromEnum (toList i5), map fromEnum (toList i6), + map fromEnum (toList i7), map fromEnum (toList i8)) + + +--convert to non type safe assocs list, all indices regardless of their type are collected in the [Int] list + +toListShow1 :: (TIndex k1, TAdd v) => AbsTensor1 n1 k1 v -> [([Int],v)] +toListShow1 = toListT' + +toListShow2 :: (TIndex k1, TAdd v) => AbsTensor2 n1 n2 k1 v -> [([Int],v)] +toListShow2 t = filter (not . scaleZero . snd) $ map (\(x,y) -> (showInd x, y)) l + where + l = toListT2 t + showInd (i1,i2) = map fromEnum (toList i1) ++ map fromEnum (toList i2) + +toListShow3 :: (TIndex k1, TIndex k2, TAdd v) => AbsTensor3 n1 n2 n3 k1 k2 v -> [([Int],v)] +toListShow3 t = filter (not . scaleZero . snd) $ map (\(x,y) -> (showInd x, y)) l + where + l = toListT3 t + showInd (i1,i2,i3) = map fromEnum (toList i1) ++ map fromEnum (toList i2) ++ + map fromEnum (toList i3) + +toListShow4 :: (TIndex k1, TIndex k2, TAdd v) => AbsTensor4 n1 n2 n3 n4 k1 k2 v -> [([Int],v)] +toListShow4 t = filter (not . scaleZero . snd) $ map (\(x,y) -> (showInd x, y)) l + where + l = toListT4 t + showInd (i1,i2,i3,i4) = map fromEnum (toList i1) ++ map fromEnum (toList i2) ++ + map fromEnum (toList i3) ++ map fromEnum (toList i4) + +toListShow5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> [([Int],v)] +toListShow5 t = filter (not . scaleZero . snd) $ map (\(x,y) -> (showInd x, y)) l + where + l = toListT5 t + showInd (i1,i2,i3,i4,i5) = map fromEnum (toList i1) ++ map fromEnum (toList i2) ++ + map fromEnum (toList i3) ++ map fromEnum (toList i4) ++ + map fromEnum (toList i5) + +toListShow6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd v) => AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> [([Int],v)] +toListShow6 t = filter (not . scaleZero . snd) $ map (\(x,y) -> (showInd x, y)) l + where + l = toListT6 t + showInd (i1,i2,i3,i4,i5,i6) = map fromEnum (toList i1) ++ map fromEnum (toList i2) ++ + map fromEnum (toList i3) ++ map fromEnum (toList i4) ++ + map fromEnum (toList i5) ++ map fromEnum (toList i6) + +toListShow7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> [([Int],v)] +toListShow7 t = filter (not . scaleZero . snd) $ map (\(x,y) -> (showInd x, y)) l + where + l = toListT7 t + showInd (i1,i2,i3,i4,i5,i6,i7) = map fromEnum (toList i1) ++ map fromEnum (toList i2) ++ + map fromEnum (toList i3) ++ map fromEnum (toList i4) ++ + map fromEnum (toList i5) ++ map fromEnum (toList i6) ++ + map fromEnum (toList i7) + +toListShow8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd v) => AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> [([Int],v)] +toListShow8 t = filter (not . scaleZero . snd) $ map (\(x,y) -> (showInd x, y)) l + where + l = toListT8 t + showInd (i1,i2,i3,i4,i5,i6,i7,i8) = map fromEnum (toList i1) ++ map fromEnum (toList i2) ++ + map fromEnum (toList i3) ++ map fromEnum (toList i4) ++ + map fromEnum (toList i5) ++ map fromEnum (toList i6) ++ + map fromEnum (toList i7) ++ map fromEnum (toList i8) + + +--flatten tensor with ansVar values to assocs list + +toListShowVar1 :: (TIndex k1, TAdd a) => AbsTensor1 n1 k1 (AnsVar a) -> [([Int], [(Int, a)])] +toListShowVar1 t = filter (not . null . snd) $ map (\(a,AnsVar b) -> (a, filter (not . scaleZero . snd) $ I.assocs b)) l + where + l = toListShow1 t + +toListShowVar2 :: (TIndex k1, TAdd a) => AbsTensor2 n1 n2 k1 (AnsVar a) -> [([Int], [(Int, a)])] +toListShowVar2 t = filter (not . null . snd) $ map (\(a,AnsVar b) -> (a, filter (not . scaleZero . snd) $ I.assocs b)) l + where + l = toListShow2 t + +toListShowVar3 :: (TIndex k1, TIndex k2, TAdd a) => AbsTensor3 n1 n2 n3 k1 k2 (AnsVar a) -> [([Int], [(Int, a)])] +toListShowVar3 t = filter (not . null . snd) $ map (\(a,AnsVar b) -> (a, filter (not . scaleZero . snd) $ I.assocs b)) l + where + l = toListShow3 t + +toListShowVar4 :: (TIndex k1, TIndex k2, TAdd a) => AbsTensor4 n1 n2 n3 n4 k1 k2 (AnsVar a) -> [([Int], [(Int, a)])] +toListShowVar4 t = filter (not . null . snd) $ map (\(a,AnsVar b) -> (a, filter (not . scaleZero . snd) $ I.assocs b)) l + where + l = toListShow4 t + +toListShowVar5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd a) => AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 (AnsVar a) -> [([Int], [(Int, a)])] +toListShowVar5 t = filter (not . null . snd) $ map (\(a,AnsVar b) -> (a, filter (not . scaleZero . snd) $ I.assocs b)) l + where + l = toListShow5 t + +toListShowVar6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd a) => AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 (AnsVar a) -> [([Int], [(Int, a)])] +toListShowVar6 t = filter (not . null . snd) $ map (\(a,AnsVar b) -> (a, filter (not . scaleZero . snd) $ I.assocs b)) l + where + l = toListShow6 t + +toListShowVar7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd a) => AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 (AnsVar a) -> [([Int], [(Int, a)])] +toListShowVar7 t = filter (not . null . snd) $ map (\(a,AnsVar b) -> (a, filter (not . scaleZero . snd) $ I.assocs b)) l + where + l = toListShow7 t + +toListShowVar8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd a) => AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 (AnsVar a) -> [([Int], [(Int, a)])] +toListShowVar8 t = filter (not . null . snd) $ map (\(a,AnsVar b) -> (a, filter (not . scaleZero . snd) $ I.assocs b)) l + where + l = toListShow8 t + +--write the tensor data into a matrix: columns label the occurring AnsVars (note that this is possible as we restricted to the case where the vars only occur linearly) +--rows label the non zero entries in the tensor + +toMatList1' :: (TIndex k1, TAdd a) => AbsTensor1 n1 k1 (AnsVar a) -> [[(Int, a)]] +toMatList1' t = map snd $ toListShowVar1 t + +toMatList2' :: (TIndex k1, TAdd a) => AbsTensor2 n1 n2 k1 (AnsVar a) -> [[(Int, a)]] +toMatList2' t = map snd $ toListShowVar2 t + +toMatList3' :: (TIndex k1, TIndex k2, TAdd a) => AbsTensor3 n1 n2 n3 k1 k2 (AnsVar a) -> [[(Int, a)]] +toMatList3' t = map snd $ toListShowVar3 t + +toMatList4' :: (TIndex k1, TIndex k2, TAdd a) => AbsTensor4 n1 n2 n3 n4 k1 k2 (AnsVar a) -> [[(Int, a)]] +toMatList4' t = map snd $ toListShowVar4 t + +toMatList5' :: (TIndex k1, TIndex k2, TIndex k3, TAdd a) => AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 (AnsVar a) -> [[(Int, a)]] +toMatList5' t = map snd $ toListShowVar5 t + +toMatList6' :: (TIndex k1, TIndex k2, TIndex k3, TAdd a) => AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 (AnsVar a) -> [[(Int, a)]] +toMatList6' t = map snd $ toListShowVar6 t + +toMatList7' :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd a) => AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 (AnsVar a) -> [[(Int, a)]] +toMatList7' t = map snd $ toListShowVar7 t + +toMatList8' :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd a) => AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 (AnsVar a) -> [[(Int, a)]] +toMatList8' t = map snd $ toListShowVar8 t + +normalize :: [(Int,Rational)] -> ([(Int,Rational)],Rational) +normalize [] = ([],1) +normalize ((a,b) : xs) = ((a,1) : map (\(x,y) -> (x,y / b)) xs,b) + +data TensList1 k1 v where + EmptyTList1 :: TensList1 k1 v + AppendTList1 :: AbsTensor1 n1 k1 v -> TensList1 k1 v -> TensList1 k1 v + +data TensList2 k1 v where + EmptyTList2 :: TensList2 k1 v + AppendTList2 :: AbsTensor2 n1 n2 k1 v -> TensList2 k1 v -> TensList2 k1 v + +data TensList3 k1 k2 v where + EmptyTList3 :: TensList3 k1 k2 v + AppendTList3 :: AbsTensor3 n1 n2 n3 k1 k2 v -> TensList3 k1 k2 v -> TensList3 k1 k2 v + +data TensList4 k1 k2 v where + EmptyTList4 :: TensList4 k1 k2 v + AppendTList4 :: AbsTensor4 n1 n2 n3 n4 k1 k2 v -> TensList4 k1 k2 v -> TensList4 k1 k2 v + +data TensList5 k1 k2 k3 v where + EmptyTList5 :: TensList5 k1 k2 k3 v + AppendTList5 :: AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> TensList5 k1 k2 k3 v -> TensList5 k1 k2 k3 v + +data TensList6 k1 k2 k3 v where + EmptyTList6 :: TensList6 k1 k2 k3 v + AppendTList6 :: AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> TensList6 k1 k2 k3 v -> TensList6 k1 k2 k3 v + +data TensList7 k1 k2 k3 k4 v where + EmptyTList7 :: TensList7 k1 k2 k3 k4 v + AppendTList7 :: AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> TensList7 k1 k2 k3 k4 v -> TensList7 k1 k2 k3 k4 v + +data TensList8 k1 k2 k3 k4 v where + EmptyTList8 :: TensList8 k1 k2 k3 k4 v + AppendTList8 :: AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> TensList8 k1 k2 k3 k4 v -> TensList8 k1 k2 k3 k4 v + +-- | Usual map function for heterogeneous tensor lists. + +mapTensList1 :: (forall n1. AbsTensor1 n1 k1 v -> b ) -> TensList1 k1 v -> [b] +mapTensList1 f EmptyTList1 = [] +mapTensList1 f (AppendTList1 t l) = f t : mapTensList1 f l + +mapTensList2 :: (forall n1 n2. AbsTensor2 n1 n2 k1 v -> b ) -> TensList2 k1 v -> [b] +mapTensList2 f EmptyTList2 = [] +mapTensList2 f (AppendTList2 t l) = f t : mapTensList2 f l + +mapTensList3 :: (forall n1 n2 n3. AbsTensor3 n1 n2 n3 k1 k2 v -> b ) -> TensList3 k1 k2 v -> [b] +mapTensList3 f EmptyTList3 = [] +mapTensList3 f (AppendTList3 t l) = f t : mapTensList3 f l + +mapTensList4 :: (forall n1 n2 n3 n4. AbsTensor4 n1 n2 n3 n4 k1 k2 v -> b ) -> TensList4 k1 k2 v -> [b] +mapTensList4 f EmptyTList4 = [] +mapTensList4 f (AppendTList4 t l) = f t : mapTensList4 f l + +mapTensList5 :: (forall n1 n2 n3 n4 n5. AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> b ) -> TensList5 k1 k2 k3 v -> [b] +mapTensList5 f EmptyTList5 = [] +mapTensList5 f (AppendTList5 t l) = f t : mapTensList5 f l + +mapTensList6 :: (forall n1 n2 n3 n4 n5 n6. AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> b ) -> TensList6 k1 k2 k3 v -> [b] +mapTensList6 f EmptyTList6 = [] +mapTensList6 f (AppendTList6 t l) = f t : mapTensList6 f l + +mapTensList7 :: (forall n1 n2 n3 n4 n5 n6 n7. AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> b ) -> TensList7 k1 k2 k3 k4 v -> [b] +mapTensList7 f EmptyTList7 = [] +mapTensList7 f (AppendTList7 t l) = f t : mapTensList7 f l + +mapTensList8 :: (forall n1 n2 n3 n4 n5 n6 n7 n8. AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> b ) -> TensList8 k1 k2 k3 k4 v -> [b] +mapTensList8 f EmptyTList8 = [] +mapTensList8 f (AppendTList8 t l) = f t : mapTensList8 f l + +infixr 5 ...> + +(...>) :: AbsTensor1 n1 k1 v -> TensList1 k1 v -> TensList1 k1 v +(...>) = AppendTList1 + + +singletonTList1 :: AbsTensor1 n1 k1 v -> TensList1 k1 v +singletonTList1 t = t ...> EmptyTList1 + +infixr 5 ...+ + +(...+) :: TensList1 k1 v -> TensList1 k1 v -> TensList1 k1 v +(...+) EmptyTList1 t1 = t1 +(...+) t1 EmptyTList1 = t1 +(...+) (AppendTList1 t1 EmptyTList1) t2 = AppendTList1 t1 t2 +(...+) (AppendTList1 t1 t1') t2 = AppendTList1 t1 (t1' ...+ t2) + + +infixr 5 ..&> + +(..&>) :: AbsTensor2 n1 n2 k1 v -> TensList2 k1 v -> TensList2 k1 v +(..&>) = AppendTList2 + +singletonTList2 :: AbsTensor2 n1 n2 k1 v -> TensList2 k1 v +singletonTList2 t = t ..&> EmptyTList2 + +infixr 5 ..&+ + +(..&+) :: TensList2 k1 v -> TensList2 k1 v -> TensList2 k1 v +(..&+) EmptyTList2 t1 = t1 +(..&+) t1 EmptyTList2 = t1 +(..&+) (AppendTList2 t1 EmptyTList2) t2 = AppendTList2 t1 t2 +(..&+) (AppendTList2 t1 t1') t2 = AppendTList2 t1 (t1' ..&+ t2) + + +infixr 5 .&.> + +(.&.>) :: AbsTensor3 n1 n2 n3 k1 k2 v -> TensList3 k1 k2 v -> TensList3 k1 k2 v +(.&.>) = AppendTList3 + +singletonTList3 :: AbsTensor3 n1 n2 n3 k1 k2 v -> TensList3 k1 k2 v +singletonTList3 t = t .&.> EmptyTList3 + +infixr 5 .&.+ + +(.&.+) :: TensList3 k1 k2 v -> TensList3 k1 k2 v -> TensList3 k1 k2 v +(.&.+) EmptyTList3 t1 = t1 +(.&.+) t1 EmptyTList3 = t1 +(.&.+) (AppendTList3 t1 EmptyTList3) t2 = AppendTList3 t1 t2 +(.&.+) (AppendTList3 t1 t1') t2 = AppendTList3 t1 (t1' .&.+ t2) + + +infixr 5 .&&> + +(.&&>) :: AbsTensor4 n1 n2 n3 n4 k1 k2 v -> TensList4 k1 k2 v -> TensList4 k1 k2 v +(.&&>) = AppendTList4 + +singletonTList4 :: AbsTensor4 n1 n2 n3 n4 k1 k2 v -> TensList4 k1 k2 v +singletonTList4 t = t .&&> EmptyTList4 + +infixr 5 .&&+ + +(.&&+) :: TensList4 k1 k2 v -> TensList4 k1 k2 v -> TensList4 k1 k2 v +(.&&+) EmptyTList4 t1 = t1 +(.&&+) t1 EmptyTList4 = t1 +(.&&+) (AppendTList4 t1 EmptyTList4) t2 = AppendTList4 t1 t2 +(.&&+) (AppendTList4 t1 t1') t2 = AppendTList4 t1 (t1' .&&+ t2) + + +infixr 5 &..> + +(&..>) :: AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> TensList5 k1 k2 k3 v -> TensList5 k1 k2 k3 v +(&..>) = AppendTList5 + +singletonTList5 :: AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 v -> TensList5 k1 k2 k3 v +singletonTList5 t = t &..> EmptyTList5 + +infixr 5 &..+ + +(&..+) :: TensList5 k1 k2 k3 v -> TensList5 k1 k2 k3 v -> TensList5 k1 k2 k3 v +(&..+) EmptyTList5 t1 = t1 +(&..+) t1 EmptyTList5 = t1 +(&..+) (AppendTList5 t1 EmptyTList5) t2 = AppendTList5 t1 t2 +(&..+) (AppendTList5 t1 t1') t2 = AppendTList5 t1 (t1' &..+ t2) + + +infixr 5 &.&> + +(&.&>) :: AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> TensList6 k1 k2 k3 v -> TensList6 k1 k2 k3 v +(&.&>) = AppendTList6 + +singletonTList6 :: AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 v -> TensList6 k1 k2 k3 v +singletonTList6 t = t &.&> EmptyTList6 + +infixr 5 &.&+ + +(&.&+) :: TensList6 k1 k2 k3 v -> TensList6 k1 k2 k3 v -> TensList6 k1 k2 k3 v +(&.&+) EmptyTList6 t1 = t1 +(&.&+) t1 EmptyTList6 = t1 +(&.&+) (AppendTList6 t1 EmptyTList6) t2 = AppendTList6 t1 t2 +(&.&+) (AppendTList6 t1 t1') t2 = AppendTList6 t1 (t1' &.&+ t2) + + +infixr 5 &&.> + +(&&.>) :: AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> TensList7 k1 k2 k3 k4 v -> TensList7 k1 k2 k3 k4 v +(&&.>) = AppendTList7 + +singletonTList7 :: AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 v -> TensList7 k1 k2 k3 k4 v +singletonTList7 t = t &&.> EmptyTList7 + +infixr 5 &&.+ + +(&&.+) :: TensList7 k1 k2 k3 k4 v -> TensList7 k1 k2 k3 k4 v -> TensList7 k1 k2 k3 k4 v +(&&.+) EmptyTList7 t1 = t1 +(&&.+) t1 EmptyTList7 = t1 +(&&.+) (AppendTList7 t1 EmptyTList7) t2 = AppendTList7 t1 t2 +(&&.+) (AppendTList7 t1 t1') t2 = AppendTList7 t1 (t1' &&.+ t2) + + +infixr 5 &&&> + +(&&&>) :: AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> TensList8 k1 k2 k3 k4 v -> TensList8 k1 k2 k3 k4 v +(&&&>) = AppendTList8 + +singletonTList8 :: AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 v -> TensList8 k1 k2 k3 k4 v +singletonTList8 t = t &&&> EmptyTList8 + +infixr 5 &&&+ + +(&&&+) :: TensList8 k1 k2 k3 k4 v -> TensList8 k1 k2 k3 k4 v -> TensList8 k1 k2 k3 k4 v +(&&&+) EmptyTList8 t1 = t1 +(&&&+) t1 EmptyTList8 = t1 +(&&&+) (AppendTList8 t1 EmptyTList8) t2 = AppendTList8 t1 t2 +(&&&+) (AppendTList8 t1 t1') t2 = AppendTList8 t1 (t1' &&&+ t2) + + +--collect data of heterogeneous tensor list in one sparse matrix assocs list +--intended for evaluating tensorial equations: the values are only collected up to overall factors + +collectMatList :: [[(Int, a)]] -> [((Int, Int), a)] +collectMatList matList = l + where + -- l2 = nubBy (\(a,_) (b,_) -> a == b) $ map normalize matList + -- l = map (\(x,y) -> map (\(a,b) -> (a,b*y)) x) l2 + l = concat $ zipWith (\r z -> map (\(x,y) -> ((z, x), y)) r) matList [1..] + +toMatListT1 :: (TIndex k1, TAdd a) => TensList1 k1 (AnsVar a) -> [((Int,Int),a)] +toMatListT1 t = collectMatList matList + where + matList = concat $ mapTensList1 toMatList1' t + +toMatListT2 :: (TIndex k1, TAdd a) => TensList2 k1 (AnsVar a) -> [((Int,Int),a)] +toMatListT2 t = collectMatList matList + where + matList = concat $ mapTensList2 toMatList2' t + +toMatListT3 :: (TIndex k1, TIndex k2, TAdd a) => TensList3 k1 k2 (AnsVar a) -> [((Int,Int),a)] +toMatListT3 t = collectMatList matList + where + matList = concat $ mapTensList3 toMatList3' t + +toMatListT4 :: (TIndex k1, TIndex k2, TAdd a) => TensList4 k1 k2 (AnsVar a) -> [((Int,Int),a)] +toMatListT4 t = collectMatList matList + where + matList = concat $ mapTensList4 toMatList4' t + +toMatListT5 :: (TIndex k1, TIndex k2, TIndex k3, TAdd a) => TensList5 k1 k2 k3 (AnsVar a) -> [((Int,Int),a)] +toMatListT5 t = collectMatList matList + where + matList = concat $ mapTensList5 toMatList5' t + +toMatListT6 :: (TIndex k1, TIndex k2, TIndex k3, TAdd a) => TensList6 k1 k2 k3 (AnsVar a) -> [((Int,Int),a)] +toMatListT6 t = collectMatList matList + where + matList = concat $ mapTensList6 toMatList6' t + +toMatListT7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd a) => TensList7 k1 k2 k3 k4 (AnsVar a) -> [((Int,Int),a)] +toMatListT7 t = collectMatList matList + where + matList = concat $ mapTensList7 toMatList7' t + +toMatListT8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4, TAdd a) => TensList8 k1 k2 k3 k4 (AnsVar a) -> [((Int,Int),a)] +toMatListT8 t = collectMatList matList + where + matList = concat $ mapTensList8 toMatList8' t + + +--convert to Eigen format for using LA subroutines + +dims :: [((Int, Int), a)] -> (Int, Int) +dims xs = (rows, cols) + where + rows = maximum $ map (fst.fst) xs + cols = maximum $ map (snd.fst) xs + +assocsToSparse :: Real a => [((Int, Int), SField a)] -> Sparse.SparseMatrixXd +assocsToSparse [] = Sparse.fromList 1 1 [(0,0,0)] +assocsToSparse assocs = Sparse.fromList rows cols els + where + (rows, cols) = dims assocs + els = map (\((x, y), SField z) -> (x-1, y-1, fromRational $ toRational z)) assocs + +toEMatrixT1 :: (TIndex k1) => TensList1 k1 (AnsVar (SField Rational)) -> Sparse.SparseMatrixXd +toEMatrixT1 = assocsToSparse . toMatListT1 + +toEMatrixT2 :: (TIndex k1) => TensList2 k1 (AnsVar (SField Rational)) -> Sparse.SparseMatrixXd +toEMatrixT2 = assocsToSparse . toMatListT2 + +toEMatrixT3 :: (TIndex k1, TIndex k2) => TensList3 k1 k2 (AnsVar (SField Rational)) -> Sparse.SparseMatrixXd +toEMatrixT3 = assocsToSparse . toMatListT3 + +toEMatrixT4 :: (TIndex k1, TIndex k2) => TensList4 k1 k2 (AnsVar (SField Rational)) -> Sparse.SparseMatrixXd +toEMatrixT4 = assocsToSparse . toMatListT4 + +toEMatrixT5 :: (TIndex k1, TIndex k2, TIndex k3) => TensList5 k1 k2 k3 (AnsVar (SField Rational)) -> Sparse.SparseMatrixXd +toEMatrixT5 = assocsToSparse . toMatListT5 + +toEMatrixT6 :: (TIndex k1, TIndex k2, TIndex k3) => TensList6 k1 k2 k3 (AnsVar (SField Rational)) -> Sparse.SparseMatrixXd +toEMatrixT6 = assocsToSparse . toMatListT6 + +toEMatrixT7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4) => TensList7 k1 k2 k3 k4 (AnsVar (SField Rational)) -> Sparse.SparseMatrixXd +toEMatrixT7 = assocsToSparse . toMatListT7 + +toEMatrixT8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4) => TensList8 k1 k2 k3 k4 (AnsVar (SField Rational)) -> Sparse.SparseMatrixXd +toEMatrixT8 = assocsToSparse . toMatListT8 + +--rank of the tensor can be computed with rank Sol.FullPivLU or Sol.JakobiSVD + +tensorRank1' :: (TIndex k1) => AbsTensor1 n1 k1 (AnsVar (SField Rational)) -> Int +tensorRank1' t = Sol.rank Sol.FullPivLU $ Sparse.toMatrix $ toEMatrixT1 (singletonTList1 t) + +tensorRank1 :: (TIndex k1) => TensList1 k1 (AnsVar (SField Rational)) -> Int +tensorRank1 t = Sol.rank Sol.FullPivLU $ Sparse.toMatrix $ toEMatrixT1 t + + +tensorRank2' :: (TIndex k1) => AbsTensor2 n1 n2 k1 (AnsVar (SField Rational)) -> Int +tensorRank2' t = Sol.rank Sol.FullPivLU $ Sparse.toMatrix $ toEMatrixT2 (singletonTList2 t) + +tensorRank2 :: (TIndex k1) => TensList2 k1 (AnsVar (SField Rational)) -> Int +tensorRank2 t = Sol.rank Sol.FullPivLU $ Sparse.toMatrix $ toEMatrixT2 t + + +tensorRank3' :: (TIndex k1, TIndex k2) => AbsTensor3 n1 n2 n3 k1 k2 (AnsVar (SField Rational)) -> Int +tensorRank3' t = Sol.rank Sol.FullPivLU $ Sparse.toMatrix $ toEMatrixT3 (singletonTList3 t) + +tensorRank3 :: (TIndex k1, TIndex k2) => TensList3 k1 k2 (AnsVar (SField Rational)) -> Int +tensorRank3 t = Sol.rank Sol.FullPivLU $ Sparse.toMatrix $ toEMatrixT3 t + + +tensorRank4' :: (TIndex k1, TIndex k2) => AbsTensor4 n1 n2 n3 n4 k1 k2 (AnsVar (SField Rational)) -> Int +tensorRank4' t = Sol.rank Sol.FullPivLU $ Sparse.toMatrix $ toEMatrixT4 (singletonTList4 t) + +tensorRank4 :: (TIndex k1, TIndex k2) => TensList4 k1 k2 (AnsVar (SField Rational)) -> Int +tensorRank4 t = Sol.rank Sol.FullPivLU $ Sparse.toMatrix $ toEMatrixT4 t + + +tensorRank5' :: (TIndex k1, TIndex k2, TIndex k3) => AbsTensor5 n1 n2 n3 n4 n5 k1 k2 k3 (AnsVar (SField Rational)) -> Int +tensorRank5' t = Sol.rank Sol.FullPivLU $ Sparse.toMatrix $ toEMatrixT5 (singletonTList5 t) + +tensorRank5 :: (TIndex k1, TIndex k2, TIndex k3) => TensList5 k1 k2 k3 (AnsVar (SField Rational)) -> Int +tensorRank5 t = Sol.rank Sol.FullPivLU $ Sparse.toMatrix $ toEMatrixT5 t + + +tensorRank6' :: (TIndex k1, TIndex k2, TIndex k3) => AbsTensor6 n1 n2 n3 n4 n5 n6 k1 k2 k3 (AnsVar (SField Rational)) -> Int +tensorRank6' t = Sol.rank Sol.FullPivLU $ Sparse.toMatrix $ toEMatrixT6 (singletonTList6 t) + +tensorRank6 :: (TIndex k1, TIndex k2, TIndex k3) => TensList6 k1 k2 k3 (AnsVar (SField Rational)) -> Int +tensorRank6 t = Sol.rank Sol.FullPivLU $ Sparse.toMatrix $ toEMatrixT6 t + + +tensorRank7' :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4) => AbsTensor7 n1 n2 n3 n4 n5 n6 n7 k1 k2 k3 k4 (AnsVar (SField Rational)) -> Int +tensorRank7' t = Sol.rank Sol.FullPivLU $ Sparse.toMatrix $ toEMatrixT7 (singletonTList7 t) + +tensorRank7 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4) => TensList7 k1 k2 k3 k4 (AnsVar (SField Rational)) -> Int +tensorRank7 t = Sol.rank Sol.FullPivLU $ Sparse.toMatrix $ toEMatrixT7 t + + +tensorRank8' :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4) => AbsTensor8 n1 n2 n3 n4 n5 n6 n7 n8 k1 k2 k3 k4 (AnsVar (SField Rational)) -> Int +tensorRank8' t = Sol.rank Sol.FullPivLU $ Sparse.toMatrix $ toEMatrixT8 (singletonTList8 t) + +tensorRank8 :: (TIndex k1, TIndex k2, TIndex k3, TIndex k4) => TensList8 k1 k2 k3 k4 (AnsVar (SField Rational)) -> Int +tensorRank8 t = Sol.rank Sol.FullPivLU $ Sparse.toMatrix $ toEMatrixT8 t + + diff --git a/src/Math/Tensor/Examples/Gravity.hs b/src/Math/Tensor/Examples/Gravity.hs new file mode 100644 --- /dev/null +++ b/src/Math/Tensor/Examples/Gravity.hs @@ -0,0 +1,562 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Math.Tensor.Examples.Gravity +-- Copyright : (c) 2019 Tobias Reinhart and Nils Alex +-- License : MIT +-- Maintainer : tobi.reinhart@fau.de, nils.alex@fau.de +-- +-- +-- This module provides a variety of @'Tensor'@s that are currently predefined in the sparse.tensor package. +-- +-- Amongst many standard tensor from differential geometry and classical field theories such as Kronecker deltas \(\delta^a_b \) in multiple different dimensions, +-- the Levi-Civita symbol \(\epsilon^{abcd} \) and the Minkowski metric \(\eta_{ab}\) and its inverse \(\eta^{ab}\), most included tensors were implemented during +-- the initial use of the sparse-tensor package, the perturbative construction of generalized gravity theories. Thus many of the included tensors stem from this area of research. +-- +-- Additionally to providing basic predefined @'Tensor'@s for further computations this module also nicely illustrates how the construction of @'Tensor'@s is achieved. +-- +-- The majority of the tensors in this module are defined as type @'ATens'@ which describes a tensor that takes the three different index types +-- @'Ind20'@, @'Ind9'@, @'Ind3'@ each one appearing in contravariant and covariant position. If in the following expression that are formed from such tensors are additionally +-- explained via their algebraic expression using appropriate symbols for the individual tensors we label indices of type @'Ind20'@ by \(A,B,C,D,...\), indices of type +-- \(I,J,K,L,...\) and spacetime indices of type @'ind3'@ are labeled by \(a,b,c,d,...\). Hence a general such tensor is displayed as \(T^{A_1...A_m I_1...I_r a_1...a_p}_{B_1...B_n J_1...J_s b_1...b_s} \). +-- Such a tensor then has the type @'ATens' m n r s p q@. +----------------------------------------------------------------------------- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +module Math.Tensor.Examples.Gravity ( +-- * Standard Tensors +-- ** Kronecker Delta +delta3, delta9, delta20, +delta3A, +-- ** Minkowski Metric +eta, invEta, etaA, invEtaA, etaAbs, +-- ** Levi-Civita Symbol +epsilon, epsilonInv, epsilonA, epsilonInvA, +-- ** Generators of the Lorentz Group \( \mathrm{SO}(3,1)\) +-- | The following six tensors are a choice of generators of the Lorentz group \( \mathrm{SO}(3,1)\), i.e. they constitute a basis of the +-- corresponding Lie algebra \( \mathrm{so}(3,1)\). +-- +-- The Lie algebra \( \mathrm{so}(3,1)\) is isomorphic to the algebra of \(\eta_{ab}\) anti symmetric matrices. +-- Thus the following six tensors \( (K_i)^a_b \) for \( i = 1,...,6 \) all satisfy \( (K_i)^a_{b} \eta_{ca} = - (K_i)^a_{c} \eta_{ba} \). +-- +-- The six generators are obtained by \(2 (K_1)^a_b = \eta_{b0} \delta^ a_{1} - \eta_{b0} \delta^ a_{1} \), and similar for +-- the remaining @5@ independent components of the anti symmetric index pair. +lorentzJ1, lorentzJ2, lorentzJ3, lorentzK1, lorentzK2, lorentzK3, +-- ** Area Metric +flatArea, +-- * Constructive Gravity Specific Tensors +-- ** Intertwiners +-- | The following tensors are used to relate the abstract indices of type @'Ind9'@ to symmetric pairs of spacetime indices of type @'Ind3'@. +interI2, interJ2, +-- | The following tensors are used to relate the abstract indices of type @'Ind20'@ to blocks of @4@ spacetime indices \( (abcd)\) of type @'Ind3'@, that are anti symmetric in +-- \( a \leftrightarrow b \), anti symmetric in \( c \leftrightarrow d \) and further symmetric w.r.t. \( (ab) \leftrightarrow (cd) \). +interIArea, interJArea, +-- ** Infinitesimal Diffeomorphisms +-- | The following two tensors \(C^{Am}_{Bn} \) and \(K^{Im}_{Jn}\) encode the infinitesimal transformation behavior of tensors of type @'ATens' 0 0 0 1 0 0@ and tensors of type +-- @'ATens' 0 1 0 0 0 0@ respectively under spacetime diffeomorphisms. They are related to the Lie derivative via \(\mathscr{L}_{\xi}G_A = \partial_m G_A \cdot \xi^m + C^{Bm}_{An} G_B \cdot \partial_m \xi ^n \). +interArea, interMetric, +-- | __ Further such Tensors__ +flatInterMetric, flatInter, +interEqn2, interEqn3, interEqn4, interEqn5, +interEqn2Metric, interEqn3Metric, interEqn4Metric, interEqn5Metric, +-- ** Random Tensor +-- | The following tensors are filled with random components. They can for instance be used to test ranks of tensorial equations. +randArea, randFlatArea, randAreaDerivative1, randAreaDerivative2, randMetric, randAxon, +-- * Unknown Tensors +-- The following tensors have all there individual components filled with different variables using the @'AnsVarR'@ type. +-- Thus they represent general tensors with unknown components. +generic4Ansatz, generic5Ansatz, generic6Ansatz, +generic8Ansatz, generic9Ansatz, generic10_1Ansatz, generic10_2Ansatz, generic11Ansatz, generic12_1Ansatz, +) where + +import System.Random.TF.Instances (randomRs) +import System.Random.TF.Init (newTFGen) + +import qualified Data.Map.Strict as M +import qualified Data.IntMap.Strict as I + +import Data.List (permutations, nub, sort) + +import Math.Tensor + +liftSTtoATens :: STTens n1 n2 v -> ATens 0 0 0 0 n1 n2 v +liftSTtoATens = Scalar . Scalar . Scalar . Scalar + +--start with deltas + +-- | Standard spacetime Kronecker delta \(\delta^a_b\) as @'STTens' 1 1 ('SField' 'Rational')@. +-- +-- > delta3 = fromListT2 $ zip [(singletonInd (Ind3 i),singletonInd (Ind3 i)) | i <- [0..3]] (repeat $ SField 1) +delta3 :: STTens 1 1 (SField Rational) +delta3 = fromListT2 $ zip [(singletonInd (Ind3 i),singletonInd (Ind3 i)) | i <- [0..3]] (repeat $ SField 1) + +-- | Spacetime Kronecker delta as @'ATens'@. +delta3A :: ATens 0 0 0 0 1 1 (SField Rational) +delta3A = liftSTtoATens delta3 + +-- | Standard Kronecker delta for the @'Ind9'@ index type \(\delta^I_J\) as @'ATens' 0 0 1 1 0 0 ('SField' 'Rational')@. +-- +-- > delta9 = fromListT6 $ zip [(Empty, Empty, singletonInd (Ind9 i),singletonInd (Ind9 i), Empty, Empty) | i <- [0..9]] (repeat $ SField 1) +delta9 :: ATens 0 0 1 1 0 0 (SField Rational) +delta9 = fromListT6 $ zip [(Empty, Empty, singletonInd (Ind9 i),singletonInd (Ind9 i), Empty, Empty) | i <- [0..9]] (repeat $ SField 1) + +-- | Standard Kronecker delta for the @'Ind20'@ index type \(\delta^A_B\) as @'ATens' 1 1 0 0 0 0 ('SField' 'Rational')@. +-- +-- > delta20 = fromListT6 $ zip [(singletonInd (Ind20 i),singletonInd (Ind20 i), Empty, Empty, Empty, Empty) | i <- [0..20]] (repeat $ SField 1) +delta20 :: ATens 1 1 0 0 0 0 (SField Rational) +delta20 = fromListT6 $ zip [(singletonInd (Ind20 i),singletonInd (Ind20 i), Empty, Empty, Empty, Empty) | i <- [0..20]] (repeat $ SField 1) + +-- | Spacetime Minkowski metric \(\eta_{ab}\) as @'ATens' 0 0 0 0 0 2 ('SField' 'Rational')@. The Minkowski metric could +-- also be defined as @'STTens' 0 2 ('SField' 'Rational')@ in similar fashion. +-- +-- > eta = fromListT2 map (\(x,y,z) -> ((Empty,Append (Ind3 x) $ Append (Ind3 y) Empty),SField z)) [(0,0,-1),(1,1,1),(2,2,1),(3,3,1)] +eta :: STTens 0 2 (SField Rational) +eta = fromListT2 l + where + l = map (\(x,y,z) -> ((Empty,Append (Ind3 x) $ Append (Ind3 y) Empty),SField z)) + [(0,0,-1),(1,1,1),(2,2,1),(3,3,1)] + +-- | Minkowski metric lifted to @'ATens'@. +etaA :: ATens 0 0 0 0 0 2 (SField Rational) +etaA = liftSTtoATens eta + +-- | Inverse spacetime Minkowski metric \(\eta^{ab}\) as @'ATens' 0 0 0 0 2 0 ('SField' 'Rational')@. The inverse Minkowski metric could +-- also be defined as @'STTens' 2 0 ('SField' 'Rational')@ in similar fashion. +-- +-- > invEta = fromListT2 $ map (\(x,y,z) -> ((Append (Ind3 x) $ Append (Ind3 y) Empty,Empty),SField z)) [(0,0,-1),(1,1,1),(2,2,1),(3,3,1)] +invEta :: STTens 2 0 (SField Rational) +invEta = fromListT2 l + where + l = map (\(x,y,z) -> ((Append (Ind3 x) $ Append (Ind3 y) Empty,Empty),SField z)) + [(0,0,-1),(1,1,1),(2,2,1),(3,3,1)] + +-- | Inverse Minkowski metric lifted to @'ATens'@. +invEtaA :: ATens 0 0 0 0 2 0 (SField Rational) +invEtaA = liftSTtoATens invEta + +-- | The tensor \(\eta_I\) provides an equivalent version of the Minkowski metric that uses an index of type @'Ind9'@ to label the @10@ different values of the symmetric spacetime index pair. +etaAbs :: ATens 0 0 0 1 0 0 (SField Rational) +etaAbs = fromListT6 l + where + l = map (\(x,y) -> ((Empty, Empty, Empty, singletonInd $ Ind9 x, Empty, Empty),SField y)) + [(0,-1),(4,1),(7,1),(9,1)] + +-- | Covariant spacetime Levi-Civita symbol \(\epsilon_{abcd}\) as type @'ATTens' 0 4 ('SField' 'Rational')@. +epsilon :: STTens 0 4 (SField Rational) +epsilon = fromListT2 l + where + l = map (\([i,j,k,l],v) -> ((Empty, Append (Ind3 i) $ Append (Ind3 j) $ Append (Ind3 k) $ singletonInd (Ind3 l)),SField v)) epsL + epsSign [i,j,k,l] = (-1) ^ length (filter (==True) [j>i,k>i,l>i,k>j,l>j,l>k]) + epsL = map (\x -> (x, epsSign x)) $ permutations [0,1,2,3] + +-- | Covariant Levi-Civita symbol lifted to @'ATens'@. +epsilonA :: ATens 0 0 0 0 0 4 (SField Rational) +epsilonA = liftSTtoATens epsilon + +-- | Contravariant spacetime Levi-Civita symbol \(\epsilon^{abcd}\) as type @'STTens'4 0 ('SField' 'Rational')@. T +epsilonInv :: STTens 4 0 (SField Rational) +epsilonInv = fromListT2 l + where + l = map (\([i,j,k,l],v) -> ((Append (Ind3 i) $ Append (Ind3 j) $ Append (Ind3 k) $ singletonInd (Ind3 l), Empty),SField v)) epsL + epsSign [i,j,k,l] = (-1) ^ length (filter (==True) [j>i,k>i,l>i,k>j,l>j,l>k]) + epsL = map (\x -> (x, epsSign x)) $ permutations [0,1,2,3] + +-- | Contravariant Levi-Civita symbol lifted to @'ATens'@. +epsilonInvA :: ATens 0 0 0 0 4 0 (SField Rational) +epsilonInvA = liftSTtoATens epsilonInv + +--generators of the Lorentz group lie algebra (for flat metric eta) + +lorentzJ1 :: ATens 0 0 0 0 1 1 (SField Rational) +lorentzJ1 = fromListT6 l + where + l = map (\(x,y,z) -> ((Empty,Empty,Empty,Empty,singletonInd $ Ind3 x,singletonInd $ Ind3 y), SField z)) [(3,2,1),(2,3,-1)] + +lorentzJ2 :: ATens 0 0 0 0 1 1 (SField Rational) +lorentzJ2 = fromListT6 l + where + l = map (\(x,y,z) -> ((Empty,Empty,Empty,Empty,singletonInd $ Ind3 x,singletonInd $ Ind3 y), SField z)) [(3,1,-1),(1,3,1)] + +lorentzJ3 :: ATens 0 0 0 0 1 1 (SField Rational) +lorentzJ3 = fromListT6 l + where + l = map (\(x,y,z) -> ((Empty,Empty,Empty,Empty,singletonInd $ Ind3 x,singletonInd $ Ind3 y), SField z)) [(2,1,1),(1,2,-1)] + +lorentzK1 :: ATens 0 0 0 0 1 1 (SField Rational) +lorentzK1 = fromListT6 l + where + l = map (\(x,y,z) -> ((Empty,Empty,Empty,Empty,singletonInd $ Ind3 x,singletonInd $ Ind3 y), SField z)) [(0,1,1),(1,0,1)] + +lorentzK2 :: ATens 0 0 0 0 1 1 (SField Rational) +lorentzK2 = fromListT6 l + where + l = map (\(x,y,z) -> ((Empty,Empty,Empty,Empty,singletonInd $ Ind3 x,singletonInd $ Ind3 y), SField z)) [(0,2,1),(2,0,1)] + +lorentzK3 :: ATens 0 0 0 0 1 1 (SField Rational) +lorentzK3 = fromListT6 l + where + l = map (\(x,y,z) -> ((Empty,Empty,Empty,Empty,singletonInd $ Ind3 x,singletonInd $ Ind3 y), SField z)) [(0,3,1),(3,0,1)] + +-- Area Metric + +-- | Flat area metric tensor. Can be obtained via the @'interJArea'@ intertwiner \( J_A^{abcd}\) as: \( N_A = J_A^{abcd} \left ( \eta_{ac} \eta_{bd} - \eta_{ad} \eta_{bc} - \epsilon_{abcd} \right ) \). +flatArea :: ATens 0 1 0 0 0 0 (SField Rational) +flatArea = fromListT6 $ map (\(i,v) -> ( (Empty, singletonInd $ Ind20 i, Empty, Empty, Empty, Empty), SField v)) + [(0,-1),(5,-1),(6,-1),(9,1),(11,-1),(12,-1),(15,1),(18,1),(20,1)] + + +--now the Area metric tensors + +trianMap2 :: M.Map (IndList 2 Ind3) (IndList 1 Ind9) +trianMap2 = M.fromList $ zip [ Append (Ind3 a) $ singletonInd $ Ind3 b | a <- [0..3], b <- [a..3] ] $ map (singletonInd . Ind9) [0..] + +trianMapArea :: M.Map (IndList 4 Ind3) (IndList 1 Ind20) +trianMapArea = M.fromList $ zip [ Append (Ind3 a) $ Append (Ind3 b) $ Append (Ind3 c) $ singletonInd $ Ind3 d | a <- [0..2], b <- [a+1..3], c <- [a..2], d <- [c+1..3], not $ a == c && b > d ] $ map (singletonInd . Ind20) [0..] + +jMult2 :: (Eq a) => IndList 2 a -> Rational +jMult2 (Append a (Append b Empty)) + | a == b = 1 + | otherwise = 1/2 + +jMult3 :: (Eq a) => IndList 3 a -> Rational +jMult3 (Append a (Append b (Append c Empty))) + | i == 1 = 1 + | i == 2 = 1/3 + | otherwise = 1/6 + where + i = length $ nub [a,b,c] + +jMultArea :: (Eq a) => IndList 4 a -> Rational +jMultArea (Append a (Append b (Append c (Append d Empty)))) + | a == c && b == d = 1/4 + | otherwise = 1/8 + +isZeroArea :: (Eq a) => IndList 4 a -> Bool +isZeroArea (Append a (Append b (Append c (Append d Empty)))) = a == b || c == d + +areaSign :: (Eq a, Ord a) => IndList 4 a -> Rational +areaSign (Append a (Append b (Append c (Append d Empty)))) = s1 * s2 + where + s1 = pairSign a b + s2 = pairSign c d + pairSign x y = if x < y then 1 else -1 + +canonicalizeArea :: (Eq a, Ord a) => IndList 4 a -> (IndList 4 a, Rational) +canonicalizeArea (Append a (Append b (Append c (Append d Empty)))) = (Append a' (Append b' (Append c' (Append d' Empty))),s) + where + s = areaSign (Append a (Append b (Append c (Append d Empty)))) + [[a',b'],[c',d']] = sort $ map sort [[a,b],[c,d]] + +-- | The tensor \(I^I_{ab} \) maps between covariant @'Ind9'@ indices and symmetric pairs of covariant @'Ind3'@ indices. +interI2 :: ATens 0 0 1 0 0 2 (SField Rational) +interI2 = fromListT6 $ fmap (fmap SField) $ filter (\(i,k) -> k /= 0) $ map (\x -> (x,f x)) inds + where + trian2 = trianMap2 + inds = [ (Empty, Empty, singletonInd $ Ind9 a, Empty, Empty, Append (Ind3 b) $ singletonInd $ Ind3 c) | a <- [0..9], b <- [0..3], c <- [0..3]] + f (_, _, ind1, _, _, ind2) + | ind1 == (M.!) trian2 (sortInd ind2) = 1 + | otherwise = 0 + +-- | The tensor \(J_I^{ab} \) maps between covariant @'Ind9'@ indices and pairs of covariant @'Ind3'@ indices. +interJ2 :: ATens 0 0 0 1 2 0 (SField Rational) +interJ2 = fromListT6 $ fmap (fmap SField) $ filter (\(i,k) -> k /= 0) $ map (\x -> (x,f x)) inds + where + trian2 = trianMap2 + inds = [ (Empty, Empty, Empty, singletonInd $ Ind9 a, Append (Ind3 b) $ singletonInd $ Ind3 c, Empty) | a <- [0..9], b <- [0..3], c <- [0..3]] + f (_, _, _, ind1, ind2, _) + | ind1 == (M.!) trian2 (sortInd ind2) = jMult2 ind2 + | otherwise = 0 + +-- | The tensor \( I^A_{abcd}\) maps between covariant @'Ind20'@ indices and blocks of @4@ of covariant @'Ind3'@ indices. +interIArea :: ATens 1 0 0 0 0 4 (SField Rational) +interIArea = fromListT6 $ fmap (fmap SField) $ filter (\(i,k) -> k /= 0) $ map (\x -> (x,f x)) inds + where + trianArea = trianMapArea + inds = [ (singletonInd (Ind20 a), Empty, Empty, Empty, Empty, Append (Ind3 b) $ Append (Ind3 c) $ Append (Ind3 d) $ singletonInd $ Ind3 e) | a <- [0..20], b <- [0..3], c <- [0..3], d <- [0..3], e <- [0..3], not (b == c || d == e)] + f (ind1, _, _, _, _, ind2) + | ind1 == (M.!) trianArea indArea = s + | otherwise = 0 + where + (indArea, s) = canonicalizeArea ind2 + +-- | The tensor \( J_A^{abcd}\) maps between contravariant @'Ind20'@ indices and blocks of @4@ of contravariant @'Ind3'@ indices. +interJArea :: ATens 0 1 0 0 4 0 (SField Rational) +interJArea = fromListT6 $ fmap (fmap SField) $ filter (\(i,k) -> k /= 0) $ map (\x -> (x,f x)) inds + where + trianArea = trianMapArea + inds = [ (Empty, singletonInd $ Ind20 a, Empty, Empty, Append (Ind3 b) $ Append (Ind3 c) $ Append (Ind3 d) $ singletonInd $ Ind3 e, Empty) | a <- [0..20], b <- [0..3], c <- [0..3], d <- [0..3], e <- [0..3], not (b == c || d == e)] + f (_, ind1, _, _, ind2, _) + | ind1 == (M.!) trianArea indArea = s * jMultArea indArea + | otherwise = 0 + where + (indArea, s) = canonicalizeArea ind2 + +-- | Can be obtained as: \(C^{Am}_{Bn} = -4 \cdot I^A_{nbcd} J_B^{mbcd} \) +-- +-- > interArea = SField (-4 :: Rational) &. contrATens3 (1,1) (contrATens3 (2,2) $ contrATens3 (3,3) $ interIArea &* interJArea +interArea :: ATens 1 1 0 0 1 1 (SField Rational) +interArea = SField (-4 :: Rational) &. contrATens3 (1,1) (contrATens3 (2,2) $ contrATens3 (3,3) $ interIArea &* interJArea) + +-- | Can be obtained as : \(K^{Im}_{Jn} = -2 \cdot I^I_{nb} J_J^{mb} \) +-- +-- > interMetric = SField (-2 :: Rational) &. contrATens3 (0,0) (interI2 &* interJ2) +interMetric :: ATens 0 0 1 1 1 1 (SField Rational) +interMetric = SField (-2 :: Rational) &. contrATens3 (0,0) (interI2 &* interJ2) + +-- | Is given by: \( C^m_{Bn} = C^{Am}_{Bn} N_A \) +-- +-- > flatInter = contrATens1 (0,1) $ interArea &* flatArea +flatInter :: ATens 0 1 0 0 1 1 (SField Rational) +flatInter = contrATens1 (0,1) $ interArea &* flatArea + +-- | Is given by: \( K^m_{Jn} = K^{Im}_{Jn} \eta_I\) +-- +-- > flatInterMetric = contrATens2 (0,1) $ interMetric &* etaAbs +flatInterMetric :: ATens 0 0 0 1 1 1 (SField Rational) +flatInterMetric = contrATens2 (0,1) $ interMetric &* etaAbs + +-- | Is given by: \( C_{An}^{Bm} \delta_p^q - \delta_A^B \delta_m^n \) +interEqn2 :: ATens 1 1 0 0 2 2 (SField Rational) +interEqn2 = int1 &- int2 + where + int1 = interArea &* delta3A + int2 = tensorTrans6 (0,1) (delta3A &* delta3A) &* delta20 + +-- | Is given by: \( K_{In}^{Jm} \delta_p^q - \delta_I^J \delta_m^n \) +interEqn2Metric :: ATens 0 0 1 1 2 2 (SField Rational) +interEqn2Metric = int1 &- int2 + where + int1 = interMetric &* delta3A + int2 = tensorTrans6 (0,1) (delta3A &* delta3A) &* delta9 + +-- | Is given by: \( C_{An}^{Bm} \delta_I^J + \delta_A^B K^{Im}_{Jn}\) +interEqn3 :: ATens 1 1 1 1 1 1 (SField Rational) +interEqn3 = int1 &+ int2 + where + int1 = interArea &* delta9 + int2 = interMetric &* delta20 + +-- | Is given by: \( K_{In}^{Jm} \delta_K^L + \delta_I^J K^{Km}_{Ln}\) +interEqn3Metric :: ATens 0 0 2 2 1 1 (SField Rational) +interEqn3Metric = int1 &+ int2 + where + int1 = interMetric &* delta9 + int2 = delta9 &* interMetric + +-- | Is given by: \( C_{An}^{B(m\vert} 2 J_I^{\vert p) q} - \delta^B_A J_I ^{pm} \delta_n^q \) +interEqn4 :: ATens 1 1 0 1 3 1 (SField Rational) +interEqn4 = block1 &- block2 + where + block1' = interJ2 &* interArea + block1 = block1' &+ tensorTrans5 (1,2) block1' + block2 = delta20 &* delta3A &* interJ2 + +-- | Is given by: \( K_{In}^{J(m\vert} 2 J_L^{\vert p) q} - \delta^I_J J_L ^{pm} \delta_n^q \) +interEqn4Metric :: ATens 0 0 1 2 3 1 (SField Rational) +interEqn4Metric = block1 &- block2 + where + block1' = interJ2 &* interMetric + block1 = block1' &+ tensorTrans5 (1,2) block1' + block2 = delta3A &* interJ2 &* delta9 + +-- | Is given by: \( C_{An}^{B(m\vert} J_I^{\vert p q )} \) +interEqn5 :: ATens 1 1 0 1 3 1 (SField Rational) +interEqn5 = cyclicSymATens5 [0,1,2] intA1 + where + intA1 = interJ2 &* interArea + +--derivative indices are left metric indices right !! + +-- | Is given by: \( K_{In}^{J(m\vert} J_L^{\vert p q )} \) +interEqn5Metric :: ATens 0 0 1 2 3 1 (SField Rational) +interEqn5Metric = cyclicSymATens5 [0,1,2] intA1 + where + intA1 = interJ2 &* interMetric + + +--generic Ansätze up to prolongation order 2 + +--A +-- | +-- prop> tensorRank6' generic4Ansatz = 21 +generic4Ansatz :: ATens 1 0 0 0 0 0 (AnsVar (SField Rational)) +generic4Ansatz = fromListT6 list + where + list = [ let varMap = AnsVar $ I.singleton (dof a) $ SField 1 + in ((singletonInd (Ind20 $ a-1), Empty, Empty, Empty, Empty, Empty), varMap) + | a <- [1..21] ] + dof a = a + +--Aa +-- | +-- prop> tensorRank6' generic5Ansatz = 21*4 +generic5Ansatz :: ATens 1 0 0 0 1 0 (AnsVar (SField Rational)) +generic5Ansatz = fromListT6 list + where + list = [ let varMap = AnsVar $ I.singleton (dof a p) $ SField 1 + in ((singletonInd (Ind20 $ a-1), Empty, Empty, Empty, singletonInd (Ind3 $ p-1 ), Empty), varMap) + | a <- [1..21], p <- [1..4] ] + dof a p = 1 + 21 + 4*(a-1) + (p-1) + +--AI +-- | +-- prop> tensorRank6' generic5Ansatz = 21*10 +generic6Ansatz :: ATens 1 0 1 0 0 0 (AnsVar (SField Rational)) +generic6Ansatz = fromListT6 list + where + list = [ let varMap = AnsVar $ I.singleton (dof a i) $ SField 1 + in ((singletonInd (Ind20 $ a-1), Empty, singletonInd (Ind9 $ i-1), Empty, Empty, Empty), varMap) + | a <- [1..21], i <- [1..10] ] + dof a i = 1 + 21 + 84 + 10*(a-1) + (i-1) +--AB +-- | +-- prop> tensorRank6' generic8Ansatz = 21*22/2 +generic8Ansatz :: ATens 2 0 0 0 0 0 (AnsVar (SField Rational)) +generic8Ansatz = fromListT6 list + where + list = [ let varMap = AnsVar $ I.singleton (dof a b) $ SField 1 + in ((Append (Ind20 $ a-1) $ singletonInd (Ind20 $ b-1), Empty, Empty, Empty, Empty, Empty), varMap) + | a <- [1..21], b <- [1..21] ] + dof a b = let a' = min a b + b' = max a b + in trian M.! [a',b'] + 315 + trian = M.fromList $ zip j k + where + j = [ [a,b] | a <- [1..315], b <- [a..315] ] + k = [1..] + +--ABb +-- | +-- prop> tensorRank6' generic21Ansatz = 21*21*4 +generic9Ansatz :: ATens 2 0 0 0 1 0 (AnsVar (SField Rational)) +generic9Ansatz = fromListT6 list + where + list = [ let varMap = AnsVar $ I.singleton (dof a b p) $ SField 1 + in ((Append (Ind20 $ a-1) $ singletonInd (Ind20 $ b-1), Empty, Empty, Empty, singletonInd (Ind3 $ p-1), Empty), varMap) + | a <- [1..21], b <- [1..21], p <- [1..4]] + dof a b p = trian M.! [a,1 + 21 + 4*(b-1) + (p-1)] + 315 + trian = M.fromList $ zip j k + where + j = [ [a,b] | a <- [1..315], b <- [a..315] ] + k = [1..] + +--AaBb +-- | +-- prop> tensorRank6' generic5Ansatz = 84*85/2 +generic10_1Ansatz :: ATens 2 0 0 0 2 0 (AnsVar (SField Rational)) +generic10_1Ansatz = fromListT6 list + where + list = [ let varMap = AnsVar $ I.singleton (dof a b p q) $ SField 1 + in ((Append (Ind20 $ a-1) $ singletonInd (Ind20 $ b-1), Empty, Empty, Empty, Append (Ind3 $ p-1) $ singletonInd (Ind3 $ q-1), Empty), varMap) + | a <- [1..21], b <- [1..21], p <- [1..4], q <- [1..4]] + dof a b p q = let + a' = min (1 + 21 + 4*(a-1) + (p-1)) (1 + 21 + 4*(b-1) + (q-1)) + b' = max (1 + 21 + 4*(a-1) + (p-1)) (1 + 21 + 4*(b-1) + (q-1)) + in trian M.! [a',b'] + 315 + trian = M.fromList $ zip j k + where + j = [ [a,b] | a <- [1..315], b <- [a..315] ] + k = [1..] + +--ABI +-- | +-- prop> tensorRank6' generic5Ansatz = 21*21*10 +generic10_2Ansatz :: ATens 2 0 1 0 0 0 (AnsVar (SField Rational)) +generic10_2Ansatz = fromListT6 list + where + list = [ let varMap = AnsVar $ I.singleton (dof a b i) $ SField 1 + in ((Append (Ind20 $ a-1) $ singletonInd (Ind20 $ b-1), Empty, singletonInd (Ind9 $ i -1), Empty, Empty, Empty), varMap) + | a <- [1..21], b <- [1..21], i <- [1..10]] + dof a b i = trian M.! [a,1 + 105 + 10*(b-1) + (i-1)] + 315 + trian = M.fromList $ zip j k + where + j = [ [a,b] | a <- [1..315], b <- [a..315] ] + k = [1..] + +--ApBI +-- | +-- prop> tensorRank6' generic5Ansatz = 21*21*10*4 +generic11Ansatz :: ATens 2 0 1 0 1 0 (AnsVar (SField Rational)) +generic11Ansatz = fromListT6 list + where + list = [ let varMap = AnsVar $ I.singleton (dof a b i p) $ SField 1 + in ((Append (Ind20 $ a-1) $ singletonInd (Ind20 $ b-1), Empty, singletonInd (Ind9 $ i -1), Empty, singletonInd (Ind3 $ p-1), Empty), varMap) + | a <- [1..21], b <- [1..21], i <- [1..10], p <- [1..4]] + dof a b i p = trian M.! [1 + 21 + 4*(a-1) + (p-1),1 + 105 + 10*(b-1) + (i-1)] + 315 + trian = M.fromList $ zip j k + where + j = [ [a,b] | a <- [1..315], b <- [a..315] ] + k = [1..] + +--AIBJ +-- | +-- prop> tensorRank6' generic5Ansatz = 210*211/2 +generic12_1Ansatz :: ATens 2 0 2 0 0 0 (AnsVar (SField Rational)) +generic12_1Ansatz = fromListT6 list + where + list = [ let varMap = AnsVar $ I.singleton (dof a b i j) $ SField 1 + in ((Append (Ind20 $ a-1) $ singletonInd (Ind20 $ b-1), Empty, Append (Ind9 $ i-1) $ singletonInd (Ind9 $ j -1), Empty, Empty, Empty), varMap) + | a <- [1..21], b <- [1..21], i <- [1..10], j <- [1..10]] + dof a b i j = let + a' = min (1 + 105 + 10*(a-1) + (i-1)) (1 + 105 + 10*(b-1) + (j-1)) + b' = max (1 + 105 + 10*(a-1) + (i-1)) (1 + 105 + 10*(b-1) + (j-1)) + in trian M.! [a',b'] + 315 + trian = M.fromList $ zip j k + where + j = [ [a,b] | a <- [1..315], b <- [a..315] ] + k = [1..] + +-- Random Tensors + +randRats :: IO [Rational] +randRats = do + gen <- newTFGen + let randList' = randomRs (-10000,10000) gen :: [Int] + let randList = map fromIntegral randList' + return randList + +randArea :: IO (ATens 0 1 0 0 0 0 (SField Rational)) +randArea = do gen <- newTFGen + randList <- randRats + let inds = map (\i -> (Empty, singletonInd $ Ind20 i, Empty, Empty, Empty, Empty)) [0..20] + return $ fromListT6 $ zip inds $ fmap SField randList + +randAxon :: IO (ATens 0 1 0 0 0 0 (SField Rational)) +randAxon = do gen <- newTFGen + randList <- randRats + let inds = map (\i -> (Empty, singletonInd $ Ind20 i, Empty, Empty, Empty, Empty)) [5,9,12] + let randInd = SField $ head randList + let assocs = zip inds [-randInd, randInd, -randInd] + let tens = fromListT6 assocs + return tens + +randFlatArea :: IO (ATens 0 1 0 0 0 0 (SField Rational)) +randFlatArea = do gen <- newTFGen + randList <- randRats + let assocs = map (\(i,v) -> ( (Empty, singletonInd $ Ind20 i, Empty, Empty, Empty, Empty), SField v)) + [(0, -1 * head randList),(5, randList !! 3),(6, -1 * randList !! 1),(9, -1 * randList !! 4),(11, -1 * randList !! 2),(12, randList !! 5),(15, head randList),(18, randList !! 1),(20, randList !! 2)] + let tens = fromListT6 assocs + return tens + + +randAreaDerivative1 :: IO (ATens 0 1 0 0 0 1 (SField Rational)) +randAreaDerivative1 = do gen <- newTFGen + randList <- randRats + let inds = [ f a p | a <- [0..20], p <- [0..3]] + return $ fromListT6 $ zip inds $ fmap SField randList + where f a p = (Empty, singletonInd $ Ind20 a, Empty, Empty, Empty, singletonInd $ Ind3 p) + + +randAreaDerivative2 :: IO (ATens 0 1 0 1 0 0 (SField Rational)) +randAreaDerivative2 = do gen <- newTFGen + randList <- randRats + let inds = [ f a i | a <- [0..20], i <- [0..9]] + return $ fromListT6 $ zip inds $ fmap SField randList + where f a i = (Empty, singletonInd $ Ind20 a, Empty, singletonInd $ Ind9 i, Empty, Empty) + + +randMetric :: IO (ATens 0 0 0 1 0 0 (SField Rational)) +randMetric = do gen <- newTFGen + randList <- randRats + let inds = map (\i -> (Empty, Empty, Empty, singletonInd $ Ind9 i, Empty, Empty)) [0..20] + return $ fromListT6 $ zip inds $ fmap SField randList diff --git a/src/Math/Tensor/Examples/Gravity/DiffeoSymEqns.hs b/src/Math/Tensor/Examples/Gravity/DiffeoSymEqns.hs new file mode 100644 --- /dev/null +++ b/src/Math/Tensor/Examples/Gravity/DiffeoSymEqns.hs @@ -0,0 +1,466 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Math.Tensor.Examples.Gravity.DiffeoSymEqns +-- Copyright : (c) 2019 Tobias Reinhart and Nils Alex +-- License : MIT +-- Maintainer : tobi.reinhart@fau.de, nils.alex@fau.de +-- +-- +-- This module collects several tensorial equations. +-- These equations arise in the research topic of perturbative constructive gravity and are used there to encode perturbative diffeomorphism invariance. +-- +-- Providing further usage examples of the sparse-tensor package the equations included here nicely illustrate the syntax that is used when entering tensors. +-- They also show how the sparse tensor package can be used to manipulate not only tenors but linear tensorial equations. The sparse-tensor package can for instance be used to extract the information that is contained in such a tensorial equation in matrix form. This then obviously allows one +-- to computate the rank of the linear tensorial equation or even explicitly solve it. +-- +-- +-- All equations that are contained in this module are functions that take possibly several tensors of type @'ATens' 'AnsVarR'@ as input. These tensors then represent +-- the individual unknown tensors in the equation. The output that is computed by the functions is also of this type. +-- +-- When illustrating how the individual such equations that are included in this module are defined we will use again the same convention as in the "Math.Tensor.Examples.Gravity" module, i.e. we label indices of type @'Ind20'@ by \(A,B,C,D,...\), indices of type +-- \(I,J,K,L,...\) and spacetime indices of type @'ind3'@ are labeled by \(a,b,c,d,...\). Hence a general such tensor is displayed as \(T^{A_1...A_m I_1...I_r a_1...a_p}_{B_1...B_n J_1...J_s b_1...b_s} \). +-- Such a tensor then has the type @'ATens' m n r s p q@. +----------------------------------------------------------------------------- +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +module Math.Tensor.Examples.Gravity.DiffeoSymEqns ( +-- * Lorentz Invariance +-- ** Area Metric +-- | The following equations encode the requirement that the input tensors are Lorentz invariant. They can be used to verify the Lorentz invariant tensors that are obtained by +-- the "Math.Tensor.LorentzGenerator" module. If the input tensor is Lorentz invariant the functions return a tensor with all values being zero, and thus for instance applying @'tensorRank6''@ to these +-- returns zero. +ansatzA, ansatzAI, ansatzAB, ansatzAaBb, ansatzABI, ansatzAIBJ, ansatzABC, ansatzABCI, ansatzABbCc, ansatzAaBbCI, ansatzABICJ, +ansatzAIBJCK, ansatzABCD, ansatzABCDJ, ansatzABCcDd, +-- * Perturbative Diffeomorphism Equivariance +-- ** Area Metric +-- | The following equations can be used with the Lorentz invariant ansätze for the area metric \(G_A = J_A^{abcd}G_{abcd}\) with the symmetries \(G_{abcd} = G_{cdab} = -G_{bacd} \) as input tensors. +-- In the following documentation these input tensors are labeled as \(a_0,a^{A}, a^{AI}, a^{AB},\) etc. For the definition of the further included tensors see "Math.Tensor.Examples.Gravity". +eqn1, eqn3, eqn1A, eqn1AI, eqn2Aa, eqn3A, eqn1AB, eqn1ABI, eqn1AaBb, eqn2ABb, eqn3AB, +-- ** Metric +-- | The following equations can be used with the Lorentz invariant ansätze for the a traditional metric metric \(g_I = J_I^{ab}g_{ab}\) as input. +-- In the following documentation these input tensors are labeled as \(a_0,a^{A}, a^{AJ}, a^{AB},\) etc. Care must be taken as for the case of the metric equations all indices that are labeled by \(A,B,C,D,... \) are also of type @'Ind9'@, +-- but are distinguished from the indices labeled by \(I,J,K,L,...\) as they describe the metric components and the latter ones describe symmetric spacetime derivative pairs. +-- For the definition of the further included tensors see "Math.Tensor.Examples.Gravity". +eqn1Met, eqn3Met, eqn2AaMet, eqn3AMet, eqn1AMet, eqn1AIMet, eqn1ABMet, eqn1ABIMet, eqn1AaBbMet, eqn2ABbMet, eqn3ABMet +) where + +import Math.Tensor +import Math.Tensor.Examples.Gravity + +import qualified Data.IntMap.Strict as I + +--the ansatz integrability conditions (when perturbing around eta*eta-eta*eta-epsilon) + +ansatzA :: ATens 1 0 0 0 0 0 AnsVarR -> ATens 1 0 0 0 2 0 AnsVarR +ansatzA ans4 = aSymATens5 (0,1) $ contrATens1 (0,0) $ contrATens3 (1,0) $ ans4 &* interArea &* invEtaA + +ansatzAa :: ATens 1 0 0 0 1 0 AnsVarR -> ATens 1 0 0 0 3 0 AnsVarR +ansatzAa ans5 = aSymATens5 (0,2) $ contrATens1 (0,0) $ contrATens3 (0,0) $ contrATens3 (3,0) $ ans5 &* interEqn2 &* invEtaA + +ansatzAI :: ATens 1 0 1 0 0 0 AnsVarR -> ATens 1 0 1 0 2 0 AnsVarR +ansatzAI ans6 = aSymATens5 (0,1) $ contrATens1 (0,0) $ contrATens2 (0,0) $ contrATens3 (1,0) $ ans6 &* interEqn3 &* invEtaA + +ansatzAB :: ATens 2 0 0 0 0 0 AnsVarR -> ATens 2 0 0 0 2 0 AnsVarR +ansatzAB ans8 = symATens1 (0,1) $ aSymATens5 (0,1) $ contrATens1 (0,0) $ contrATens3 (1,0) $ ans8 &* interArea &* invEtaA + +ansatzAaBb :: ATens 2 0 0 0 2 0 AnsVarR -> ATens 2 0 0 0 4 0 AnsVarR +ansatzAaBb ans10_1 = block1 &+ block2 + where + block1 = aSymATens5 (1,3) $ contrATens1 (0,0) $ contrATens3 (0,0) $ contrATens3 (4,0) $ ans10_1 &* interEqn2 &* invEtaA + block2 = tensorTrans1 (0,1) $ tensorTrans5 (0,2) block1 + +ansatzABI :: ATens 2 0 1 0 0 0 AnsVarR -> ATens 2 0 1 0 2 0 AnsVarR +ansatzABI ans10_2 = block1 &+ block2 + where + block1 = aSymATens5 (0,1) $ contrATens1 (1,0) $ contrATens2 (0,0) $ contrATens3 (1,0) $ ans10_2 &* interEqn3 &* invEtaA + block2 = tensorTrans1 (0,1) $ aSymATens5 (0,1) $ contrATens1 (0,0) $ contrATens3 (1,0) $ ans10_2 &* interArea &* invEtaA + +ansatzAIBJ :: ATens 2 0 2 0 0 0 AnsVarR -> ATens 2 0 2 0 2 0 AnsVarR +ansatzAIBJ ans12_1 = block1 &+ block2 + where + block1 = aSymATens5 (0,1) $ contrATens1 (0,0) $ contrATens2 (0,0) $ contrATens3 (1,0) $ ans12_1 &* interEqn3 &* invEtaA + block2 = tensorTrans1 (0,1) $ tensorTrans3 (0,1) block1 + +ansatzABC :: ATens 3 0 0 0 0 0 AnsVarR -> ATens 3 0 0 0 2 0 AnsVarR +ansatzABC ans12 = block1 &+ block2 &+ block3 + where + block1 = aSymATens5 (0,1) $ contrATens1 (0,0) $ contrATens3 (1,0) $ ans12 &* interArea &* invEtaA + block2 = tensorTrans1 (1,2) block1 + block3 = tensorTrans1 (0,2) block1 + +ansatzABbCc :: ATens 3 0 0 0 2 0 AnsVarR -> ATens 3 0 0 0 4 0 AnsVarR +ansatzABbCc ans14_1 = block1 &+ block2 &+ block3 + where + block1 = aSymATens5 (1,3) $ contrATens1 (1,0) $ contrATens3 (0,0) $ contrATens3 (4,0) $ ans14_1 &* interEqn2 &* invEtaA + block2 = tensorTrans1 (1,2) $ tensorTrans5 (0,2) block1 + block3 = tensorTrans5 (1,2) $ tensorTrans1 (0,1) $ tensorTrans1 (1,2) $ aSymATens5 (2,3) $ contrATens1 (0,0) $ contrATens3 (3,0) $ ans14_1 &* interArea &* invEtaA + +ansatzABCI :: ATens 3 0 1 0 0 0 AnsVarR -> ATens 3 0 1 0 2 0 AnsVarR +ansatzABCI ans14_2 = block1 &+ block2 + where + block1 = symATens1 (0,2) $ contrATens1 (0,0) $ ans14_2 &* aSymATens5 (0,1) (contrATens3 (1,0) $ interArea &* invEtaA) + block2 = tensorTrans1 (1,2) $ contrATens2 (0,0) $ contrATens1 (2,0) $ ans14_2 &* aSymATens5 (0,1) (contrATens3 (1,0) $ interEqn3 &* invEtaA) + +ansatzAaBbCI :: ATens 3 0 1 0 2 0 AnsVarR -> ATens 3 0 1 0 4 0 AnsVarR +ansatzAaBbCI ans16_1 = block1 &+ block2 &+ block3 + where + block1 = aSymATens5 (1,3) $ contrATens1 (0,0) $ contrATens3 (0,0) $ contrATens3 (4,0) $ ans16_1 &* interEqn2 &* invEtaA + block2 = tensorTrans1 (0,2) $ tensorTrans5 (0,2) block1 + block3 = tensorTrans5 (1,2) $ tensorTrans1 (1,2) $ aSymATens5 (2,3) $ contrATens2 (0,0) $ contrATens1 (2,0) $ contrATens3 (4,0) $ ans16_1 &* interEqn3 &* invEtaA + +ansatzABICJ :: ATens 3 0 2 0 0 0 AnsVarR -> ATens 3 0 2 0 2 0 AnsVarR +ansatzABICJ ans16_2 = block1 &+ block2 &+ block3 + where + block1 = aSymATens5 (0,1) $ contrATens1 (1,0) $ contrATens2 (0,0) $ contrATens3 (1,0) $ ans16_2 &* interEqn3 &* invEtaA + block2 = tensorTrans1 (1,2) $ tensorTrans3 (0,1) block1 + block3 = tensorTrans3 (0,1) $ tensorTrans1 (0,2) $ aSymATens5 (0,1) $ contrATens1 (0,0) $ contrATens3 (1,0) $ ans16_2 &* interArea &* invEtaA + +ansatzAIBJCK :: ATens 3 0 3 0 0 0 AnsVarR -> ATens 3 0 3 0 2 0 AnsVarR +ansatzAIBJCK ans18 = block1 &+ block2 &+ block3 + where + block1 = contrATens1 (0,0) $ contrATens2 (0,0) $ ans18 &* removeZeros6 (aSymATens5 (0,1) $ contrATens3 (1,0) $ interEqn3 &* invEtaA) + block2 = tensorTrans1 (0,2) $ tensorTrans3 (0,2) block1 + block3 = tensorTrans1 (1,2) $ tensorTrans3 (1,2) block1 + +ansatzABCD :: ATens 4 0 0 0 0 0 AnsVarR -> ATens 4 0 0 0 2 0 AnsVarR +ansatzABCD ans16 = block1 &+ block2 &+ block3 &+ block4 + where + block1 = aSymATens5 (0,1) $ contrATens1 (0,0) $ contrATens3 (1,0) $ ans16 &* interArea &* invEtaA + block2 = tensorTrans1 (0,3) block1 + block3 = tensorTrans1 (1,3) block1 + block4 = tensorTrans1 (2,3) block1 + +ansatzABCDJ :: ATens 4 0 1 0 0 0 AnsVarR -> ATens 4 0 1 0 2 0 AnsVarR +ansatzABCDJ ans18_2 = block1 &+ block2 &+ block3 &+ block4 + where + block1 = aSymATens5 (0,1) $ contrATens1 (0,0) $ contrATens3 (1,0) $ ans18_2 &* interArea &* invEtaA + block2 = tensorTrans1 (0,3) block1 + block3 = tensorTrans1 (1,3) block1 + block4 = tensorTrans1 (2,3) $ aSymATens5 (0,1) $ contrATens2 (0,0) $ contrATens1 (3,0) $ contrATens3 (1,0) $ ans18_2 &* interEqn3 &* invEtaA + +ansatzABCcDd :: ATens 4 0 0 0 2 0 AnsVarR -> ATens 4 0 0 0 4 0 AnsVarR +ansatzABCcDd ans18_3 = block1 &+ block2 &+ block3 &+ block4 + where + block1 = contrATens1 (0,0) $ ans18_3 &* aSymATens5 (0,1) (contrATens3 (1,0) $ interArea &* invEtaA) + block2 = tensorTrans1 (0,3) block1 + block3' = contrATens3 (0,0) $ contrATens1 (2,0) $ ans18_3 &* aSymATens5 (0,2) (contrATens3 (2,0) $ interEqn2 &* invEtaA) + block3 = resortTens1 [3,0,2,1] $ resortTens5 [1,2,0,3] block3' + block4 = tensorTrans1 (1,2) $ tensorTrans5 (0,1) block3 + + +--the mass sub graph, i.e no derivatives + +--order 0 + +-- | The equation is given by: \(0 = a^A C_{An}^{Bm}N_B + a_0 \delta^m_n \). +eqn1 :: ATens 0 0 0 0 0 0 AnsVarR -> ATens 1 0 0 0 0 0 AnsVarR -> ATens 0 0 0 0 1 1 AnsVarR +eqn1 ans0 ans4 = contrATens1 (0,0) (ans4 &* flatInter) &+ (ans0 &* delta3A) + +--order 1 + +-- | The equation is given by: \( 0 = a^A C_{An}^{Bm} + 2 a^{AB}C_{An}^{Cm}N_C + a^B\delta^m_n \). +eqn1A :: ATens 1 0 0 0 0 0 AnsVarR -> ATens 2 0 0 0 0 0 AnsVarR -> ATens 1 0 0 0 1 1 AnsVarR +eqn1A ans4 ans8 = block1 &+ block2 &+ block3 + where + block1 = contrATens1 (0,0) $ ans4 &* interArea + block2 = contrATens1 (0,0) $ ans8 &* flatInter + block3 = ans4 &* delta3A + +--order 2 + +-- | The equation is given by: \( 0 = 2 a^{AC}C_{An}^{Bm} + 2a^{AB}C_{An}^{Cm} + 6 a^{ABC}C_{An}^{Dm} N_D + 2a^{BC} \delta^m_n \) +eqn1AB :: ATens 2 0 0 0 0 0 AnsVarR -> ATens 3 0 0 0 0 0 AnsVarR -> ATens 2 0 0 0 1 1 AnsVarR +eqn1AB ans8 ans12 = block1 &+ block2 &+ block3 + where + block1 = symATens1 (0,1) $ contrATens1 (0,0) $ ans8 &* interArea + block2 = contrATens1 (0,0) $ ans12 &* flatInter + block3 = ans8 &* delta3A + +--order 3 + +eqn1ABC :: ATens 3 0 0 0 0 0 AnsVarR -> ATens 4 0 0 0 0 0 AnsVarR -> ATens 3 0 0 0 1 1 AnsVarR +eqn1ABC ans12 ans16 = block1 &+ block2 &+ block3 &+ block4 + where + block1 = contrATens1 (0,0) $ ans12 &* interArea + block2 = tensorTrans1 (0,2) block1 + block3 = tensorTrans1 (1,2) block1 + block4 = contrATens1 (0,0) $ ans16 &* flatInter + +--the sub-graph with 2 total derivative + +--order 0 + +-- | The equation is given by: \( 0 = a^{AI}C_{An}^{B(m\vert }N_B J^{\vert pq)}_I \). +eqn3 :: ATens 1 0 1 0 0 0 AnsVarR -> ATens 0 0 0 0 3 1 AnsVarR +eqn3 ans6 = contrATens2 (0,0) $ contrATens1 (0,0) $ ans6 &* contrATens1 (0,1) (interEqn5 &* flatArea) + +--order 1 + +-- | The equation is given by: \( 0 = a^{AI}\left [C_{An}^{Bm}\delta^I _J- 2 \delta^A_B J_I^{pm}I^J_{pn} \right ] + a^{ABJ}C_{An}^{Cm}N_C + a^{BJ} \delta^m_n \). +eqn1AI :: ATens 1 0 1 0 0 0 AnsVarR -> ATens 2 0 1 0 0 0 AnsVarR -> ATens 1 0 1 0 1 1 AnsVarR +eqn1AI ans6 ans10_2 = block1 &+ block2 &+ block3 + where + block1 = contrATens1 (0,0) $ ans10_2 &* flatInter + block2 = contrATens2 (0,0) $ contrATens1 (0,0) $ ans6 &* interEqn3 + block3 = ans6 &* delta3A + +-- | The equation is given by: \( 0 = 2a^{A(p\vert Bq}C_{An}^{C\vert m)}N_C + a^{AI} \left [C_{An}^{B(m\vert} 2 J_{I}^{\vert p)q} - \delta_A^BJ_I^{pm}\delta^q_n \right ] \). +eqn2Aa :: ATens 1 0 1 0 0 0 AnsVarR -> ATens 2 0 0 0 2 0 AnsVarR -> ATens 1 0 0 0 3 1 AnsVarR +eqn2Aa ans6 ans10_1 = block1 &+ block2 + where + block1 = symATens5 (1,2) $ contrATens1 (1,0) $ ans10_1 &* flatInter + block2 = symATens5 (1,2) $ contrATens2 (0,0) $ contrATens1 (0,0) $ ans6 &* interEqn4 + +-- | The equation is given by: \( 0 = a^{BAI}C_{An}^{C(m\vert}N_CJ_I^{\vert pq)} + a^{AI}C_{An}^{B(m \vert} J_I^{\vert pq)} \). +eqn3A :: ATens 1 0 1 0 0 0 AnsVarR -> ATens 2 0 1 0 0 0 AnsVarR -> ATens 1 0 0 0 3 1 AnsVarR +eqn3A ans6 ans10_2 = block1 &+ block2 + where + block1 = contrATens1 (0,0) $ contrATens2 (0,0) $ ans6 &* interEqn5 + block2 = contrATens2 (0,0) $ contrATens1 (1,0) $ contrATens1 (2,1) $ ans10_2 &* interEqn5 &* flatArea + +--order 2 + +-- | The equation is given by: \( 0 = a^{CAI} \left [C_{An}^{Bm}\delta^I _J- 2 \delta^A_B J_I^{pm}I^J_{pn} \right ] + 2 a^{ACBJ} C_{An}^{Dm} N_D + a^{CBJ} \delta ^m _n \). +eqn1ABI :: ATens 2 0 1 0 0 0 AnsVarR -> ATens 3 0 1 0 0 0 AnsVarR -> ATens 2 0 1 0 1 1 AnsVarR +eqn1ABI ans10_2 ans14_2 = block1 &+ block2 &+ block3 &+ block4 + where + block1 = contrATens1 (0,0) $ ans14_2 &* flatInter + block2 = contrATens1 (1,0) $ interArea &* ans10_2 + block3 = contrATens2 (0,0) $ contrATens1 (1,0) $ ans10_2 &* interEqn3 + block4 = ans10_2 &* delta3A + +-- | The equation is given by: \( 0 = 2 a^{BCAI}C_{An}^{D(m \vert}N_DJ_I^{\vert pq)} + a^{CAI}C_{An}^{B(m \vert} J_I^{\vert pq)} \). +eqn3AB :: ATens 2 0 1 0 0 0 AnsVarR -> ATens 3 0 1 0 0 0 AnsVarR -> ATens 2 0 0 0 3 1 AnsVarR +eqn3AB ans10_2 ans14_2 = block1 &+ block2 + where + block1 = symATens1 (0,1) $ contrATens2 (0,0) $ contrATens1 (1,0) $ ans10_2 &* interEqn5 + block2 = contrATens2 (0,0) $ contrATens1 (2,0) $ ans14_2 &* contrATens1 (0,1) (interEqn5 &* flatArea) + +-- | The equation is given by: \( 0 = 2 a^{C A(p \vert B q} C_{An}^{D \vert m )} N_D + a^{CAI} \left [C_{An}^{B(m\vert} 2 J_{I}^{\vert p)q} - \delta_A^BJ_I^{pm}\delta^q_n \right ] \). +eqn2ABb :: ATens 2 0 0 0 2 0 AnsVarR -> ATens 2 0 1 0 0 0 AnsVarR -> ATens 3 0 0 0 2 0 AnsVarR -> ATens 2 0 0 0 3 1 AnsVarR +eqn2ABb ans10_1 ans10_2 ans14_1 = block1 &+ block2 &+ block3 + where + block1 = symATens5 (0,2) $ contrATens1 (1,0) $ ans14_1 &* flatInter + block2' = tensorTrans5 (0,1) $ contrATens2 (0,0) $ contrATens1 (1,0) $ ans10_2 &* interEqn4 + block2 = symATens5 (0,2) block2' + block3 = tensorTrans1 (0,1) $ symATens5 (0,2) $ contrATens1 (0,0) $ ans10_1 &* interArea + +-- | The equation is given by: \( 0 = 2 a^{BqCr} \left [ C_{An}^{Bm} \delta ^q_p - \delta^B_A \delta^m_n \right ] +2 a^{A Bq Cr} C_{An}^{Dm} N_D + 2 a^{BqCr} \delta^m_n \). +eqn1AaBb :: ATens 2 0 0 0 2 0 AnsVarR -> ATens 3 0 0 0 2 0 AnsVarR -> ATens 2 0 0 0 3 1 AnsVarR +eqn1AaBb ans10_1 ans14_1 = block1 &+ block2 &+ block3 &+ block4 + where + block1 = tensorTrans5 (1,2) $ contrATens1 (0,0) $ ans14_1 &* flatInter + block2 = contrATens1 (0,0) $ contrATens3 (0,1) $ ans10_1 &* interEqn2 + block3 = tensorTrans1 (0,1) $ tensorTrans5 (0,2) block2 + block4 = tensorTrans5 (1,2) $ ans10_1 &* delta3A + +--order 2: further equations of the next order + + +eqn1ABbCc :: ATens 3 0 0 0 2 0 AnsVarR -> ATens 4 0 0 0 2 0 AnsVarR -> ATens 3 0 0 0 3 1 AnsVarR +eqn1ABbCc ans14_1 ans18_3 = block1 &+ block2 &+ block3 &+ block4 + where + block1 = tensorTrans5 (1,2) $ contrATens1 (0,0) $ ans18_3 &* flatInter + block2 = tensorTrans5 (0,1) $ contrATens1 (1,0) $ interArea &* ans14_1 + block3 = contrATens3 (0,1) $ contrATens1 (1,0) $ ans14_1 &* interEqn2 + block4 = tensorTrans1 (1,2) $ tensorTrans5 (0,2) block3 + +eqn1ABCI :: ATens 3 0 1 0 0 0 AnsVarR -> ATens 4 0 1 0 0 0 AnsVarR -> ATens 3 0 1 0 1 1 AnsVarR +eqn1ABCI ans14_2 ans18_2 = block1 &+ block2 &+ block3 + where + block1 = contrATens1 (0,0) $ ans18_2 &* flatInter + block2 = symATens1 (0,1) $ contrATens1 (1,0) $ interArea &* ans14_2 + block3 = contrATens2 (0,0) $ contrATens1 (2,0) $ ans14_2 &* interEqn3 + +eqn2ABCc :: ATens 3 0 0 0 2 0 AnsVarR -> ATens 3 0 1 0 0 0 AnsVarR -> ATens 4 0 0 0 2 0 AnsVarR -> ATens 3 0 0 0 3 1 AnsVarR +eqn2ABCc ans14_1 ans14_2 ans18_3 = block1 &+ block2 &+ block3 + where + block1 = symATens5 (0,2) $ contrATens1 (2,0) $ ans18_3 &* flatInter + block2 = symATens5 (0,2) $ tensorTrans5 (0,1) $ contrATens2 (0,0) $ contrATens1 (2,0) $ ans14_2 &* interEqn4 + block3 = symATens1 (0,1) $ tensorTrans1 (1,2) $ symATens5 (0,2) $ contrATens1 (1,0) $ ans14_1 &* interArea + +eqn3ABC :: ATens 3 0 1 0 0 0 AnsVarR -> ATens 4 0 1 0 0 0 AnsVarR -> ATens 3 0 0 0 3 1 AnsVarR +eqn3ABC ans14_2 ans18_2 = block1 &+ block2 &+ block3 &+ block4 + where + block1 = contrATens2 (0,0) $ contrATens1 (3,0) $ ans18_2 &* contrATens1 (0,1) (interEqn5 &* flatArea) + block2 = contrATens2 (0,0) $ contrATens1 (2,0) $ ans14_2 &* interEqn5 + block3 = tensorTrans1 (0,2) block2 + block4 = tensorTrans1 (1,2) block2 + +--the sub graph with a total of 4 derivatives: further equations that contain more derivatives + +eqn3AI :: ATens 2 0 2 0 0 0 AnsVarR -> ATens 1 0 1 0 3 1 AnsVarR +eqn3AI ans12_1 = contrATens2 (0,0) $ contrATens1 (0,0) $ ans12_1 &* contrATens1 (0,1) (interEqn5 &* flatArea) + + +--tensor trafo equations for rom calculations (use density or scalar) +--ansätze must be computed from lagrangian ansätze + +--linear order + +linMass :: ATens 2 0 0 0 0 0 AnsVarR -> ATens 1 0 0 0 1 1 AnsVarR +linMass ans8 = tens1 + where + tens1 = contrATens1 (1,0) $ ans8 &* flatInter + +linKin :: ATens 2 0 0 0 2 0 AnsVarR -> ATens 1 0 0 0 3 1 AnsVarR +linKin ans10 = tens1 + where + tens1 = cyclicSymATens5 [0,1,2] $ contrATens1 (1,0) $ ans10 &* flatInter + +--quadratic order + +quadMass :: ATens 3 0 0 0 0 0 AnsVarR -> ATens 2 0 0 0 0 0 AnsVarR -> ATens 2 0 0 0 1 1 AnsVarR +quadMass ans12 ans8 = tens1 &+ tens2 &+ tens3 &+ dens + where + dens = (SField (2 :: Rational) &.) $ ans8 &* delta3A + tens1 = (SField (6 :: Rational) &.) $ contrATens1 (1,0) $ ans12 &* flatInter + tens2 = (SField (2 :: Rational) &.) $ contrATens1 (1,0) $ ans8 &* interArea + tens3 = (SField (2 :: Rational) &.) $ tensorTrans1 (0,1) $ contrATens1 (0,0) $ ans8 &* interArea + +quadKin1 :: ATens 3 0 0 0 2 0 AnsVarR -> ATens 2 0 0 0 2 0 AnsVarR -> ATens 2 0 0 0 3 1 AnsVarR +quadKin1 ans14 ans10 = tens1 &+ tens2 &+ tens3 &+ dens &- (tens4_1 &+ tens4_2) + where + dens = ans10 &* delta3A + tens1 = (SField (1/2 :: Rational) &.) $ symATens5 (0,1) $ contrATens1 (2,0) $ ans14 &* flatInter + tens2 = contrATens1 (1,0) $ ans10 &* interArea + tens3 = tensorTrans1 (0,1) $ contrATens1 (0,0) $ ans10 &* interArea + tens4_1 = tensorTrans5 (1,2) $ ans10 &* delta3A + tens4_2 = resortTens5 [1,2,0] $ ans10 &* delta3A + + +quadKin2 :: ATens 3 0 0 0 2 0 AnsVarR -> ATens 2 0 0 0 2 0 AnsVarR -> ATens 2 0 0 0 3 1 AnsVarR +quadKin2 ans14 ans10 = symATens5 (0,2) $ tens1 &+ tens3 &+ tens4 &- (tens0 &+ tens2) + where + tens0 = tensorTrans5 (1,2) $ ans10 &* delta3A + tens1 = (SField (2 :: Rational) &.) $ contrATens1 (1,0) $ ans10 &* interArea + tens2 = tensorTrans1 (0,1) $ contrATens1 (0,0) $ ans14 &* flatInter + tens3 = contrATens1 (2,0) $ ans14 &* flatInter + tens4 = contrATens1 (0,0) $ ans14 &* flatInter + + +quadKin3 :: ATens 3 0 0 0 2 0 AnsVarR -> ATens 2 0 0 0 2 0 AnsVarR -> ATens 2 0 0 0 3 1 AnsVarR +quadKin3 ans14 ans10 = cyclicSymATens5 [0,1,2] $ tens1 &+ tens2 + where + tens1 = contrATens1 (1,0) $ ans10 &* interArea + tens2 = contrATens1 (1,0) $ ans14 &* flatInter + + +--principal polynomial equations + +polyAns2 :: ATens 0 0 1 0 0 0 AnsVarR +polyAns2 = fromListT6' $ map (\(x,y) -> (([], [], [Ind9 x], [], [], []),AnsVar $ I.singleton 1 y)) [(0,-1),(4,1),(7,1),(9,1)] + +polyTensEqn :: ATens 1 0 1 0 0 0 AnsVarR -> ATens 0 0 1 0 1 1 AnsVarR +polyTensEqn ans6 = total + where + ans6' = shiftLabels6 1 ans6 + ans2 = polyAns2 + tens1 = contrATens1 (0,0) $ ans6' &* flatInter + tens2 = contrATens2 (0,0) $ ans2 &* interMetric + total = tens1 &+ tens2 + +polyDensEqn :: ATens 1 0 1 0 0 0 AnsVarR -> ATens 0 0 1 0 1 1 AnsVarR +polyDensEqn ans6 = polyTensEqn ans6 &+ (ans2 &* delta3A) + where + ans2 = polyAns2 + +--additional equations for the metric case + +--the mass sub graph, i.e no derivatives + +--order 0 + +-- | The equation is given by: \(0 = a^A K_{An}^{Bm}\eta_B + a_0 \delta^m_n \). +eqn1Met :: ATens 0 0 0 0 0 0 AnsVarR -> ATens 0 0 1 0 0 0 AnsVarR -> ATens 0 0 0 0 1 1 AnsVarR +eqn1Met ans0 ans2 = contrATens2 (0,0) (ans2 &* flatInterMetric) &+ (ans0 &* delta3A) + +--order 1 + +-- | The equation is given by: \( 0 = a^A K_{An}^{Bm} + 2 a^{AB}K_{An}^{Cm}\eta_C + a^B\delta^m_n \). +eqn1AMet :: ATens 0 0 1 0 0 0 AnsVarR -> ATens 0 0 2 0 0 0 AnsVarR -> ATens 0 0 1 0 1 1 AnsVarR +eqn1AMet ans2 ans4 = block1 &+ block2 &+ block3 + where + block1 = contrATens2 (0,0) $ ans2 &* interMetric + block2 = contrATens2 (0,0) $ ans4 &* flatInterMetric + block3 = ans2 &* delta3A + +--order 2 + +-- | The equation is given by: \( 0 = 2 a^{AC}K_{An}^{Bm} + 2a^{AB}K_{An}^{Cm} + 6 a^{ABC}K_{An}^{Dm} \eta_D + 2a^{BC} \delta^m_n \) +eqn1ABMet :: ATens 0 0 2 0 0 0 AnsVarR -> ATens 0 0 3 0 0 0 AnsVarR -> ATens 0 0 2 0 1 1 AnsVarR +eqn1ABMet ans4 ans6 = block1 &+ block2 &+ block3 + where + block1 = symATens3 (0,1) $ contrATens2 (0,0) $ ans4 &* interMetric + block2 = contrATens2 (0,0) $ ans6 &* flatInterMetric + block3 = ans4 &* delta3A + + +--the sub graph with 2 total derivative + +--order 0 + +-- | The equation is given by: \( 0 = a^{AI}K_{An}^{B(m\vert }\eta_B J^{\vert pq)}_I \). +eqn3Met :: ATens 0 0 2 0 0 0 AnsVarR -> ATens 0 0 0 0 3 1 AnsVarR +eqn3Met ans4 = contrATens2 (0,0) $ contrATens2 (1,0) $ ans4 &* contrATens2 (0,2) (interEqn5Metric &* etaAbs) + +--order 1 + +-- | The equation is given by: \( 0 = a^{AI}\left [K_{An}^{Bm}\delta^I _J- 2 \delta^A_B J_I^{pm}I^J_{pn} \right ] + a^{ABJ}K_{An}^{Cm}\eta_C + a^{BJ} \delta^m_n \). +eqn1AIMet :: ATens 0 0 2 0 0 0 AnsVarR -> ATens 0 0 3 0 0 0 AnsVarR -> ATens 0 0 2 0 1 1 AnsVarR +eqn1AIMet ans4 ans6 = block1 &+ block2 &+ block3 + where + block1 = contrATens2 (0,0) $ ans6 &* flatInterMetric + block2 = contrATens2 (0,0) $ contrATens2 (1,1) $ ans4 &* interEqn3Metric + block3 = ans4 &* delta3A + +-- | The equation is given by: \( 0 = 2a^{A(p\vert Bq}K_{An}^{C\vert m)}\eta_C + a^{AI} \left [K_{An}^{B(m\vert} 2 J_{I}^{\vert p)q} - \delta_A^BJ_I^{pm}\delta^q_n \right ] \). +eqn2AaMet :: ATens 0 0 2 0 0 0 AnsVarR -> ATens 0 0 2 0 2 0 AnsVarR -> ATens 0 0 1 0 3 1 AnsVarR +eqn2AaMet ans4 ans6 = block1 &+ block2 + where + block1 = symATens5 (1,2) $ contrATens2 (1,0) $ ans6 &* flatInterMetric + block2 = symATens5 (1,2) $ contrATens2 (0,0) $ contrATens2 (1,0) $ ans4 &* interEqn4Metric + +-- | The equation is given by: \( 0 = a^{BAI}K_{An}^{C(m\vert}\eta_CJ_I^{\vert pq)} + a^{AI}K_{An}^{B(m \vert} J_I^{\vert pq)} \). +eqn3AMet :: ATens 0 0 2 0 0 0 AnsVarR -> ATens 0 0 3 0 0 0 AnsVarR -> ATens 0 0 1 0 3 1 AnsVarR +eqn3AMet ans4 ans6 = block1 &+ block2 + where + block1 = contrATens2 (0,0) $ contrATens2 (1,0) $ ans4 &* interEqn5Metric + block2 = contrATens2 (1,0) $ contrATens2 (2,0) $ ans6 &* contrATens2 (0,2) (interEqn5Metric &* etaAbs) + +--order 2 + +-- | The equation is given by: \( 0 = a^{CAI} \left [K_{An}^{Bm}\delta^I _J- 2 \delta^A_B J_I^{pm}I^J_{pn} \right ] + 2 a^{ACBJ} K_{An}^{Dm} \eta_D + a^{CBJ} \delta ^m _n \). +eqn1ABIMet :: ATens 0 0 3 0 0 0 AnsVarR -> ATens 0 0 4 0 0 0 AnsVarR -> ATens 0 0 3 0 1 1 AnsVarR +eqn1ABIMet ans6 ans8 = block1 &+ block2 &+ block3 &+ block4 + where + block1 = contrATens2 (0,0) $ ans8 &* flatInterMetric + block2 = contrATens2 (1,0) $ interMetric &* ans6 + block3 = contrATens2 (1,0) $ contrATens2 (2,1) $ ans6 &* interEqn3Metric + block4 = ans6 &* delta3A + +-- | The equation is given by: \( 0 = 2 a^{BCAI}K_{An}^{D(m \vert}\eta_DJ_I^{\vert pq)} + a^{CAI}K_{An}^{B(m \vert} J_I^{\vert pq)} \). +eqn3ABMet :: ATens 0 0 3 0 0 0 AnsVarR -> ATens 0 0 4 0 0 0 AnsVarR -> ATens 0 0 2 0 3 1 AnsVarR +eqn3ABMet ans6 ans8 = block1 &+ block2 + where + block1 = symATens3 (0,1) $ contrATens2 (1,0) $ contrATens2 (2,0) $ ans6 &* interEqn5Metric + block2 = contrATens2 (2,0) $ contrATens2 (3,0) $ ans8 &* contrATens2 (0,2) (interEqn5Metric &* etaAbs) + +-- | The equation is given by: \( 0 = 2 a^{C A(p \vert B q} K_{An}^{D \vert m )} \eta_D + a^{CAI} \left [K_{An}^{B(m\vert} 2 J_{I}^{\vert p)q} - \delta_A^BJ_I^{pm}\delta^q_n \right ] \). +eqn2ABbMet :: ATens 0 0 2 0 2 0 AnsVarR -> ATens 0 0 3 0 0 0 AnsVarR -> ATens 0 0 3 0 2 0 AnsVarR -> ATens 0 0 2 0 3 1 AnsVarR +eqn2ABbMet ans6_1 ans6_2 ans8 = block1 &+ block2 &+ block3 + where + block1 = symATens5 (0,2) $ contrATens2 (1,0) $ ans8 &* flatInterMetric + block2' = tensorTrans5 (0,1) $ contrATens2 (1,0) $ contrATens2 (1,1) $ ans6_2 &* interEqn4Metric + block2 = symATens5 (0,2) block2' + block3 = tensorTrans3 (0,1) $ symATens5 (0,2) $ contrATens2 (0,0) $ ans6_1 &* interMetric + +-- | The equation is given by: \( 0 = 2 a^{BqCr} \left [ K_{An}^{Bm} \delta ^q_p - \delta^B_A \delta^m_n \right ] +2 a^{A Bq Cr} K_{An}^{Dm} \eta_D + 2 a^{BqCr} \delta^m_n \). +eqn1AaBbMet :: ATens 0 0 2 0 2 0 AnsVarR -> ATens 0 0 3 0 2 0 AnsVarR -> ATens 0 0 2 0 3 1 AnsVarR +eqn1AaBbMet ans6 ans8 = block1 &+ block2 &+ block3 &+ block4 + where + block1 = tensorTrans5 (1,2) $ contrATens2 (0,0) $ ans8 &* flatInterMetric + block2 = contrATens2 (0,0) $ contrATens3 (0,1) $ ans6 &* interEqn2Metric + block3 = tensorTrans3 (0,1) $ tensorTrans5 (0,2) block2 + block4 = tensorTrans5 (1,2) $ ans6 &* delta3A diff --git a/src/Math/Tensor/Examples/Gravity/Schwarzschild.hs b/src/Math/Tensor/Examples/Gravity/Schwarzschild.hs new file mode 100644 --- /dev/null +++ b/src/Math/Tensor/Examples/Gravity/Schwarzschild.hs @@ -0,0 +1,104 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Math.Tensor.Examples.Gravity.Schwarzschild +-- Copyright : (c) 2019 Tobias Reinhart and Nils Alex +-- License : MIT +-- Maintainer : tobi.reinhart@fau.de, nils.alex@fau.de +-- +-- +-- This module provides the metric, inverse metric, Christoffel symbol, Ricci tensor and Einstein tensor for the Schwarzschild spacetime as an +-- example for tensor sections and partial derivatives thereof. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Math.Tensor.Examples.Gravity.Schwarzschild ( +schwarzschild, +schwarzschild', +christoffel, +ricci, +einstein +) +where + +import Math.Tensor + +import Numeric.AD.Internal.Forward (Forward(..)) + +-- | Schwarzschild metric \( g = (1-\frac{r_\text{s}}{r})\,\mathrm dt\otimes\mathrm dt - \frac{1}{1-\frac{r_\text{s}}{r}}\,\mathrm dr\otimes \mathrm dr - r^2\,\mathrm d\theta\otimes \mathrm d\theta - r^2\sin^2\theta\,\mathrm d\phi\otimes \mathrm d\phi \). + +schwarzschild :: Floating a => a -> STTens 0 2 (CFun [a] a) +schwarzschild rs = fromListT2 + [ + ((Empty, Ind3 0 `Append` singletonInd (Ind3 0)), CFun $ \(_:r:_) -> r' r ), + ((Empty, Ind3 1 `Append` singletonInd (Ind3 1)), CFun $ \(_:r:_) -> -1/r' r), + ((Empty, Ind3 2 `Append` singletonInd (Ind3 2)), CFun $ \(_:r:_) -> -(r^2)), + ((Empty, Ind3 3 `Append` singletonInd (Ind3 3)), CFun $ \(_:r:theta:_) -> -(r*sin theta)^2) + ] + where + r' r = 1 - rs / r + + +-- | Inverse Schwarzschild metric \( g = \frac{1}{1-\frac{r_\text{s}}{r}}\,\partial_t \otimes \partial_t - (1-\frac{r_\text{s}}{r})\,\partial_r \otimes \partial_r - \frac{1}{r^2}\,\partial_\theta \otimes \partial_\theta - \frac{1}{r^2\sin^2\theta}\,\partial_\phi \otimes \partial_\phi \). + +schwarzschild' :: Floating a => a -> STTens 2 0 (CFun [a] a) +schwarzschild' rs = fromListT2 + [ + ((Ind3 0 `Append` singletonInd (Ind3 0), Empty), CFun $ \(_:r:_) -> 1/r' r), + ((Ind3 1 `Append` singletonInd (Ind3 1), Empty), CFun $ \(_:r:_) -> - r' r), + ((Ind3 2 `Append` singletonInd (Ind3 2), Empty), CFun $ \(_:r:_) -> -1/(r^2)), + ((Ind3 3 `Append` singletonInd (Ind3 3), Empty), CFun $ \(_:r:theta:_) -> -1/(r*sin theta)^2) + ] + where + r' r = 1 - rs / r + +half :: Fractional a => SField a +half = SField $ 1/2 + +-- | Christoffel symbol of the Schwarzschild metric. + +christoffel :: forall a.Floating a => a -> STTens 1 2 (CFun [a] a) +christoffel rs = gamma + where + g = schwarzschild (Lift rs) + g' = schwarzschild' rs :: STTens 2 0 (CFun [a] a) + del_g = partial g :: STTens 0 3 (CFun [a] a) + g'_del_g = g' &* del_g + t1 = contrATens1 (0, 0) g'_del_g + t2 = contrATens1 (0, 1) g'_del_g + t3 = tensorTrans2 (0, 1) t2 + s = t2 &+ (t3 &- t1) + h = half :: SField a + gamma = h &. s + +-- | Ricci tensor of the Schwarzschild metric. + +ricci :: forall a.Floating a => a -> STTens 0 2 (CFun [a] a) +ricci rs = (term1 &- term2) &+ (term3 &- term4) + where + gamma1 = christoffel (Lift rs) + gamma2 = christoffel rs + del_gamma = partial gamma1 :: STTens 1 3 (CFun [a] a) + gamma_gamma = contrATens1 (1,1) $ gamma2 &* gamma2 :: STTens 1 3 (CFun [a] a) + term1 = contrATens1 (0,0) del_gamma + term2 = contrATens1 (0,1) del_gamma + term3 = contrATens1 (0,0) gamma_gamma + term4 = contrATens1 (0,1) gamma_gamma + +-- | Einstein tensor of the Schwarzschild metric. +-- The component functions evaluate to zero: +-- +-- >>> let g = einstein 2 +-- >>> g `evalSec` [1.1, 2.4, 1.7, 2.2] +-- ZeroTensor + +einstein :: forall a.Floating a => a -> STTens 0 2 (CFun [a] a) +einstein rs = r_ab &- (h &. r &* g) + where + r_ab = ricci rs :: STTens 0 2 (CFun [a] a) + g = schwarzschild rs :: STTens 0 2 (CFun [a] a) + g' = schwarzschild' rs :: STTens 2 0 (CFun [a] a) + r = contrATens1 (0,0) $ contrATens1 (1,1) $ g' &* r_ab + h = half :: SField a diff --git a/src/Math/Tensor/Examples/Gravity/SchwarzschildSymbolic.hs b/src/Math/Tensor/Examples/Gravity/SchwarzschildSymbolic.hs new file mode 100644 --- /dev/null +++ b/src/Math/Tensor/Examples/Gravity/SchwarzschildSymbolic.hs @@ -0,0 +1,92 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Math.Tensor.Examples.Gravity.SchwarzschildSymbolic +-- Copyright : (c) 2019 Tobias Reinhart and Nils Alex +-- License : MIT +-- Maintainer : tobi.reinhart@fau.de, nils.alex@fau.de +-- +-- +-- This module provides the Schwarzschild metric as an example for a tensor with symbolic values +-- as well as functions to calculate Christoffel symbols, Ricci tensors and Einstein tensors +-- from metric tensors with symbolic values. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE DataKinds #-} + +module Math.Tensor.Examples.Gravity.SchwarzschildSymbolic ( +schwarzschildS, +schwarzschildS', +christoffelS, +ricciS, +einsteinS +) +where + +import Math.Tensor + +-- | Schwarzschild metric \( g = (1-\frac{r_\text{s}}{r})\,\mathrm dt\otimes\mathrm dt - \frac{1}{1-\frac{r_\text{s}}{r}}\,\mathrm dr\otimes \mathrm dr - r^2\,\mathrm d\theta\otimes \mathrm d\theta - r^2\sin^2\theta\,\mathrm d\phi\otimes \mathrm d\phi \). + +schwarzschildS :: STTens 0 2 SSymbolic +schwarzschildS = fromListT2 + [ + ((Empty, Ind3 0 `Append` singletonInd (Ind3 0)), SSymbolic "1 - rs / r" ), + ((Empty, Ind3 1 `Append` singletonInd (Ind3 1)), SSymbolic "-1 / (1 - rs / r)"), + ((Empty, Ind3 2 `Append` singletonInd (Ind3 2)), SSymbolic "-r^2"), + ((Empty, Ind3 3 `Append` singletonInd (Ind3 3)), SSymbolic "-r^2*sin(theta)^2") + ] + +-- | Inverse Schwarzschild metric \( g = \frac{1}{1-\frac{r_\text{s}}{r}}\,\partial_t \otimes \partial_t - (1-\frac{r_\text{s}}{r})\,\partial_r \otimes \partial_r - \frac{1}{r^2}\,\partial_\theta \otimes \partial_\theta - \frac{1}{r^2\sin^2\theta}\,\partial_\phi \otimes \partial_\phi \). + +schwarzschildS' :: STTens 2 0 SSymbolic +schwarzschildS' = fromListT2 + [ + ((Ind3 0 `Append` singletonInd (Ind3 0), Empty), SSymbolic "1/(1 - rs/r)"), + ((Ind3 1 `Append` singletonInd (Ind3 1), Empty), SSymbolic "-(1-rs/r)"), + ((Ind3 2 `Append` singletonInd (Ind3 2), Empty), SSymbolic "-1/r^2"), + ((Ind3 3 `Append` singletonInd (Ind3 3), Empty), SSymbolic "-1/(r^2*sin(theta)^2)") + ] + +half :: SField Rational +half = SField (1/2) + +-- | Christoffel symbols of any symbolic metric. + +christoffelS :: STTens 0 2 SSymbolic -> STTens 2 0 SSymbolic -> STTens 1 2 SSymbolic +christoffelS g g' = gamma + where + del_g = partialSymbolic ["t", "r", "theta", "phi"] g + g'_del_g = g' &* del_g + t1 = contrATens1 (0, 0) g'_del_g + t2 = contrATens1 (0, 1) g'_del_g + t3 = tensorTrans2 (0, 1) t2 + s = t2 &+ (t3 &- t1) + gamma = half &. s + +-- | Ricci tensor of any symbolic metric. + +ricciS :: STTens 0 2 SSymbolic -> STTens 2 0 SSymbolic -> STTens 0 2 SSymbolic +ricciS g g' = (term1 &- term2) &+ (term3 &- term4) + where + gamma = christoffelS g g' + del_gamma = partialSymbolic ["t", "r", "theta", "phi"] gamma + gamma_gamma = contrATens1 (1,1) $ gamma &* gamma + term1 = contrATens1 (0,0) del_gamma + term2 = contrATens1 (0,1) del_gamma + term3 = contrATens1 (0,0) gamma_gamma + term4 = contrATens1 (0,1) gamma_gamma + +-- | Einstein tensor of any symbolic metric. +-- The components evaluate to zero: +-- +-- >>> let g = schwarzschildS +-- >>> let g' = schwarzschildS' +-- >>> let e = einsteinS g g' +-- >>> print e +-- ZeroTensor -- modulo symbolic simplification, which is not implemented yet. + +einsteinS :: STTens 0 2 SSymbolic -> STTens 2 0 SSymbolic -> STTens 0 2 SSymbolic +einsteinS g g' = r_ab &- (half &. r &* g) + where + r_ab = ricciS g g' + r = contrATens1 (0,0) $ contrATens1 (1,1) $ g' &* r_ab diff --git a/src/Math/Tensor/LorentzGenerator.hs b/src/Math/Tensor/LorentzGenerator.hs new file mode 100644 --- /dev/null +++ b/src/Math/Tensor/LorentzGenerator.hs @@ -0,0 +1,2121 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Math.Tensor.LorentzGenerator +-- Copyright : (c) 2019 Tobias Reinhart and Nils Alex +-- License : MIT +-- Maintainer : tobi.reinhart@fau.de, nils.alex@fau.de +-- +-- This module supplements the sparse-tensor package with the functionality of constructing bases of the space of Lorentz invariant tensors of arbitrary rank and symmetry. +-- +-- It can be shown that all \( SO(3,1) \) invariant tensors must be given by expressions that are solely composed of the Minkowski metric \(\eta_{ab} \), its inverse \(\eta^{ab} \) and the covariant and contravariant Levi-Civita +-- symbols \( \epsilon_{abcd}\) and \( \epsilon^{abcd} \). Any such an expression can be written as a sum of products of these tensors, with the individual products +-- containing the appropriate number of factors ensuring the required rank of the expression and the sum further enforcing the required symmetry. In the following such an expression is simply called an ansatz. +-- Thus the goal of the following functions is the computation of a set of ansätze of given rank and symmetry that are linear independent and allow one to express any further Lorentz invariant tensor with the same rank and symmetry as appropriate linear combination of them. +-- +-- Considering tensors with @4@ contravariant spacetime indices \(T^{abcd} \) that further satisfy the symmetry property \( T^{abcd} = T^{cdab} = T^{bacd} \) as an example, there only exist two linear independent ansätze namely: +-- +-- * \( \eta^{ab} \eta^{cd}\) +-- * \( \eta^{c(a} \eta^{b)d} \). +-- +-- If the tensors are required to have @6@ contravariant spacetime indices \( Q^{abcdpq} \) and satisfy the symmetry property \(Q^{abcdpq} = Q^{cdabpq} = - Q^{bacdpq} = Q^{abcdqp} \) there exist three linear independent ansätze: +-- +-- * \( \eta^{ac}\eta^{bd}\eta^{pq} - \eta^{ad}\eta^{bc}\eta^{pq} \) +-- * \( \eta^{ac}\eta^{bp}\eta^{dq} + \eta^{ac}\eta^{bq}\eta^{dp} - \eta^{bc}\eta^{ap}\eta^{dq} - \eta^{bc}\eta^{aq}\eta^{dp} - \eta^{ad}\eta^{bp}\eta^{cq} - \eta^{ad}\eta^{bq}\eta^{cp} + \eta^{bd}\eta^{ap}\eta^{cq} + \eta^{bd}\eta^{aq}\eta^{cp} \) +-- * \( \epsilon^{abcd}\eta^{pq} \). +-- +-- One can further show that any Lorentz invariant tensor must include in each of its individual products either exactly one or no Levi-Civita symbol. Further there exist no linear dependencies between those ansätze that contain an \(\epsilon^{abcd}\) or \(\epsilon_{abcd}\) and those that do not. +-- Hence the problem actually decouples into two sub problems, the construction of all linear independent ansätze that do not contain an Levi-Civita symbol and the construction of all those linear independent ansätze that do contain exactly one Levi-Civita symbol. +-- +-- +-- This module specifically defines data types @'AnsatzForestEta'@ and @'AnsatzForestEpsilon'@ that are internally implemented as ordered expression tailored towards linear combinations of the two types of ansätze. +-- +-- Currently the computation of ansatz bases is limited to the case where all indices are contravariant spacetime indices. +-- Minor changes should nevertheless also allow the computation of ansatz bases for arbitrary mixed rank spacetime tensors and even bases for tensors that are invariant under the action of any \(\mathrm{SO}(p,q)\), i.e. in arbitrary dimension and for arbitrary signature of the inner product. +----------------------------------------------------------------------------- +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} + +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} + +{-# LANGUAGE TupleSections #-} + +module Math.Tensor.LorentzGenerator ( +-- * Expression Forest Data Types +-- ** Node Types +Eta(..), Epsilon(..), Var(..), +-- ** Forest types +AnsatzForestEpsilon(..), AnsatzForestEta(..), +-- ** Conversions of AnsatzForests +-- *** List of Branches +flattenForest, flattenForestEpsilon, forestEtaList, forestEpsList, forestEtaListLatex, forestEpsListLatex, +-- *** ASCII drawing +drawAnsatzEta, drawAnsatzEpsilon, +-- ** Utility functions +-- *** Modifying Variables +getForestLabels, getForestLabelsEpsilon, +removeVarsEta, removeVarsEps, +relabelAnsatzForest, relabelAnsatzForestEpsilon, +mapVars, mapVarsEpsilon, +-- *** Ansatz Rank +ansatzRank, ansatzRankEpsilon, +-- *** Saving and Loading +encodeAnsatzForestEta, encodeAnsatzForestEpsilon, +decodeAnsatzForestEta, decodeAnsatzForestEpsilon, +-- * Construction of Ansatz Bases +-- ** The Fast Way +-- | The following functions construct the basis of Lorentz invariant tensors of given rank and symmetry by using an algorithm that is optimized towards +-- fast computation times. This is achieved at the cost of memory swelling of intermediate results. +-- +-- The output of each of the following functions is given by a triplet that consists of @('AnsatzForestEta', 'AnsatzForestEpsilon', 'Tensor' 'AnsVarR')@. +-- The @'Tensor'@ is obtained by explicitly providing the the components of the ansätze with individual ansätze given by individual variables of type @'AnsVar'@. +-- +mkAnsatzTensorFastSym, mkAnsatzTensorFast, mkAnsatzTensorFastAbs, +mkAnsatzTensorFastSym', mkAnsatzTensorFast', +-- ** The Memory Optimized Way +-- The following functions essentially compute the same results as their __Fast__ counterparts, with the only distinction being that they employ a slightly different +-- algorithm that avoids the problem of intermediate memory swelling and thus yields improved memory usage. All this is achieved at the cost of slightly higher computation times compared to the __Fast__ functions. +mkAnsatzTensorEigSym, mkAnsatzTensorEig, mkAnsatzTensorEigAbs, +mkAnsatzTensorEigSym', mkAnsatzTensorEig', +-- * Specifying Additional Data +-- ** Symmetry Type +Symmetry(..), +-- ** Evaluation Lists +-- *** Area Metric +-- | The following provides an example of evaluation lists. +areaList4, areaList6, areaList8, areaList10_1, areaList10_2, areaList12, areaList14_1, areaList14_2, +-- *** Metric +-- | In the documentation of the following further provided exemplary evaluation lists index labels \(A, B, C, ...\) also refers to indices of type @'Ind9'@. +metricList2, metricList4_1, metricList4_2, metricList6_1, metricList6_2, metricList6_3, metricList8_1, metricList8_2, +-- ** Symmetry Lists +-- *** Area Metric +-- | The following are examples of symmetry lists. +symList4, symList6, symList8, symList10_1, symList10_2, symList12, symList14_1, symList14_2, +-- *** Metric +-- | The following are examples of symmetry lists. +metricsymList2, metricsymList4_1, metricsymList4_2, metricsymList6_1, metricsymList6_2, metricsymList6_3, metricsymList8_1, metricsymList8_2 +) where + +import qualified Data.IntMap.Strict as I +import qualified Data.Map.Strict as M +import Data.List (nub, permutations, foldl', (\\), elemIndex, nubBy, sortBy, insert, intersect, union, partition, delete) +import Data.Maybe (fromJust, isNothing, fromMaybe, isJust, mapMaybe) +import Control.Parallel.Strategies (parListChunk, rdeepseq, runEval, NFData(..)) +import Data.Serialize (encodeLazy, decodeLazy, Serialize(..)) +import GHC.Generics +import qualified Data.ByteString.Lazy as BS (ByteString(..)) +import Codec.Compression.GZip (compress, decompress) +import Data.Either (either) +import Data.Tuple (swap) +import GHC.TypeLits +import Data.Singletons (SingI(..)) + +--LinearAlgebra subroutines + +import qualified Data.Eigen.Matrix as Mat +import qualified Data.Eigen.SparseMatrix as Sparse +import qualified Data.Eigen.LA as Sol + +import Math.Tensor + +{-- +The first step consist of pre-reducing the index list for the eta and epsilon trees as much as possible. +This is done by using the symmetries in the sense that we try to select exactly one representative out of each class of indices +that are equivalent under the symmetries. +Note that the pre-reduction is not necessary but increases performance. +--} + +-- | Type alias to encode the symmetry information. The individual @'Int'@ values label the individual spacetime indices, the @'Symmetry'@ type is the compromised of (SymPairs, ASymPairs, BlockSyms, CyclicSyms, CyclicBlockSyms). +type Symmetry = ( [(Int,Int)] , [(Int,Int)] , [([Int],[Int])] , [[Int]], [[[Int]]] ) + +addSym :: Symmetry -> Symmetry -> Symmetry +addSym (a,b,c,d,e) (f,g,h,i,j) = (a `union` f, b `union` g, c `union` h, d `union` i, e `union` j) + +--constructing the filter list out of the symmetry data for filtering one representative out of each symmetry class + +mkFilters :: Symmetry -> [(Int,Int)] +mkFilters (pairs,aPairs,blocks,cycles,blockCycles) = map sortPair $ f1 `union` (f2 `union` (f3 `union` f4)) + where + sortPair (a,b) = if a < b then (a,b) else (b,a) + f1 = pairs ++ aPairs + f2 = map (\(a,b) -> (head a, head b)) blocks + getPairs [a,b] = [(a,b)] + getPairs (x:xs) = (x, head xs) : getPairs xs + f3 = concatMap getPairs cycles + f4 = concatMap (getPairs . map head) blockCycles + +--filter the index lists + +filter1Sym :: [Int] -> (Int,Int) -> Bool +filter1Sym l (i,j) = case (iPos,jPos) of + (Just i', Just j') -> i' < j' + _ -> True + where + (iPos,jPos) = (elemIndex i l, elemIndex j l) + +filterSym :: [Int] -> [(Int,Int)] -> Bool +filterSym l inds = and boolList + where + boolList = map (filter1Sym l) inds + + +{-- +Note that writing specific indices from a block symmetry at an eta yields additional symmetries: for instance consider the block symmetry +[ab] <-> [cd] writing eta[ac] yields the new symmetry b <-> d. The 2-block symmetry is thus reduced to a 1-block symmetry. In the same way +etas reduce n-block symmetries to (n-1)-block symmetries. To compute these we also need to include all possible block symmetries that are specified +in terms of a cyclic block symmetry. +--} + +getExtraSyms1 :: [Int] -> Symmetry -> Symmetry +getExtraSyms1 [] syms = ([],[],[],[],[]) +getExtraSyms1 (a:b:xs) (pairs,aPairs,blocks,cycles,blockCycles) = addSym (newPairs, [], newBlocks, [], []) (getExtraSyms1 xs newSyms) + where + allBlocks = blocks ++ concatMap mkBlocksFromBlockCycle blockCycles + newBlocks' = map (\(x,y) -> unzip $ filter (\(c,d) -> (c,d) /= (a,b)) $ zip x y) allBlocks + (newBlocks, newPairs') = partition (\(a,b) -> length a > 1) newBlocks' + newPairs = map (\([a],[b]) -> (a,b)) newPairs' + newSyms = addSym (pairs,aPairs,blocks,cycles,blockCycles) (newPairs, [], newBlocks, [], []) + +mkBlocksFromBlockCycle :: [[Int]] -> [([Int],[Int])] +mkBlocksFromBlockCycle [x,y] = [(x,y)] +mkBlocksFromBlockCycle (x:xs) = l ++ mkBlocksFromBlockCycle xs + where + l = map (x,) xs + +{-- +Furthermore distributing a symmetric or antisymmetric pair of indices over 2 etas yields an additional symmetry or anti-symmetry +of the remaining eta indices due to the product structure: for instance consider the a <-> b symmetry, +writing eta[ac] eta[bd] yields an additional c <-> d symmetry. Here it is additionally necessary to include the pair symmetries that are contributed by a given total symmetry +--} + + +--given one eta, if the eta contains an index from a symmetric or antisymmetric pair return the corresponding second index and the other index of the eta + +get2nd :: [Int] -> Symmetry -> (Maybe [(Int,Int)], Maybe [(Int,Int)]) +get2nd [a,b] (pairs,aPairs,blocks,cycles,blockCycles) = (sndPairs, sndAPairs) + where + allPairs = pairs ++ concatMap mkSymsFromCycle cycles + aPair = lookup a allPairs + bPair = lookup b (map swap allPairs) + aAPair = lookup a aPairs + bAPair = lookup b (map swap aPairs) + sndPairs = case (aPair, bPair) of + (Nothing, Nothing) -> Nothing + (Just x, Nothing) -> Just [(b,x)] + (Nothing, Just y) -> Just [(a,y)] + (Just x, Just y) -> if x == b then Nothing else Just [(b,x),(a,y)] + sndAPairs = case (aAPair, bAPair) of + (Nothing, Nothing) -> Nothing + (Just x, Nothing) -> Just [(b,x)] + (Nothing, Just y) -> Just [(a,y)] + (Just x, Just y) -> if x == b then Nothing else Just [(b,x),(a,y)] + + +--find the eta that contains the computed second pair index and return the other indices of this eta + +get2ndSyms :: Maybe [(Int,Int)] -> Symmetry -> [[Int]] -> Symmetry +get2ndSyms Nothing syms etas = syms +get2ndSyms (Just i) (pairs,aPairs,blocks,cycles,blockCycles) etas = (newPairs,[],[],[],[]) + where + get2ndInd l (i,j) = mapMaybe (\[a,b] -> if j == a then Just (i,b) else if j == b then Just (i,a) else Nothing) l + newPairs = concatMap (get2ndInd etas) i + +mkSymsFromCycle :: [Int] -> [(Int,Int)] +mkSymsFromCycle [x,y] = [(x,y)] +mkSymsFromCycle (x:xs) = l ++ mkSymsFromCycle xs + where + l = map (x,) xs + + +get2ndASyms :: Maybe [(Int,Int)] -> Symmetry -> [[Int]] -> Symmetry +get2ndASyms Nothing syms etas = syms +get2ndASyms (Just i) (pairs,aPairs,blocks,cycles,blockCycles) etas = ([], newAPairs,[],[],[]) + where + get2ndInd l (i,j) = mapMaybe (\[a,b] -> if j == a then Just (i,b) else if j == b then Just (i,a) else Nothing) l + newAPairs = concatMap (get2ndInd etas) i + + +--apply to whole ind list + +getExtraSyms2 :: [Int] -> Symmetry -> Symmetry +getExtraSyms2 [] syms = syms +getExtraSyms2 (a':b':xs) syms = addSym (getExtraSyms2 xs newSyms) newSyms + where + mkEtas [] = [] + mkEtas [l,k] = [[l,k]] + mkEtas (l:k:ls) = [l,k] : mkEtas ls + x = [a',b'] + (i,j) = get2nd x syms + (p,_,_,_,_) = get2ndSyms i syms (mkEtas xs) + (_,a,_,_,_) = get2ndASyms j syms (mkEtas xs) + newSyms = addSym (p,a,[],[],[]) syms + +--compute all extra symmetries + +getAllExtraSyms :: [Int] -> Symmetry -> Symmetry +getAllExtraSyms etas syms = allSyms2 + where + allSyms1 = addSym (getExtraSyms1 etas syms) syms + allSyms2 = addSym (getExtraSyms2 etas allSyms1) allSyms1 + + +getAllIndsEta :: [Int] -> [(Int,Int)] -> [[Int]] +getAllIndsEta [a,b] aSyms = [[a,b]] +getAllIndsEta (x:xs) aSyms = concatMap res firstEta + where + firstEta = mapMaybe (\y -> if (x,y) `notElem` aSyms then Just ([x,y],delete y xs) else Nothing) xs + res (a,b) = (++) a <$> getAllIndsEta b aSyms + +filterEta :: [Int] -> Symmetry -> [(Int,Int)] -> Bool +filterEta inds (p1,ap1,b1,c1,cb1) filters = filterSym inds totFilters && isNonZero + where + (p2,ap2,b2,c2,cb2) = getAllExtraSyms inds (p1,ap1,b1,c1,cb1) + extrafilters = mkFilters (p2,ap2,b2,c2,cb2) + totFilters = filters `union` extrafilters + mkEtas [] = [] + mkEtas [l,k] = [(l,k)] + mkEtas (l:k:ls) = (l,k) : mkEtas ls + etas = mkEtas inds + isNonZero = null $ etas `intersect` union ap1 ap2 + +--construct a pre-reduced list of eta indices + +getEtaInds :: [Int] -> Symmetry -> [[Int]] +getEtaInds [] sym = [[]] +getEtaInds inds (p,ap,b,c,bc) = filter (\x -> filterEta x (p,ap,b,c,bc) filters1) allInds + where + filters1 = mkFilters (p,ap,b,c,bc) + allInds = getAllIndsEta inds ap + +{-- +Now we proceed in the same fashion for the epsilon ind list. +Here we can actually from the very beginning prevent some linear dependencies from occurring by noting that due to certain symmetries +certain expressions involving epsilon only differ by an expression that is antisymmetric in 5 or more indices and hence vanishes +we restrict to the simplest case: two antisymmetric pairs with a block symmetry, i.e. an area block + +we can use the following observations : + as we want to construct a basis it suffices to pick representatives of the different symmetry orbits module anti-sym in (>4) indices + 1) whenever 3 indices of one are metric are contracted against an epsilon we can actually express the tensor as one with 4 area indices contracted against epsilon + 2) all tensors with 2 area indices contracted against one epsilon can be expressed as tensors with the first 2 area indices contracted against epsilon + 3) tensors with a maximum of 1 epsilon contraction per area metric can be expressed by those with at least one 2 area contraction +--} + +--get all possible epsilon inds that are allowed under the above considerations + +getAllIndsEpsilon :: [Int] -> Symmetry -> [[Int]] +getAllIndsEpsilon inds (p,ap,b,cyc,cb) = [ [a,b,c,d] | a <- [1..i-3], b <- [a+1..i-2], c <- [b+1..i-1], d <- [c+1..i], + not (isSym p [a,b,c,d]) && not (is3Area areaBlocks [a,b,c,d]) && isValid2Area areaBlocks [a,b,c,d] + && not (is1Area areaBlocks [a,b,c,d]) && not (isSymCyc cyc [a,b,c,d]) ] + where + i = length inds + blocks2 = filter (\x -> length (fst x) == 2) b + areaBlocks = map (uncurry (++)) $ filter (\([a,b],[c,d]) -> (a,b) `elem` ap && (c,d) `elem` ap) blocks2 + isSym [] x = False + isSym [(a,b)] [i,j,k,l] = length ([a,b] `intersect` [i,j,k,l]) == 2 + isSym (x:xs) [i,j,k,l] + | isSym [x] [i,j,k,l] = True + | otherwise = isSym xs [i,j,k,l] + isSymCyc [] x = False + isSymCyc [l'] [i,j,k,l] = length (l' `intersect` [i,j,k,l]) >= 2 + isSymCyc (x:xs) [i,j,k,l] + | isSymCyc [x] [i,j,k,l] = True + | otherwise = isSymCyc xs [i,j,k,l] + is3Area [] i = False + is3Area [[a,b,c,d]] [i,j,k,l] = length ([a,b,c,d] `intersect` [i,j,k,l]) == 3 + is3Area (x:xs) [i,j,k,l] + | is3Area [x] [i,j,k,l] = True + | otherwise = is3Area xs [i,j,k,l] + isValid2Area [] i = True + isValid2Area [[a,b,c,d]] [i,j,k,l] + | length inter == 2 = inter == [a,b] + | otherwise = True + where + inter = [a,b,c,d] `intersect` [i,j,k,l] + isValid2Area (x:xs) [i,j,k,l] + | isValid2Area [x] [i,j,k,l] = isValid2Area xs [i,j,k,l] + | otherwise = False + is1Area [] i = False + is1Area list [i,j,k,l] = maximum (map (length . ([i,j,k,l] `intersect`)) list) == 1 + +--a 2-block symmetry with the respectively first indices at an epsilon yields an additional anti-symmetry (note that we did not include higher block anti-symmetries) + +getExtraASymsEps :: [Int] -> Symmetry -> Symmetry +getExtraASymsEps eps (p,ap,blo,cyc,cb) = ([],newASyms, [], [], []) + where + allBlocks = blo ++ concatMap mkBlocksFromBlockCycle cb + blocks2 = filter (\(a,b) -> length a == 2) allBlocks + newASyms = mapMaybe (\([i,j],[k,l]) -> if length ([i,k] `intersect` eps) == 2 then Just (j,l) else if length ([j,l] `intersect` eps) == 2 then Just (i,k) else Nothing) blocks2 + +getEpsilonInds :: [Int] -> Symmetry -> [[Int]] +getEpsilonInds inds sym = allIndsRed + where + epsInds = getAllIndsEpsilon inds sym + allInds = concat $ filter (not . null) $ map (\x -> map (x ++) $ getEtaInds (inds \\ x) (addSym sym (getExtraASymsEps x sym)) )epsInds + isSymP [] x = False + isSymP [(a,b)] [i,j,k,l] = length ([a,b] `intersect` [i,j,k,l]) == 2 + isSymP (x:xs) [i,j,k,l] + | isSymP [x] [i,j,k,l] = True + | otherwise = isSymP xs [i,j,k,l] + filters = mkFilters sym + allIndsRed = filter (\x -> let symEps = addSym (getExtraASymsEps (take 4 x) sym) sym + symEta = addSym symEps (getAllExtraSyms (drop 4 x) symEps) + newFilters = union filters (mkFilters symEta) + in filterSym x newFilters) allInds + +{-- +Expressions containing sums of products of epsilon and eta with unknown variables are encoded as trees with nodes being given by +epsilons and etas and leafs being given by the variables +--} + +--eta and epsilon types for the tree representing a sum of products of these tensors + +-- | Data type that represents the individual \(\eta^{ab}\) tensor. The indices are labeled not by characters but by integers. +data Eta = Eta {-# UNPACK #-} !Int {-# UNPACK #-} !Int deriving (Show, Read, Eq, Ord, Generic, Serialize, NFData) + +-- | Data type that represents the individual \(\epsilon^{abcd}\) tensor. The indices are labeled not by characters but by integers. +data Epsilon = Epsilon {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int {-# UNPACK #-} !Int deriving (Show, Read, Eq, Ord, Generic, Serialize, NFData) + +-- | Data type that represents variables that multiply the individual ansätze to form a general linear combination. The 2nd @'Int'@ argument labels the variables the first @'Int'@ is a factor that multiplies the variable. +data Var = Var {-# UNPACK #-} !Int {-# UNPACK #-} !Int deriving (Show, Read, Eq, Ord, Generic, Serialize, NFData ) + +sortList :: Ord a => [a] -> [a] +sortList = foldr insert [] + +sortEta :: Eta -> Eta +sortEta (Eta x y) = Eta (min x y) (max x y) +{-# INLINEABLE sortEta #-} + +sortEpsilon :: Epsilon -> Epsilon +sortEpsilon (Epsilon i j k l) = Epsilon i' j' k' l' + where + [i',j',k',l'] = sortList [i,j,k,l] + +getEpsSign :: Epsilon -> Int +getEpsSign (Epsilon i j k l) = (-1) ^ length (filter (==True) [j>i,k>i,l>i,k>j,l>j,l>k]) +{-# INLINEABLE getEpsSign #-} + +addVars :: Var -> Var -> Var +addVars (Var x y) (Var x' y') = if y == y' then Var (x + x') y else error "should not add different vars" +{-# INLINEABLE addVars #-} + +multVar :: Int -> Var -> Var +multVar x (Var x' y) = Var (x * x') y +{-# INLINEABLE multVar #-} + +isZeroVar :: Var -> Bool +isZeroVar (Var x _) = x==0 +{-# INLINEABLE isZeroVar #-} + +-- | Data type that represents a general linear combination of ansätze that involve no \(\epsilon^{abcd}\). +data AnsatzForestEta = ForestEta (M.Map Eta AnsatzForestEta)| Leaf !Var | EmptyForest deriving (Show, Read, Eq, Generic, Serialize) + +-- | Data type that represents a general linear combination of ansätze that involve one \(\epsilon^{abcd}\) in each individual product. +type AnsatzForestEpsilon = M.Map Epsilon AnsatzForestEta + +--save and load forests as bytestrings + +-- | Encode an @'AnsatzForestEta'@ employing the @'Serialize'@ instance. +encodeAnsatzForestEta :: AnsatzForestEta -> BS.ByteString +encodeAnsatzForestEta = compress . encodeLazy + +-- | Encode an @'AnsatzForestEpsilon'@ employing the @'Serialize'@ instance. +encodeAnsatzForestEpsilon :: AnsatzForestEpsilon -> BS.ByteString +encodeAnsatzForestEpsilon = compress . encodeLazy + +-- | Decode an @'AnsatzForestEta'@ employing the @'Serialize'@ instance. +decodeAnsatzForestEta :: BS.ByteString -> AnsatzForestEta +decodeAnsatzForestEta bs = either error id $ decodeLazy $ decompress bs + +-- | Decode an @'AnsatzForestEpsilon'@ employing the @'Serialize'@ instance. +decodeAnsatzForestEpsilon :: BS.ByteString -> AnsatzForestEpsilon +decodeAnsatzForestEpsilon bs = either error id $ decodeLazy $ decompress bs + +forestMap :: AnsatzForestEta -> M.Map Eta AnsatzForestEta +forestMap (ForestEta m) = m +{-# INLINEABLE forestMap #-} + +--map a function over the nodes of the AnsatzTree (map over the tensors eta and epsilon) + +mapNodes :: (Eta -> Eta) -> AnsatzForestEta -> AnsatzForestEta +mapNodes f EmptyForest = EmptyForest +mapNodes f (ForestEta m) = ForestEta $ M.mapKeys f . M.map (mapNodes f) $ m +mapNodes f (Leaf x) = Leaf x + +mapNodesEpsilon :: (Epsilon -> Epsilon) -> AnsatzForestEpsilon -> AnsatzForestEpsilon +mapNodesEpsilon = M.mapKeys + +--map over the vars, i.e. the leafs of the tree + +-- | Map a general function over all variables that are contained in the @'AnsatzForestEta'@. +mapVars :: (Var -> Var) -> AnsatzForestEta -> AnsatzForestEta +mapVars f EmptyForest = EmptyForest +mapVars f (Leaf var) = Leaf (f var) +mapVars f (ForestEta m) = ForestEta $ M.map (mapVars f) m + +-- | Map a general function over all variables that are contained in the @'AnsatzForestEpsilon'@. +mapVarsEpsilon :: (Var -> Var) -> AnsatzForestEpsilon -> AnsatzForestEpsilon +mapVarsEpsilon f = M.map (mapVars f) + +--multiplying the vars with a fixed Int + +multVars :: Int -> AnsatzForestEta -> AnsatzForestEta +multVars i = mapVars (multVar i) + +multVarsEpsilon :: Int -> AnsatzForestEpsilon -> AnsatzForestEpsilon +multVarsEpsilon i = mapVarsEpsilon (multVar i) + +--relabel and remove Vars in the Forest + +getLeafVals :: AnsatzForestEta -> [Var] +getLeafVals (Leaf var) = [var] +getLeafVals (ForestEta m) = rest + where + rest = concatMap getLeafVals $ M.elems m + +getLeafValsEpsilon :: AnsatzForestEpsilon -> [Var] +getLeafValsEpsilon m = concatMap getLeafVals $ M.elems m + +getVarLabels :: Var -> Int +getVarLabels (Var i j) = j + +-- | Return a list of the labels of all variables that are contained in the @'AnsatzForestEta'@. +getForestLabels :: AnsatzForestEta -> [Int] +getForestLabels ans = nub $ map getVarLabels $ getLeafVals ans + +-- | Return a list of the labels of all variables that are contained in the @'AnsatzForestEpsilon'@. +getForestLabelsEpsilon :: AnsatzForestEpsilon -> [Int] +getForestLabelsEpsilon m = nub $ map getVarLabels $ getLeafValsEpsilon m + +-- | Return the rank, i.e. the number of different variables that is contained in the @'AnsatzForestEta'@. +ansatzRank :: AnsatzForestEta -> Int +ansatzRank ans = length $ getForestLabels ans + +-- | Return the rank, i.e. the number of different variables that is contained in the @'AnsatzForestEpsilon'@. +ansatzRankEpsilon :: AnsatzForestEpsilon -> Int +ansatzRankEpsilon ans = length $ getForestLabelsEpsilon ans + + +relabelVar :: (Int -> Int) -> Var -> Var +relabelVar f (Var i j) = Var i (f j) + +-- | Shift the variable labels of all variables that are contained in the @'AnsatzForestEta'@ by the amount specified. +relabelAnsatzForest :: Int -> AnsatzForestEta -> AnsatzForestEta +relabelAnsatzForest i ans = mapVars update ans + where + vars = getForestLabels ans + relabMap = I.fromList $ zip vars [i..] + update = relabelVar ((I.!) relabMap) + +-- | Remove the branches with variable label contained in the argument @'Int'@ list from the @'AnsatzForestEta'@. +removeVarsEta :: [Int] -> AnsatzForestEta -> AnsatzForestEta +removeVarsEta vars (Leaf (Var i j)) + | j `elem` vars = EmptyForest + | otherwise = Leaf (Var i j) +removeVarsEta vars (ForestEta m) = ForestEta $ M.filter (/= EmptyForest) $ M.map (removeVarsEta vars) m +removeVarsEta vars EmptyForest = EmptyForest + +-- | Shift the variable labels of all variables that are contained in the @'AnsatzForestEpsilon'@ by the amount specified. +relabelAnsatzForestEpsilon :: Int -> AnsatzForestEpsilon -> AnsatzForestEpsilon +relabelAnsatzForestEpsilon i ans = if ans == M.empty then M.empty else mapVarsEpsilon update ans + where + vars = getForestLabelsEpsilon ans + relabMap = I.fromList $ zip vars [i..] + update = relabelVar ((I.!) relabMap) + +-- | Remove the branches with variable label contained in the argument @'Int'@ list from the @'AnsatzForestEpsilon'@. +removeVarsEps :: [Int] -> AnsatzForestEpsilon -> AnsatzForestEpsilon +removeVarsEps vars m = M.filter (/= EmptyForest) $ M.map (removeVarsEta vars) m + +--add 2 sorted forests + +addForests :: AnsatzForestEta -> AnsatzForestEta -> AnsatzForestEta +addForests ans EmptyForest = ans +addForests EmptyForest ans = ans +addForests (Leaf var1) (Leaf var2) + | isZeroVar newLeafVal = EmptyForest + | otherwise = Leaf newLeafVal + where + newLeafVal = addVars var1 var2 +addForests (ForestEta m1) (ForestEta m2) + | M.null newMap = EmptyForest + | otherwise = ForestEta newMap + where + newMap = M.filter (/= EmptyForest) $ M.unionWith addForests m1 m2 + +addForestsEpsilon :: AnsatzForestEpsilon -> AnsatzForestEpsilon -> AnsatzForestEpsilon +addForestsEpsilon m1 m2 = M.filter (/= EmptyForest) $ M.unionWith addForests m1 m2 + +addList2Forest :: AnsatzForestEta -> ([Eta],Var) -> AnsatzForestEta +addList2Forest EmptyForest x = mkForestFromAscList x +addList2Forest (Leaf var1) ([], var2) + | isZeroVar newLeafVal = EmptyForest + | otherwise = Leaf newLeafVal + where + newLeafVal = addVars var1 var2 +addList2Forest (ForestEta m1) (x:xs, var) = ForestEta $ M.insertWith (\a1 a2 -> addList2Forest a2 (xs, var)) x newVal m1 + where + newVal = mkForestFromAscList (xs,var) + +addList2ForestEpsilon :: AnsatzForestEpsilon -> (Epsilon,[Eta],Var) -> AnsatzForestEpsilon +addList2ForestEpsilon m (eps,eta,var) = M.insertWith (\a1 a2 -> addList2Forest a2 (eta, var)) eps newVal m + where + newVal = mkForestFromAscList (eta,var) + +--flatten Forest to AscList consisting of the several Branches + +-- | Flatten an @'AnsatzForestEta'@ to a list that contains the individual branches. +flattenForest :: AnsatzForestEta -> [([Eta],Var)] +flattenForest EmptyForest = [] +flattenForest (Leaf var) = [([],var)] +flattenForest (ForestEta m) = concat l + where + mPairs = M.assocs m + l = fmap (\(k,v) -> map (\(i,j) -> (insert k i, j)) $ flattenForest v) mPairs + +-- | Flatten an @'AnsatzForestEpsilon'@ to a list that contains the individual branches. +flattenForestEpsilon :: AnsatzForestEpsilon -> [(Epsilon,[Eta],Var)] +flattenForestEpsilon m = concat l + where + mPairs = M.assocs m + l = fmap (\(k,v) -> map (\(i,j) -> (k, i, j)) $ flattenForest v) mPairs + +--draw the forests as ASCII picture + +drawEtaTree :: Eta -> AnsatzForestEta -> [String] +drawEtaTree (Eta i j) (Leaf (Var a b)) = ["(" ++ show i ++ "," ++ show j ++ ") * (" ++ show a ++ ") * x[" ++ show b ++ "]"] +drawEtaTree (Eta i j) (ForestEta m) = lines ("(" ++ show i ++ "," ++ show j ++ ")") ++ drawSubTrees m + where + drawSubTrees x + | x == M.empty = [] + | M.size x == 1 = let [(a,b)] = M.assocs x in "|" : shift "`---- " " " (drawEtaTree a b) + | otherwise = let (a,b) = head $ M.assocs x in "|" : shift "+---- " "| " (drawEtaTree a b) ++ drawSubTrees (M.delete a x) + shift first other = zipWith (++) (first : repeat other) +drawEtaTree eta EmptyForest = [] + +drawEpsilonTree :: Epsilon -> AnsatzForestEta -> [String] +drawEpsilonTree (Epsilon i j k l) (Leaf (Var a b)) = ["(" ++ show i ++ "," ++ show j ++ "," ++ show k ++ "," ++ show l ++ ") * (" ++ show a ++ ") * x[" ++ show b ++ "]"] +drawEpsilonTree (Epsilon i j k l) (ForestEta m) = lines ("(" ++ show i ++ "," ++ show j ++ "," ++ show k ++ "," ++ show l ++ ")") ++ drawSubTrees m + where + drawSubTrees x + | x == M.empty = [] + | M.size x == 1 = let [(a,b)] = M.assocs x in "|" : shift "`---- " " " (drawEtaTree a b) + | otherwise = let (a,b) = head $ M.assocs x in "|" : shift "+---- " "| " (drawEtaTree a b) ++ drawSubTrees (M.delete a x) + shift first other = zipWith (++) (first : repeat other) +drawEpsilonTree eps EmptyForest = [] + +-- | Returns an ASCII drawing of the @'AnsatzForestEta'@ in the fashion explained in "Data.Tree". +-- The ansatz \( x_1 \cdot 8 \{ \eta^{ac}\eta^{bd}\eta^{pq} - \eta^{ad}\eta^{bc}\eta^{pq} \} + x_2 \cdot 2 \{\eta^{ac}\eta^{bp}\eta^{dq} + \eta^{ac}\eta^{bq}\eta^{dp} - \eta^{bc}\eta^{ap}\eta^{dq} - \eta^{bc}\eta^{aq}\eta^{dp} - \eta^{ad}\eta^{bp}\eta^{cq} - \eta^{ad}\eta^{bq}\eta^{cp} + \eta^{bd}\eta^{ap}\eta^{cq} + \eta^{bd}\eta^{aq}\eta^{cp} \} \) is drawn to +-- +-- > (1,3) +-- > | +-- > +---- (2,4) +-- > | | +-- > | `---- (5,6) * (8) * x[1] +-- > | +-- > +---- (2,5) +-- > | | +-- > | `---- (4,6) * (2) * x[2] +-- > | +-- > `---- (2,6) +-- > | +-- > `---- (4,5) * (2) * x[2] +-- > +-- > (1,4) +-- > | +-- > +---- (2,3) +-- > | | +-- > | `---- (5,6) * (-8) * x[1] +-- > | +-- > +---- (2,5) +-- > | | +-- > | `---- (3,6) * (-2) * x[2] +-- > | +-- > `---- (2,6) +-- > | +-- > `---- (3,5) * (-2) * x[2] +-- > +-- > (1,5) +-- > | +-- > +---- (2,3) +-- > | | +-- > | `---- (4,6) * (-2) * x[2] +-- > | +-- > `---- (2,4) +-- > | +-- > `---- (3,6) * (2) * x[2] +-- > +-- > (1,6) +-- > | +-- > +---- (2,3) +-- > | | +-- > | `---- (4,5) * (-2) * x[2] +-- > | +-- > `---- (2,4) +-- > | +-- > `---- (3,5) * (2) * x[2] +drawAnsatzEta :: AnsatzForestEta -> String +drawAnsatzEta (Leaf (Var a b)) = show a ++ "x[" ++ show b ++ "]" +drawAnsatzEta (ForestEta m) = unlines $ map (\(x,y) -> unlines $ drawEtaTree x y) $ M.assocs m +drawAnsatzEta EmptyForest = [] + +-- | Returns an ASCII drawing of the @'AnsatzForestEpsilon'@ in the fashion explained in "Data.Tree". +-- The ansatz \( x_3 \cdot 16 \epsilon^{abcd}\eta^{pq} \) is drawn as: +-- +-- > (1,2,3,4) +-- > | +-- > `---- (5,6) * (16) * x[3] +drawAnsatzEpsilon :: AnsatzForestEpsilon -> String +drawAnsatzEpsilon m + | M.size m == 0 = [] + | otherwise = unlines $ map (\(x,y) -> unlines $ drawEpsilonTree x y) $ M.assocs m + +--get one representative for each Var Label + +-- | Return one representative, i.e. one individual product for each of the basis ansätze in an @'AnsatzForestEta'@. The function thus returns the contained individual ansätze without +-- their explicit symmetrization. +forestEtaList :: AnsatzForestEta -> [[Eta]] +forestEtaList f = map fst fList'' + where + fList = flattenForest f + fList' = sortBy (\(e1, Var x1 y1 ) (e2, Var x2 y2) -> compare y1 y2) fList + fList'' = nubBy (\(e1, Var x1 y1 ) (e2, Var x2 y2) -> if x1 == 0 || x2 == 0 then error "zeros!!" else y1 == y2) fList' + +-- | Return one representative, i.e. one individual product for each of the basis ansätze in an @'AnsatzForestEpsilon'@. The function thus returns the contained individual ansätze without +-- their explicit symmetrization. +forestEpsList :: AnsatzForestEpsilon -> [(Epsilon,[Eta])] +forestEpsList f = map (\(a,b,c) -> (a,b)) fList'' + where + fList = flattenForestEpsilon f + fList' = sortBy (\(e1, e', Var x1 y1 ) (e2, e2', Var x2 y2) -> compare y1 y2) fList + fList'' = nubBy (\(e1, e1', Var x1 y1 ) (e2, e2', Var x2 y2) -> if x1 == 0 || x2 == 0 then error "zeros!!" else y1 == y2) fList' + +--output in latex format + +mkEtasLatex :: String -> Eta -> String +mkEtasLatex inds (Eta i j) = "\\eta^{" ++ etaI : etaJ : "}" + where + (etaI,etaJ) = (inds !! (i-1), inds !! (j-1) ) + +-- | Outputs the @'forestEtaList'@ in \( \LaTeX \) format. The @'String'@ argument is used to label the individual indices. +forestEtaListLatex :: AnsatzForestEta -> String -> Char -> String +forestEtaListLatex f inds var = tail $ concat etaL'' + where + etaL = sortBy (\(e1, Var x1 y1 ) (e2, Var x2 y2) -> compare y1 y2) $ flattenForest f + etaL' = nubBy (\(e1, Var x1 y1 ) (e2, Var x2 y2) -> if x1 == 0 || x2 == 0 then error "zeros!!" else y1 == y2) etaL + etaL'' = map (\(a,Var x y) -> "+" ++ var : "_{" ++ show y ++ "}\\cdot" ++ concatMap (mkEtasLatex inds) a) etaL' + +mkEpsLatex :: String -> Epsilon -> String +mkEpsLatex inds (Epsilon i j k l) = "\\epsilon^{" ++ epsi : epsj : epsk : epsl : "}" + where + (epsi, epsj, epsk, epsl) = (inds !! (i-1), inds !! (j-1), inds !! (k-1), inds !! (l-1)) + +-- | Outputs the @'forestEpsList'@ in \( \LaTeX \) format. The @'String'@ argument is used to label the individual indices. +forestEpsListLatex :: AnsatzForestEpsilon -> String -> Char -> String +forestEpsListLatex f inds var = tail $ concat epsL'' + where + epsL = sortBy (\(e1, e1', Var x1 y1 ) (e2, e2', Var x2 y2) -> compare y1 y2) $ flattenForestEpsilon f + epsL' = nubBy (\(e1, e1', Var x1 y1 ) (e2, e2', Var x2 y2) -> if x1 == 0 || x2 == 0 then error "zeros!!" else y1 == y2) epsL + epsL'' = map (\(a,b,Var x y) -> "+" ++ var : "_{" ++ show y ++ "}\\cdot" ++ mkEpsLatex inds a ++ concatMap (mkEtasLatex inds) b) epsL' + +--construct a forest of a given asclist + +mkForestFromAscList :: ([Eta],Var) -> AnsatzForestEta +mkForestFromAscList ([],var) = Leaf var +mkForestFromAscList (x:xs, var) = ForestEta $ M.singleton x $ mkForestFromAscList (xs,var) + +mkForestFromAscListEpsilon :: (Epsilon,[Eta],Var) -> AnsatzForestEpsilon +mkForestFromAscListEpsilon (x,y,z) = M.singleton x $ mkForestFromAscList (y,z) + +--canonicalize the individual etas and epsilons + +canonicalizeAnsatzEta :: AnsatzForestEta -> AnsatzForestEta +canonicalizeAnsatzEta = mapNodes sortEta + +canonicalizeAnsatzEpsilon :: AnsatzForestEpsilon -> AnsatzForestEpsilon +canonicalizeAnsatzEpsilon m = newMap + where + newMap = M.mapKeys sortEpsilon $ M.mapWithKey (\k v -> mapVars (multVar (getEpsSign k) ) v) $ M.map (mapNodes sortEta) m + +--sort a given AnsatzForest, i.e. bring the products of eta and epsilon to canonical order once the individual tensors are ordered canonically + +sortForest :: AnsatzForestEta -> AnsatzForestEta +sortForest f = foldl' addList2Forest EmptyForest fList + where + fList = flattenForest f + +sortForestEpsilon :: AnsatzForestEpsilon -> AnsatzForestEpsilon +sortForestEpsilon f = foldl' addList2ForestEpsilon M.empty fList + where + fList = flattenForestEpsilon f + +--swap functions for the symmetrization + +swapLabelF :: (Int,Int) -> Int -> Int +swapLabelF (x,y) z + | x == z = y + | y == z = x + | otherwise = z + +swapBlockLabelMap :: ([Int],[Int]) -> I.IntMap Int +swapBlockLabelMap (x,y) = swapF + where + swapF = I.fromList $ zip x y ++ zip y x + +swapLabelEta :: (Int,Int) -> Eta -> Eta +swapLabelEta inds (Eta x y) = Eta (f x) (f y) + where + f = swapLabelF inds + +swapLabelEpsilon :: (Int,Int) -> Epsilon -> Epsilon +swapLabelEpsilon inds (Epsilon i j k l) = Epsilon (f i) (f j) (f k) (f l) + where + f = swapLabelF inds + +swapBlockLabelEta :: I.IntMap Int -> Eta -> Eta +swapBlockLabelEta swapF (Eta i j) = Eta i' j' + where + i' = I.findWithDefault i i swapF + j' = I.findWithDefault j j swapF + +swapBlockLabelEpsilon :: I.IntMap Int -> Epsilon -> Epsilon +swapBlockLabelEpsilon swapF (Epsilon i j k l) = Epsilon i' j' k' l' + where + i' = I.findWithDefault i i swapF + j' = I.findWithDefault j j swapF + k' = I.findWithDefault k k swapF + l' = I.findWithDefault l l swapF + +swapLabelFEta :: (Int,Int) -> AnsatzForestEta -> AnsatzForestEta +swapLabelFEta inds ans = sortForest.canonicalizeAnsatzEta $ swapAnsatz + where + f = swapLabelEta inds + swapAnsatz = mapNodes f ans + +swapLabelFEps :: (Int,Int) -> AnsatzForestEpsilon -> AnsatzForestEpsilon +swapLabelFEps inds ans = sortForestEpsilon.canonicalizeAnsatzEpsilon $ swapAnsatz + where + f = swapLabelEpsilon inds + swapAnsatz = mapNodesEpsilon f $ M.map (swapLabelFEta inds) ans + +swapBlockLabelFEta :: I.IntMap Int -> AnsatzForestEta -> AnsatzForestEta +swapBlockLabelFEta swapF ans = sortForest.canonicalizeAnsatzEta $ swapAnsatz + where + f = swapBlockLabelEta swapF + swapAnsatz = mapNodes f ans + +swapBlockLabelFEps :: I.IntMap Int -> AnsatzForestEpsilon -> AnsatzForestEpsilon +swapBlockLabelFEps swapF ans = sortForestEpsilon.canonicalizeAnsatzEpsilon $ swapAnsatz + where + f = swapBlockLabelEpsilon swapF + swapAnsatz = mapNodesEpsilon f $ M.map (swapBlockLabelFEta swapF) ans + +--symmetrizer functions + +pairSymForestEta :: (Int,Int) -> AnsatzForestEta -> AnsatzForestEta +pairSymForestEta inds ans = addForests ans $ swapLabelFEta inds ans + +pairSymForestEps :: (Int,Int) -> AnsatzForestEpsilon -> AnsatzForestEpsilon +pairSymForestEps inds ans = addForestsEpsilon ans $ swapLabelFEps inds ans + +pairASymForestEta :: (Int,Int) -> AnsatzForestEta -> AnsatzForestEta +pairASymForestEta inds ans = addForests ans $ mapVars (multVar (-1)) $ swapLabelFEta inds ans + +pairASymForestEps :: (Int,Int) -> AnsatzForestEpsilon -> AnsatzForestEpsilon +pairASymForestEps inds ans = addForestsEpsilon ans $ mapVarsEpsilon (multVar (-1)) $ swapLabelFEps inds ans + +pairBlockSymForestEta :: I.IntMap Int -> AnsatzForestEta -> AnsatzForestEta +pairBlockSymForestEta swapF ans = addForests ans $ swapBlockLabelFEta swapF ans + +pairBlockSymForestEps :: I.IntMap Int -> AnsatzForestEpsilon -> AnsatzForestEpsilon +pairBlockSymForestEps swapF ans = addForestsEpsilon ans $ swapBlockLabelFEps swapF ans + +pairBlockASymForestEta :: I.IntMap Int -> AnsatzForestEta -> AnsatzForestEta +pairBlockASymForestEta swapF ans = addForests ans $ mapVars (multVar (-1)) $ swapBlockLabelFEta swapF ans + +pairBlockASymForestEps :: I.IntMap Int -> AnsatzForestEpsilon -> AnsatzForestEpsilon +pairBlockASymForestEps swapF ans = addForestsEpsilon ans $ mapVarsEpsilon (multVar (-1)) $ swapBlockLabelFEps swapF ans + +cyclicSymForestEta :: [Int] -> AnsatzForestEta -> AnsatzForestEta +cyclicSymForestEta inds ans = foldr (\y x -> addForests x $ swapBlockLabelFEta y ans ) ans perms + where + perms = map (I.fromList . zip inds) $ tail $ permutations inds + +cyclicSymForestEps :: [Int] -> AnsatzForestEpsilon -> AnsatzForestEpsilon +cyclicSymForestEps inds ans = foldr (\y x -> addForestsEpsilon x $ swapBlockLabelFEps y ans ) ans perms + where + perms = map (I.fromList . zip inds) $ tail $ permutations inds + +cyclicBlockSymForestEta :: [[Int]] -> AnsatzForestEta -> AnsatzForestEta +cyclicBlockSymForestEta inds ans = foldr (\y x -> addForests x $ swapBlockLabelFEta y ans ) ans perms + where + perms = map (I.fromList . zip (concat inds) . concat) $ tail $ permutations inds + +cyclicBlockSymForestEps :: [[Int]] -> AnsatzForestEpsilon-> AnsatzForestEpsilon +cyclicBlockSymForestEps inds ans = foldr (\y x -> addForestsEpsilon x $ swapBlockLabelFEps y ans ) ans perms + where + perms = map (I.fromList . zip (concat inds) . concat) $ tail $ permutations inds + +--general symmetrizer function + +symAnsatzForestEta ::Symmetry -> AnsatzForestEta -> AnsatzForestEta +symAnsatzForestEta (sym,asym,blocksym,cyclicsym,cyclicblocksym) ans = + foldr cyclicBlockSymForestEta ( + foldr cyclicSymForestEta ( + foldr pairBlockSymForestEta ( + foldr pairASymForestEta ( + foldr pairSymForestEta ans sym + ) asym + ) blockSymMap + ) cyclicsym + ) cyclicblocksym + where + blockSymMap = map swapBlockLabelMap blocksym + +symAnsatzForestEps :: Symmetry -> AnsatzForestEpsilon -> AnsatzForestEpsilon +symAnsatzForestEps (sym,asym,blocksym,cyclicsym,cyclicblocksym) ans = + foldr cyclicBlockSymForestEps ( + foldr cyclicSymForestEps ( + foldr pairBlockSymForestEps ( + foldr pairASymForestEps ( + foldr pairSymForestEps ans sym + ) asym + ) blockSymMap + ) cyclicsym + ) cyclicblocksym + where + blockSymMap = map swapBlockLabelMap blocksym + +--convert the indLists to lists of eta and or epsilon tensors, if present epsilons are always first + +mkEtaList :: [Int] -> [Eta] +mkEtaList [] = [] +mkEtaList x = Eta a b : mkEtaList rest + where + [a,b] = take 2 x + rest = drop 2 x + +mkEpsilonList :: [Int] -> (Epsilon,[Eta]) +mkEpsilonList x = (Epsilon i j k l , mkEtaList rest) + where + [i,j,k,l] = take 4 x + rest = drop 4 x + +mkEtaList' :: Var -> [Int] -> ([Eta],Var) +mkEtaList' var l = (mkEtaList l, var) + +mkEpsilonList' :: Var -> [Int] -> (Epsilon,[Eta],Var) +mkEpsilonList' var l = (eps, eta, var) + where + (eps,eta) = mkEpsilonList l + +--look up a 1d Forest (obtained from the index list) in the given Forest + +isElem :: [Eta] -> AnsatzForestEta -> Bool +isElem [] (Leaf x) = True +isElem x EmptyForest = False +isElem (x:xs) (ForestEta m) = case mForest of + Just forest -> xs `isElem` forest + _ -> False + where + mForest = M.lookup x m + +isElemEpsilon :: (Epsilon, [Eta]) -> AnsatzForestEpsilon -> Bool +isElemEpsilon (eps,l) m = case mForest of + Just forest -> l `isElem` forest + _ -> False + where + mForest = M.lookup eps m + +--reduce a list of possible ansätze w.r.t the present symmetries, no numerical evaluation + +reduceAnsatzEta' :: Symmetry -> [([Eta],Var)] -> AnsatzForestEta +reduceAnsatzEta' sym = foldl' addOrRem' EmptyForest + where + addOrRem' f ans = if isElem (fst ans) f then f else addForests f (symAnsatzForestEta sym $ mkForestFromAscList ans) + +reduceAnsatzEpsilon' :: Symmetry -> [(Epsilon, [Eta], Var)] -> AnsatzForestEpsilon +reduceAnsatzEpsilon' sym = foldl' addOrRem' M.empty + where + addOrRem' f (x,y,z) = if isElemEpsilon (x,y) f then f else addForestsEpsilon f (symAnsatzForestEps sym $ mkForestFromAscListEpsilon (x,y,z)) + +mkAllVars :: [Var] +mkAllVars = map (Var 1) [1..] + +--construct the full algebraic forest for a given number of indices and given symmetries, no numerical reduction to a basis + +getEtaForestFast :: Int -> Symmetry -> AnsatzForestEta +getEtaForestFast ord syms = relabelAnsatzForest 1 $ reduceAnsatzEta' syms allForests + where + allInds = getEtaInds [1..ord] syms + allVars = mkAllVars + allForests = zipWith mkEtaList' allVars allInds + +getEpsForestFast :: Int -> Symmetry -> AnsatzForestEpsilon +getEpsForestFast ord syms = if ord < 4 then M.empty else relabelAnsatzForestEpsilon 1 $ reduceAnsatzEpsilon' syms allForests + where + allInds = getEpsilonInds [1..ord] syms + allVars = mkAllVars + allForests = zipWith mkEpsilonList' allVars allInds + + +{-- +The next part is evaluating a given AnsatzTree numerically. This is necessary to remove linear dependencies +that occur due to implicit anti-symmetries in 5 or more indices. +--} + +--evaluate the nodes, i.e. eta and epsilon + +evalNodeEta :: I.IntMap Int -> Eta -> Maybe Int +evalNodeEta iMap (Eta x y) + | a == b && a == 0 = Just (-1) + | a == b = Just 1 + | otherwise = Nothing + where + [a,b] = [(I.!) iMap x, (I.!) iMap y] + +evalNodeEpsilon :: I.IntMap Int -> Epsilon -> Maybe Int +evalNodeEpsilon iMap (Epsilon w x y z) = M.lookup l epsMap + where + l = [(I.!) iMap w, (I.!) iMap x, (I.!) iMap y, (I.!) iMap z] + +epsMap :: M.Map [Int] Int +epsMap = M.fromList $ map (\x -> (x, epsSign x)) $ permutations [0,1,2,3] + where + epsSign [i,j,k,l] = (-1) ^ length (filter (==True) [j>i,k>i,l>i,k>j,l>j,l>k]) + +--basic tree eval function + +evalAnsatzForestEta :: I.IntMap Int -> AnsatzForestEta -> I.IntMap Int +evalAnsatzForestEta evalM (Leaf (Var x y)) = I.singleton y x +evalAnsatzForestEta evalM (ForestEta m) = M.foldlWithKey' foldF I.empty m + where + foldF b k a = let nodeVal = evalNodeEta evalM k + in if isNothing nodeVal then b + else I.unionWith (+) (I.map (fromJust nodeVal *) (evalAnsatzForestEta evalM a)) b +evalAnsatzForestEta evalM EmptyForest = I.empty + +evalAnsatzForestEpsilon :: I.IntMap Int -> AnsatzForestEpsilon -> I.IntMap Int +evalAnsatzForestEpsilon evalM = M.foldlWithKey' foldF I.empty + where + foldF b k a = let nodeVal = evalNodeEpsilon evalM k + in if isNothing nodeVal then b + else I.unionWith (+) (I.map (fromJust nodeVal *) (evalAnsatzForestEta evalM a)) b + +--for a single Ansatz we do not need the IntMap to keep track of the VarLabels -> eval to a number + +eval1AnsatzForestEta :: I.IntMap Int -> AnsatzForestEta -> Int +eval1AnsatzForestEta evalM (Leaf (Var x _)) = x +eval1AnsatzForestEta evalM (ForestEta m) = M.foldlWithKey' foldF 0 m + where + foldF b k a = let nodeVal = evalNodeEta evalM k + in if isNothing nodeVal then b + else b + (fromJust nodeVal * eval1AnsatzForestEta evalM a) +eval1AnsatzForestEta evalM EmptyForest = 0 + +eval1AnsatzForestEpsilon :: I.IntMap Int -> AnsatzForestEpsilon -> Int +eval1AnsatzForestEpsilon evalM = M.foldlWithKey' foldF 0 + where + foldF b k a = let nodeVal = evalNodeEpsilon evalM k + in if isNothing nodeVal then b + else b + (fromJust nodeVal * eval1AnsatzForestEta evalM a) + +--eval a given 1Var ansatz to a sparse Matrix (a row vector) -> Eigen Indices start at 0 !! + +mkVecList mkAns dofList evalM = vecList + where + l' = mapMaybe mkAns dofList + l = runEval $ parListChunk 500 rdeepseq l' + lVals = map (\(x,y,z) -> z) l + max = maximum lVals + n = length evalM + vecList = let vec = Sparse.fromList 1 n l in + if null l then Nothing else Just $ Sparse.scale (1/max) vec + + +evalAnsatzEtaVecListEig :: [I.IntMap Int] -> AnsatzForestEta -> Maybe Sparse.SparseMatrixXd +evalAnsatzEtaVecListEig evalM EmptyForest = Nothing +evalAnsatzEtaVecListEig evalM f = mkVecList mkAns dofList evalM + where + dofList = zip [0..] evalM + mkAns (i,j) = let ansVal = eval1AnsatzForestEta j f + in if ansVal == 0 then Nothing else Just (0,i, fromIntegral ansVal) + +evalAnsatzEpsilonVecListEig :: [I.IntMap Int] -> AnsatzForestEpsilon -> Maybe Sparse.SparseMatrixXd +evalAnsatzEpsilonVecListEig evalM f = if f == M.empty then Nothing else mkVecList mkAns dofList evalM + where + dofList = zip [0..] evalM + mkAns (i,j) = let ansVal = eval1AnsatzForestEpsilon j f + in if ansVal == 0 then Nothing else Just (0,i, fromIntegral ansVal) + +--eval a given Forest for all inds + +type AssocsList a = [([(Int,Int)],a)] + +type AssocsListAbs a = [([(Int,Int)],Int,a)] + + +evalAllEta :: [I.IntMap Int] -> AnsatzForestEta -> [[(Int,Int)]] +evalAllEta [] f = [] +evalAllEta evalMs EmptyForest = [] +evalAllEta evalMs f = l' + where + l = map (\x -> filter (\(a,b) -> b /= 0) $ I.assocs $ evalAnsatzForestEta x f) evalMs + l' = runEval $ parListChunk 500 rdeepseq l + +evalAllTensorEta :: (NFData a) => [(I.IntMap Int, a)] -> AnsatzForestEta -> AssocsList a +evalAllTensorEta [] f = [] +evalAllTensorEta evalMs EmptyForest = [] +evalAllTensorEta evalMs f = l' + where + l = map (\(x,z) -> (filter (\(a,b) -> b /= 0) $ I.assocs $ evalAnsatzForestEta x f,z)) evalMs + l' = runEval $ parListChunk 500 rdeepseq l + +evalAllEpsilon :: [I.IntMap Int] -> AnsatzForestEpsilon -> [[(Int,Int)]] +evalAllEpsilon [] f = [] +evalAllEpsilon evalMs f = if f == M.empty then [] else l' + where + l = map (\x -> filter (\(a,b) -> b /= 0) $ I.assocs $ evalAnsatzForestEpsilon x f) evalMs + l' = runEval $ parListChunk 500 rdeepseq l + +evalAllTensorEpsilon :: (NFData a) => [(I.IntMap Int, a)] -> AnsatzForestEpsilon -> AssocsList a +evalAllTensorEpsilon [] f = [] +evalAllTensorEpsilon evalMs f = if f == M.empty then [] else l' + where + l = map (\(x,z) -> ( filter (\(a,b) -> b /= 0) $ I.assocs $ evalAnsatzForestEpsilon x f,z)) evalMs + l' = runEval $ parListChunk 500 rdeepseq l + +evalAllTensorEtaAbs :: (NFData a) => [(I.IntMap Int, Int, a)] -> AnsatzForestEta -> AssocsListAbs a +evalAllTensorEtaAbs [] f = [] +evalAllTensorEtaAbs evalMs EmptyForest = [] +evalAllTensorEtaAbs evalMs f = l' + where + l = map (\(x,y,z) -> (filter (\(a,b) -> b /= 0) $ I.assocs $ evalAnsatzForestEta x f, y,z)) evalMs + l' = runEval $ parListChunk 500 rdeepseq l + +evalAllTensorEpsilonAbs :: (NFData a) => [(I.IntMap Int, Int, a)] -> AnsatzForestEpsilon -> AssocsListAbs a +evalAllTensorEpsilonAbs [] f = [] +evalAllTensorEpsilonAbs evalMs f = if f == M.empty then [] else l' + where + l = map (\(x,y,z) -> ( filter (\(a,b) -> b /= 0) $ I.assocs $ evalAnsatzForestEpsilon x f, y,z)) evalMs + l' = runEval $ parListChunk 500 rdeepseq l + + +{-- +Now there are two ways how we can proceed in removing the linear dependencies and thus constructing a basis: + +1) the memory optimized way, constructing a lin indep tree from the very beginning + the first step is to check whether a given Ansatz is element of the span of the previous ansätze and therefore can be discarded + +2) the second way is constructing a given Ansatz by first reducing only algebraically, and later on evaluating the whole forest + to a matrix and reducing the matrix numerically. + +We start with the first way. +--} + +type RankDataEig = (Mat.MatrixXd, Sparse.SparseMatrixXd) + +getVarNrEig :: RankDataEig -> Int +getVarNrEig = Sparse.rows . snd + +--check in each step if the new ansatz vector is linear dependant w.r.t. the ansatz vectors obtained previously + +checkNumericLinDepEig :: RankDataEig -> Maybe Sparse.SparseMatrixXd -> Maybe RankDataEig +checkNumericLinDepEig (lastMat, lastFullMat) (Just newVec) + | eigenRank < maxRank = Nothing + | otherwise = Just (newMat, newAnsatzMat) + where + newVecTrans = Sparse.transpose newVec + scalar = Sparse.toMatrix $ Sparse.mul newVec newVecTrans + prodBlock = Sparse.toMatrix $ Sparse.mul lastFullMat newVecTrans + prodBlockTrans = Mat.transpose prodBlock + newMat = concatBlockMat lastMat prodBlock prodBlockTrans scalar + eigenRank = Sol.rank Sol.FullPivLU newMat + maxRank = min (Mat.cols newMat) (Mat.rows newMat) + newAnsatzMat = Sparse.fromRows $ Sparse.getRows lastFullMat ++ [newVec] +checkNumericLinDepEig (lastMat, lastFullMat) Nothing = Nothing + +--concat Matrices to a block Matrix + +concatBlockMat :: Mat.MatrixXd -> Mat.MatrixXd -> Mat.MatrixXd -> Mat.MatrixXd -> Mat.MatrixXd +concatBlockMat a b c d = newMat + where + newUpper = zipWith (++) (Mat.toList a) (Mat.toList b) + newLower = zipWith (++) (Mat.toList c) (Mat.toList d) + newMat = Mat.fromList $ newUpper ++ newLower + +--in each step add the new AnsatzVector to the forest iff it is lin indep of the previous vectors + +{- +alreadyPresentIO n total rDat + = putStrLn $ progress n total ++ " : " ++ "already present, not added, ansatz rank is " ++ show (getVarNrEig rDat) +notPresentNotAddedIO n total rDat + = putStrLn $ progress n total ++ " : " ++ "not present, linearly dependent, not added, ansatz rank is " ++ show (getVarNrEig rDat) +notPresentAddedIO n total rDat + = putStrLn $ progress n total ++ " : " ++ "not present, linearly independent, added, ansatz rank is " ++ show (getVarNrEig rDat) +progress n total + = show n ++ " of " ++ show total +-} + +getNewRDat evalM newAns rDat = newRDat + where + newVec = evalAnsatzEtaVecListEig evalM newAns + newRDat = checkNumericLinDepEig rDat newVec + +getNewRDatEps evalM newAns rDat = newRDat + where + newVec = evalAnsatzEpsilonVecListEig evalM newAns + newRDat = checkNumericLinDepEig rDat newVec + +getNewAns symList etaList rDat = symAnsatzForestEta symList $ mkForestFromAscList (etaList,Var 1 (getVarNrEig rDat + 1)) +getNewAnsEps symList epsList etaList rDat = symAnsatzForestEps symList $ mkForestFromAscListEpsilon (epsList,etaList,Var 1 (getVarNrEig rDat + 1)) + +{- +addOrDiscardEtaEigIO :: Symmetry -> Int -> [I.IntMap Int] -> (AnsatzForestEta, RankDataEig) -> (Int, [Eta]) -> IO (AnsatzForestEta, RankDataEig) +addOrDiscardEtaEigIO symList len evalM (ans,rDat) (num, etaL) + | isElem etaL ans = do + alreadyPresentIO num len rDat + return (ans,rDat) + | otherwise = case newRDat of + Nothing -> do + notPresentNotAddedIO num len rDat + return (ans,rDat) + Just newRDat' -> do + notPresentAddedIO num len newRDat' + return (sumAns,newRDat') + where + newAns = getNewAns symList etaL rDat + newRDat = getNewRDat evalM newAns rDat + sumAns = addForests ans newAns +-} + +addOrDiscardEtaEig :: Symmetry -> [I.IntMap Int] -> (AnsatzForestEta, RankDataEig) -> [Eta] -> (AnsatzForestEta, RankDataEig) +addOrDiscardEtaEig symList evalM (ans,rDat) etaL + | isElem etaL ans = (ans,rDat) + | otherwise = case newRDat of + Nothing -> (ans,rDat) + Just newRDat' -> (sumAns,newRDat') + where + newAns = getNewAns symList etaL rDat + newRDat = getNewRDat evalM newAns rDat + sumAns = addForests ans newAns + + +{- +addOrDiscardEpsilonEigIO :: Symmetry -> Int -> [I.IntMap Int] -> (AnsatzForestEpsilon, RankDataEig) -> (Int,(Epsilon,[Eta])) -> IO (AnsatzForestEpsilon, RankDataEig) +addOrDiscardEpsilonEigIO symList len evalM (ans,rDat) (num,(epsL,etaL)) + | isElemEpsilon (epsL,etaL) ans = do + alreadyPresentIO num len rDat + return (ans,rDat) + | otherwise = case newRDat of + Nothing -> do + notPresentNotAddedIO num len rDat + let r = getVarNrEig rDat + + return (ans,rDat) + Just newRDat' -> do + notPresentAddedIO num len newRDat' + return (sumAns,newRDat') + where + newAns = getNewAnsEps symList epsL etaL rDat + newRDat = getNewRDatEps evalM newAns rDat + sumAns = addForestsEpsilon ans newAns +-} + +addOrDiscardEpsilonEig :: Symmetry -> [I.IntMap Int] -> (AnsatzForestEpsilon, RankDataEig) -> (Epsilon,[Eta]) -> (AnsatzForestEpsilon, RankDataEig) +addOrDiscardEpsilonEig symList evalM (ans,rDat) (epsL,etaL) + | isElemEpsilon (epsL,etaL) ans = (ans,rDat) + | otherwise = case newRDat of + Nothing -> (ans,rDat) + Just newRDat' -> (sumAns,newRDat') + where + newAns = getNewAnsEps symList epsL etaL rDat + newRDat = getNewRDatEps evalM newAns rDat + sumAns = addForestsEpsilon ans newAns + + +--construct the RankData from the first nonzero Ansatz + +{- +mk1stRankDataEtaEigIO :: Symmetry -> Int -> [(Int,[Eta])] -> [I.IntMap Int] -> IO (AnsatzForestEta,RankDataEig,[(Int,[Eta])]) +mk1stRankDataEtaEigIO symL numEta etaL evalM = + do + putStrLn $ show (fst $ head etaL) ++ " of " ++ show numEta + let newAns = symAnsatzForestEta symL $ mkForestFromAscList (snd $ head etaL,Var 1 1) + let newVec = evalAnsatzEtaVecListEig evalM newAns + let restList = tail etaL + case newVec of + Nothing -> if null restList then return (EmptyForest ,(Mat.fromList [], Sparse.fromList 0 0 []),[]) else mk1stRankDataEtaEigIO symL numEta restList evalM + Just newVec' -> return (newAns, (newMat, newVec'), restList) + where + newVecTrans = Sparse.transpose newVec' + newMat = Sparse.toMatrix $ Sparse.mul newVec' newVecTrans +-} + +mk1stRankDataEtaEig :: Symmetry -> [[Eta]] -> [I.IntMap Int] -> (AnsatzForestEta,RankDataEig,[[Eta]]) +mk1stRankDataEtaEig symL etaL evalM = output + where + newAns = symAnsatzForestEta symL $ mkForestFromAscList (head etaL,Var 1 1) + newVec = evalAnsatzEtaVecListEig evalM newAns + restList = tail etaL + output = case newVec of + Nothing -> if null restList then (EmptyForest,(Mat.fromList [], Sparse.fromList 0 0 []),[]) else mk1stRankDataEtaEig symL restList evalM + Just newVec' -> (newAns, (newMat, newVec'), restList) + where + newVecTrans = Sparse.transpose newVec' + newMat = Sparse.toMatrix $ Sparse.mul newVec' newVecTrans + + +mk1stRankDataEpsilonEig :: Symmetry -> [(Epsilon,[Eta])] -> [I.IntMap Int] -> (AnsatzForestEpsilon,RankDataEig,[(Epsilon,[Eta])]) +mk1stRankDataEpsilonEig symL epsL evalM = output + where + newAns = symAnsatzForestEps symL $ mkForestFromAscListEpsilon (fst $ head epsL, snd $ head epsL,Var 1 1) + newVec = evalAnsatzEpsilonVecListEig evalM newAns + restList = tail epsL + output = case newVec of + Nothing -> if null restList then (M.empty,(Mat.fromList [], Sparse.fromList 0 0 []),[]) else mk1stRankDataEpsilonEig symL restList evalM + Just newVec' -> (newAns,(newMat, newVec'), restList) + where + newVecTrans = Sparse.transpose newVec' + newMat = Sparse.toMatrix $ Sparse.mul newVec' newVecTrans + + +--finally reduce the ansatzList (IO versions print the current status for longer computations will follow with the next versions) + + +reduceAnsatzEtaEig :: Symmetry -> [[Eta]] -> [I.IntMap Int] -> (AnsatzForestEta,Sparse.SparseMatrixXd) +reduceAnsatzEtaEig symL etaL evalM + | null evalM = (EmptyForest, Sparse.fromList 0 0 []) + | null etaL = (EmptyForest, Sparse.fromList 0 0 []) + | otherwise = (finalForest, finalMat) + where + (ans1,rDat1,restEtaL) = mk1stRankDataEtaEig symL etaL evalM + (finalForest, (_,finalMat)) = foldl' (addOrDiscardEtaEig symL evalM) (ans1,rDat1) restEtaL + +reduceAnsatzEpsilonEig :: Symmetry -> [(Epsilon,[Eta])] -> [I.IntMap Int] -> (AnsatzForestEpsilon,Sparse.SparseMatrixXd) +reduceAnsatzEpsilonEig symL epsL evalM + | null evalM = (M.empty, Sparse.fromList 0 0 []) + | null epsL = (M.empty, Sparse.fromList 0 0 []) + | otherwise = (finalForest, finalMat) + where + (ans1,rDat1,restEpsL) = mk1stRankDataEpsilonEig symL epsL evalM + (finalForest, (_,finalMat)) = foldl' (addOrDiscardEpsilonEig symL evalM) (ans1,rDat1) restEpsL + +--construct a basis ansatz forest + +getEtaForestEig :: Int -> Symmetry -> [I.IntMap Int] -> (AnsatzForestEta,Sparse.SparseMatrixXd) +getEtaForestEig ord sym [] = (EmptyForest, Sparse.fromList 0 0 []) +getEtaForestEig ord sym evalMs + | null allEtaLists = (EmptyForest, Sparse.fromList 0 0 []) + | otherwise = reduceAnsatzEtaEig sym allEtaLists evalMs + where + allInds = getEtaInds [1..ord] sym + allEtaLists = map mkEtaList allInds + +getEpsForestEig :: Int -> Symmetry -> [I.IntMap Int] -> (AnsatzForestEpsilon,Sparse.SparseMatrixXd) +getEpsForestEig ord sym [] = (M.empty, Sparse.fromList 0 0 []) +getEpsForestEig ord sym evalMs + | null allEpsLists = (M.empty, Sparse.fromList 0 0 []) + | otherwise = reduceAnsatzEpsilonEig sym allEpsLists evalMs + where + allInds = getEpsilonInds [1..ord] sym + allEpsLists = map mkEpsilonList allInds + +--eta and eps forest combined + +getFullForestEig :: Int -> Symmetry -> [I.IntMap Int] -> [I.IntMap Int] -> (AnsatzForestEta, AnsatzForestEpsilon, Sparse.SparseMatrixXd, Sparse.SparseMatrixXd) +getFullForestEig ord sym evalMEta evalMEps = (etaAns, epsAns, etaMat, epsMat) + where + (etaAns,etaMat) = getEtaForestEig ord sym evalMEta + (epsAns',epsMat) = getEpsForestEig ord sym evalMEps + epsAns = relabelAnsatzForestEpsilon (1 + length (getForestLabels etaAns)) epsAns' + +{-- +Finally we can evaluated the ansatz trees to a contravariant tensor with spacetime indices +Sym version outputs the fully symmetrized ansatz tensor, this is however expensive, non Sym version computes the non symmetrized ansatz +tensor, i.e. only 1 representative out of each symmetry equivalence class is non zero. It is important to note that when contracting the non symmetrized +tensor with another tensor with given symmetry one needs to account for the now missing multiplicities from the symmetries as in the construction of ansätze +we used factor less symmetrizer functions. +--} + +evalToTensSym :: Symmetry -> [(I.IntMap Int, IndTupleST n1 0)] -> [(I.IntMap Int, IndTupleST n1 0)] -> AnsatzForestEta -> AnsatzForestEpsilon -> STTens n1 0 AnsVarR +evalToTensSym (p,ap,b,c,bc) evalEta evalEps ansEta ansEps = symTens + where + p' = map (\(x,y) -> (x-1,y-1)) p + ap' = map (\(x,y) -> (x-1,y-1)) ap + b' = map (\(x,y) -> (map (\z -> z-1) x, map (\z' -> z'-1) y) ) b + c' = map (map (subtract 1)) c + bc' = map (map (map (subtract 1))) bc + tens = evalToTens evalEta evalEps ansEta ansEps + symTens = foldr cyclicBlockSymATens1 ( + foldr cyclicSymATens1 ( + foldr symBlockATens1 ( + foldr aSymATens1 ( + foldr symATens1 tens p' + ) ap' + ) b' + ) c' + ) bc' + +evalToTens :: [(I.IntMap Int, IndTupleST n1 0)] -> [(I.IntMap Int, IndTupleST n1 0)] -> AnsatzForestEta -> AnsatzForestEpsilon -> STTens n1 0 AnsVarR +evalToTens evalEta evalEps ansEta ansEps = tens + where + etaL = evalAllTensorEta evalEta ansEta + epsL = evalAllTensorEpsilon evalEps ansEps + etaL' = map (\(x,indTuple) -> (indTuple, AnsVar $ I.fromList $ map (\(i,r) -> (i,SField $ fromIntegral r)) x)) etaL + epsL' = map (\(x,indTuple) -> (indTuple, AnsVar $ I.fromList $ map (\(i,r) -> (i,SField $ fromIntegral r)) x)) epsL + etaRmL = filter (\(_,AnsVar b) -> not $ I.null b) etaL' + epsRmL = filter (\(_,AnsVar b) -> not $ I.null b) epsL' + tens = fromListT2 etaRmL &+ fromListT2 epsRmL + +--eval to abstract tensor type taking into account possible block symmetries and multiplicity of the ansätze + +evalToTensAbs :: [(I.IntMap Int, Int, [IndTupleAbs n1 0 n2 0 n3 0])] -> [(I.IntMap Int, Int, [IndTupleAbs n1 0 n2 0 n3 0])] -> AnsatzForestEta -> AnsatzForestEpsilon -> ATens n1 0 n2 0 n3 0 AnsVarR +evalToTensAbs evalEta evalEps ansEta ansEps = fromListT6 etaRmL &+ fromListT6 epsRmL + where + etaL = evalAllTensorEtaAbs evalEta ansEta + epsL = evalAllTensorEpsilonAbs evalEps ansEps + etaL' = map (\(x,mult,indTuple) -> (indTuple, AnsVar $ I.fromList $ map (\(i,r) -> (i,fromIntegral $ r*mult)) x)) etaL + epsL' = map (\(x,mult,indTuple) -> (indTuple, AnsVar $ I.fromList $ map (\(i,r) -> (i,fromIntegral $ r*mult)) x)) epsL + etaRmL = filter (\(_,AnsVar b) -> not $ I.null b) $ concatMap (\(x,y) -> zip x (repeat y)) etaL' + epsRmL = filter (\(_,AnsVar b) -> not $ I.null b) $ concatMap (\(x,y) -> zip x (repeat y)) epsL' + +--the 2 final functions, constructing the 2 AnsatzForests and the AnsatzTensor (currently the list of symmetry DOFs must be specified by hand -> this can also yield a performance advantage) + +mkEvalMap :: Int -> [Int] -> I.IntMap Int +mkEvalMap i = I.fromList . zip [1..i] + +mkEvalMaps :: [[Int]] -> [I.IntMap Int] +mkEvalMaps l = let s = length (head l) in map (mkEvalMap s) l + +mkEvalMapsInds :: forall (n :: Nat). SingI n => [[Int]] -> [(I.IntMap Int, IndTupleST n 0)] +mkEvalMapsInds l = let s = length (head l) in map (\x -> (mkEvalMap s x, (fromList $ map toEnum x, Empty))) l + +mkAllEvalMaps :: forall (n :: Nat). SingI n => Symmetry -> [[Int]] -> ([I.IntMap Int], [I.IntMap Int], [(I.IntMap Int, IndTupleST n 0)], [(I.IntMap Int, IndTupleST n 0)]) +mkAllEvalMaps sym l = (evalMEtaRed, evalMEpsRed, evalMEtaInds, evalMEpsInds) + where + evalLEta = filter isEtaList l + evalLEps = filter isEpsilonList l + evalLEtaRed = filter (isLorentzEval sym) evalLEta + evalLEpsRed = filter (isLorentzEval sym) evalLEps + evalMEtaRed = mkEvalMaps evalLEtaRed + evalMEpsRed = mkEvalMaps evalLEpsRed + evalMEtaInds = mkEvalMapsInds evalLEta + evalMEpsInds = mkEvalMapsInds evalLEps + + +mkAllEvalMapsAbs :: Symmetry -> [([Int], Int, [IndTupleAbs n1 0 n2 0 n3 0])] -> ([I.IntMap Int], [I.IntMap Int], [(I.IntMap Int, Int, [IndTupleAbs n1 0 n2 0 n3 0])], [(I.IntMap Int, Int, [IndTupleAbs n1 0 n2 0 n3 0])]) +mkAllEvalMapsAbs sym l = (evalMEtaRed, evalMEpsRed, evalMEtaInds, evalMEpsInds) + where + (headList,_,_) = head l + ord = length headList + evalLEta = filter (\(x,_,_) -> isEtaList x) l + evalLEps = filter (\(x,_,_) -> isEpsilonList x) l + evalLEtaRed = map (\(a,_,_) -> a) $ filter (\(x,_,_) -> isLorentzEval sym x) evalLEta + evalLEpsRed = map (\(a,_,_) -> a) $ filter (\(x,_,_) -> isLorentzEval sym x) evalLEps + evalMEtaRed = mkEvalMaps evalLEtaRed + evalMEpsRed = mkEvalMaps evalLEpsRed + evalMEtaInds = map (\(x,y,z) -> (mkEvalMap ord x, y, z)) evalLEta + evalMEpsInds = map (\(x,y,z) -> (mkEvalMap ord x, y, z)) evalLEps + +-- | The function is similar to @'mkAnsatzTensorFastSym'@ yet it uses an algorithm that prioritizes memory usage over fast computation times. +mkAnsatzTensorEigSym :: forall (n :: Nat). SingI n => Int -> Symmetry -> [[Int]] -> (AnsatzForestEta, AnsatzForestEpsilon, STTens n 0 AnsVarR) +mkAnsatzTensorEigSym ord symmetries evalL = (ansEta, ansEps, tens) + where + (evalMEtaRed, evalMEpsRed, evalMEtaInds, evalMEpsInds) = mkAllEvalMaps symmetries evalL + (ansEta, ansEps, _, _) = getFullForestEig ord symmetries evalMEtaRed evalMEpsRed + tens = evalToTensSym symmetries evalMEtaInds evalMEpsInds ansEta ansEps + +-- | The function is similar to @'mkAnsatzTensorFast'@ yet it uses an algorithm that prioritizes memory usage over fast computation times. +mkAnsatzTensorEig :: forall (n :: Nat). SingI n => Int -> Symmetry -> [[Int]] -> (AnsatzForestEta, AnsatzForestEpsilon, STTens n 0 AnsVarR) +mkAnsatzTensorEig ord symmetries evalL = (ansEta, ansEps, tens) + where + (evalMEtaRed, evalMEpsRed, evalMEtaInds, evalMEpsInds) = mkAllEvalMaps symmetries evalL + (ansEta, ansEps, _, _) = getFullForestEig ord symmetries evalMEtaRed evalMEpsRed + tens = evalToTens evalMEtaInds evalMEpsInds ansEta ansEps + +-- | The function is similar to @'mkAnsatzTensorFastAbs'@ yet it uses an algorithm that prioritizes memory usage over fast computation times. +mkAnsatzTensorEigAbs :: Int -> Symmetry -> [([Int], Int, [IndTupleAbs n1 0 n2 0 n3 0])] -> (AnsatzForestEta, AnsatzForestEpsilon, ATens n1 0 n2 0 n3 0 AnsVarR) +mkAnsatzTensorEigAbs ord symmetries evalL = (ansEta, ansEps, tens) + where + (evalMEtaRed, evalMEpsRed, evalMEtaInds, evalMEpsInds) = mkAllEvalMapsAbs symmetries evalL + (ansEta, ansEps, _, _) = getFullForestEig ord symmetries evalMEtaRed evalMEpsRed + tens = evalToTensAbs evalMEtaInds evalMEpsInds ansEta ansEps + + +--now we start with the second way + +assocsToEig :: [[(Int,Int)]] -> Mat.MatrixXd +assocsToEig l = Sparse.toMatrix $ Sparse.fromList n m l' + where + l' = concat $ zipWith (\r z -> map (\(x,y) -> (z-1, x-1, fromIntegral y)) r) l [1..] + n = maximum (map (\(x,_,_) -> x) l') + 1 + m = maximum (map (\(_,x,_) -> x) l') + 1 + +--filter the lin. dependant vars from the Assocs List +{- +optimized version, requires custom eigen build + +getPivots' :: [[(Int,Int)]] -> [Int] +getPivots' l = map (1+) p + where + mat = assocsToEig l + p = Sol.pivots Sol.FullPivLU mat +-} + +getPivots :: [[(Int,Int)]] -> [Int] +getPivots l = map (1+) p + where + mat = assocsToEig l + pMatTr = Mat.toList $ Mat.transpose $ Sol.image Sol.FullPivLU mat + matTr = Mat.toList $ Mat.transpose mat + p = mapMaybe (`elemIndex` matTr) pMatTr + + + +--reduce linear deps in the ansätze + +reduceLinDepsFastEta :: [I.IntMap Int] -> Symmetry -> AnsatzForestEta -> AnsatzForestEta +reduceLinDepsFastEta evalM symL ansEta = newEtaAns + where + etaL = evalAllEta evalM ansEta + etaVars = getPivots etaL + allEtaVars = getForestLabels ansEta + remVarsEta = allEtaVars \\ etaVars + newEtaAns = relabelAnsatzForest 1 $ removeVarsEta remVarsEta ansEta + +reduceLinDepsFastEps :: [I.IntMap Int] -> Symmetry -> AnsatzForestEpsilon -> AnsatzForestEpsilon +reduceLinDepsFastEps evalM symL ansEps = newEpsAns + where + epsL = evalAllEpsilon evalM ansEps + epsVars = getPivots epsL + allEpsVars = getForestLabelsEpsilon ansEps + remVarsEps = allEpsVars \\ epsVars + newEpsAns = relabelAnsatzForestEpsilon 1 $ removeVarsEps remVarsEps ansEps + +--final function, fast way of constructing the ansatz trees and the 2 tensors (again the list of symmetry DOFs bust be specified but this can yield a performance advantage) + +mkAnsatzFast :: Int -> Symmetry -> [I.IntMap Int] -> [I.IntMap Int] -> (AnsatzForestEta, AnsatzForestEpsilon) +mkAnsatzFast ord symmetries evalMEtaRed evalMEpsRed = (ansEtaRed, ansEpsRed) + where + ansEta = getEtaForestFast ord symmetries + ansEpsilon = getEpsForestFast ord symmetries + ansEtaRed = reduceLinDepsFastEta evalMEtaRed symmetries ansEta + ansEpsRed' = reduceLinDepsFastEps evalMEpsRed symmetries ansEpsilon + ansEpsRed = relabelAnsatzForestEpsilon (1 + length (getForestLabels ansEtaRed)) ansEpsRed' + +-- | The function computes all linear independent ansätze that have rank specified by the first integer argument and further satisfy the symmetry specified by the @'Symmetry'@ value. +-- The additional argument of type @[['Int']]@ is used to provide the information of all (by means of the symmetry at hand) independent components of the ansätze. +-- Explicit examples how this information can be computed are provided by the functions for @'areaList4'@, ... and also by @'metricList2'@, ... . +-- The output is given as spacetime tensor @'STTens'@ and is explicitly symmetrized. +mkAnsatzTensorFastSym :: forall (n :: Nat). SingI n => Int -> Symmetry -> [[Int]]-> (AnsatzForestEta, AnsatzForestEpsilon, STTens n 0 AnsVarR) +mkAnsatzTensorFastSym ord symmetries evalL = (ansEta, ansEps, tens) + where + (evalMEtaRed, evalMEpsRed, evalMEtaInds, evalMEpsInds) = mkAllEvalMaps symmetries evalL + (ansEta, ansEps) = mkAnsatzFast ord symmetries evalMEtaRed evalMEpsRed + tens = evalToTensSym symmetries evalMEtaInds evalMEpsInds ansEta ansEps + +--and without explicit symmetrization in tens + +-- | This function provides the same functionality as @'mkAnsatzTensorFast'@ but without explicit symmetrization of the result. In other words from each symmetrization sum only the first +-- summand is returned. This is advantageous as for large expressions explicit symmetrization might be expensive and further is sometime simply not needed as the result might for instance be contracted against +-- a symmetric object, which thus enforces the symmetry, in further steps of the computation. +mkAnsatzTensorFast :: forall (n :: Nat). SingI n => Int -> Symmetry -> [[Int]]-> (AnsatzForestEta, AnsatzForestEpsilon, STTens n 0 AnsVarR) +mkAnsatzTensorFast ord symmetries evalL = (ansEta, ansEps, tens) + where + (evalMEtaRed, evalMEpsRed, evalMEtaInds, evalMEpsInds) = mkAllEvalMaps symmetries evalL + (ansEta, ansEps) = mkAnsatzFast ord symmetries evalMEtaRed evalMEpsRed + tens = evalToTens evalMEtaInds evalMEpsInds ansEta ansEps + +--eval to abstract tensor + +-- | This function provides the same functionality as @'mkAnsatzTensorFast'@ but returns the result as tensor of type @'ATens' 'AnsVarR'@. This is achieved by explicitly providing not only +-- the list of individual index combinations but also their representation using more abstract index types as input. The input list consists of triplets where the first element +-- as before labels the independent index combinations, the second element labels the corresponding multiplicity under the present symmetry. The multiplicity simply encodes how many different combinations of spacetime indices +-- correspond to the same abstract index tuple. The last element of the input triplets labels the individual abstract index combinations that then correspond to the provided spacetime indices. If some of the initial symmetries +-- are still present when using abstract indices this last element might consists of more then one index combination. The appropriate value that is retrieved from the two ansatz forests is then written to each of the provided index combinations. +mkAnsatzTensorFastAbs :: Int -> Symmetry -> [([Int], Int, [IndTupleAbs n1 0 n2 0 n3 0])] -> (AnsatzForestEta, AnsatzForestEpsilon, ATens n1 0 n2 0 n3 0 AnsVarR) +mkAnsatzTensorFastAbs ord symmetries evalL = (ansEta, ansEps, tens) + where + (evalMEtaRed, evalMEpsRed, evalMEtaInds, evalMEpsInds) = mkAllEvalMapsAbs symmetries evalL + (ansEta, ansEps) = mkAnsatzFast ord symmetries evalMEtaRed evalMEpsRed + tens = evalToTensAbs evalMEtaInds evalMEpsInds ansEta ansEps + + +{-- +The last step consists of computing the evaluation list from the present symmetries. To that end it is important to note +that for epsilon tensors only index combinations that contain each value 0,...,3 an odd number of times and for eta tensors we need an even number. +Further note that due to the Lorentz invariance of such expressions when computing linear dependencies we are free to relabel the coordinate axis, +i.e. interchange for instance 1 and 0 as this is precisely the effect of a Lorentz transformation (at least up to a sign). +Computing the eval Lists is actually the most expensive step and we can thus get a huge performance improvement if we explicitly provide the +eval maps by and and furthermore only evaluate index combinations that belong different symmetry equivalence classes. +--} + +countEqualInds :: [Int] -> (Int,Int,Int,Int) +countEqualInds [] = (0,0,0,0) +countEqualInds (i:xs) + | i == 0 = (a+1,b,c,d) + | i == 1 = (a,b+1,c,d) + | i == 2 = (a,b,c+1,d) + | i == 3 = (a,b,c,d+1) + | otherwise = error "wrong index" + where + (a,b,c,d) = countEqualInds xs + +isEtaList :: [Int] -> Bool +isEtaList l = let (a,b,c,d) = countEqualInds l in even a && even b && even c && even d + +isEpsilonList :: [Int] -> Bool +isEpsilonList l = let (a,b,c,d) = countEqualInds l in odd a && odd b && odd c && odd d + +--filter one representative of each symmetry equivalence class + +filterPSym :: [Int] -> (Int,Int) -> Bool +filterPSym inds (i,j) = (inds !! (i-1)) <= (inds !! (j-1)) + +filterASym :: [Int] -> (Int,Int) -> Bool +filterASym inds (i,j) = (inds !! (i-1)) < (inds !! (j-1)) + +filterCSym :: [Int] -> [Int] -> Bool +filterCSym inds i = and boolL + where + getPairs [a,b] = [(a,b)] + getPairs (x:xs) = (x, head xs) : getPairs xs + pairL = getPairs i + boolL = map (filterPSym inds) pairL + +filterBSym :: [Int] -> ([Int],[Int]) -> Bool +filterBSym inds ([],[]) = True +filterBSym inds (x:xs,y:ys) + | xVal < yVal = True + | xVal == yVal = filterBSym inds (xs,ys) + | otherwise = False + where + xVal = inds !! (x-1) + yVal = inds !! (y-1) + +filterBCSym :: [Int] -> [[Int]] -> Bool +filterBCSym inds i = and boolL + where + getPairs [a,b] = [(a,b)] + getPairs (x:xs) = (x, head xs) : getPairs xs + pairL = getPairs i + boolL = map (filterBSym inds) pairL + +filterAllSym :: [Int] -> Symmetry -> Bool +filterAllSym inds (p,ap,b,c,bc) = and (p' ++ ap' ++ c' ++ b' ++ bc') + where + p' = map (filterPSym inds) p + ap' = map (filterASym inds) ap + c' = map (filterCSym inds) c + b' = map (filterBSym inds) b + bc' = map (filterBCSym inds) bc + +--filter 1 representative out of each equivalence class that is generated by Lorentz transformations + +isLorentzEval :: Symmetry -> [Int] -> Bool +isLorentzEval sym inds = inds == canonicalL + where + allInds = filterMins $ getAllIndLists inds + canonicalL = minimum $ map (canonicalizeList sym) allInds + +filterMins :: [[Int]] -> [[Int]] +filterMins l = map fst $ filter (\x -> n == snd x) l' + where + l' = map (\x -> (x,sum x)) l + n = minimum $ map snd l' + +--create all equivalent ind Lists + +getAllIndListsMap :: I.IntMap Int -> [I.IntMap Int] +getAllIndListsMap iMap = map (\x -> I.map ((I.!) x) iMap) allSwaps + where + inds = nub $ I.elems iMap + n = length inds + allSwaps = map ((\x y -> I.fromList $ zip x y) inds) $ permutations [0..n-1] + +getAllIndLists :: [Int] -> [[Int]] +getAllIndLists l = map I.elems $ getAllIndListsMap $ I.fromList $ zip [1..] l + +--need to filter further as the symmetries might mix with the Lorentz filtration + +canonicalizePair :: (Int,Int) -> I.IntMap Int -> I.IntMap Int +canonicalizePair (i,j) iMap + | (I.!) iMap i <= (I.!) iMap j = iMap + | otherwise = I.mapKeys swapKeys iMap + where + swapKeys x + | x == i = j + | x == j = i + | otherwise = x + +canonicalizeBlockPair :: ([Int],[Int]) -> I.IntMap Int -> I.IntMap Int +canonicalizeBlockPair ([i],[j]) iMap + | (I.!) iMap i <= (I.!) iMap j = iMap + | otherwise = I.mapKeys swapKeys iMap + where + swapKeys x + | x == i = j + | x == j = i + | otherwise = x +canonicalizeBlockPair (i:is,j:js) iMap + | iVal < jVal = iMap + | iVal > jVal = I.mapKeys (swapBlocks (i:is,j:js)) iMap + | iVal == jVal = newMap + where + iVal = (I.!) iMap i + jVal = (I.!) iMap j + swapBlocks (m1,m2) x = let m = I.fromList $ zip m1 m2 ++ zip m2 m1 + in fromMaybe x $ I.lookup x m + newMap = canonicalizeBlockPair (is,js) iMap + + +canonicalizeIntMap :: Symmetry -> I.IntMap Int -> I.IntMap Int +canonicalizeIntMap (p,ap,b,c,bc) iMap = iMap2 + where + allBlocks = b ++ concatMap mkBlocksFromBlockCycle bc + allPairs = p ++ ap ++ concatMap mkSymsFromCycle c + iMap1 = foldr canonicalizePair iMap allPairs + iMap2 = foldr canonicalizeBlockPair iMap1 allBlocks + +canonicalizeList :: Symmetry -> [Int] -> [Int] +canonicalizeList sym inds = I.elems $ canonicalizeIntMap sym $ I.fromList $ zip [1..] inds + +allList' :: Int -> [(Int,Int)] -> [(Int,Int)] -> [(Int,Int)] -> [(Int,Int)] -> [[Int]] +allList' 1 syms aSyms symBounds aSymBounds = case (symB, aSymB) of + (Just j, Nothing) -> [[k] | k <- [j..3]] + (Nothing, Just j) -> [[k] | k <- [j+1..3]] + (Nothing, Nothing) -> [[0], [1], [2], [3]] + (Just j, Just k) -> [[k] | k <- [max j (k+1) .. 3]] + where + (symB,aSymB) = (lookup 1 symBounds, lookup 1 aSymBounds) +allList' i syms aSyms symBounds aSymBounds = concatMap (\x -> (:) <$> [x] <*> allList' (i-1) newSyms newASyms (newSymBounds x) (newASymBounds x)) l + where + (symB,aSymB) = (lookup 1 symBounds, lookup 1 aSymBounds) + l' = case (symB, aSymB) of + (Just j, Nothing) -> [j..3] + (Nothing, Just j) -> [j+1..3] + (Nothing, Nothing) -> [0..3] + (Just j, Just k) -> [max j (k+1) .. 3] + l = if isJust newASymB then filter (<3) l' else l' + newSyms = map (\(x,y) -> (x-1,y-1)) syms + newASyms = map (\(x,y) -> (x-1,y-1)) aSyms + newSymB = lookup 1 syms + newASymB = lookup 1 aSyms + newSymBounds' = map (\(x,y) -> (x-1,y-1)) symBounds + newASymBounds' = map (\(x,y) -> (x-1,y-1)) aSymBounds + newSymBounds x' = case newSymB of + Just j -> (j-1,x') : newSymBounds' + Nothing -> newSymBounds' + newASymBounds x' = case newASymB of + Just j -> (j-1,x') : newASymBounds' + Nothing -> newASymBounds' + +--create all possible index lists by employing the constraints posed by pair symmetries + +allList :: Int -> Symmetry -> [[Int]] +allList ord (syms,aSyms,_,_,_) = allList' ord syms aSyms [] [] + +--use the above functions to construct ansätze without providing eval lists by hand + +-- | The function is similar to @'mkAnsatzTensorFastSym''@ yet it uses an algorithm that prioritizes memory usage over fast computation times. +mkAnsatzTensorEigSym' :: forall (n :: Nat). SingI n => Int -> Symmetry -> (AnsatzForestEta, AnsatzForestEpsilon, STTens n 0 AnsVarR) +mkAnsatzTensorEigSym' ord symmetries = mkAnsatzTensorEigSym ord symmetries evalL + where + evalL = filter (`filterAllSym` symmetries) $ allList ord symmetries + +-- | Provides the same functionality as @'mkAnsatzTensorFastSym'@ with the difference that the list of independent index combinations is automatically computed form the present symmetry. +-- Note that this yields slightly higher computation costs. +mkAnsatzTensorFastSym' :: forall (n :: Nat). SingI n => Int -> Symmetry -> (AnsatzForestEta, AnsatzForestEpsilon, STTens n 0 AnsVarR) +mkAnsatzTensorFastSym' ord symmetries = mkAnsatzTensorFastSym ord symmetries evalL + where + evalL = filter (`filterAllSym` symmetries) $ allList ord symmetries + +--and without explicit symmetrization + +-- | The function is similar to @'mkAnsatzTensorFast''@ yet it uses an algorithm that prioritizes memory usage over fast computation times. +mkAnsatzTensorEig' :: forall (n :: Nat). SingI n => Int -> Symmetry -> (AnsatzForestEta, AnsatzForestEpsilon, STTens n 0 AnsVarR) +mkAnsatzTensorEig' ord symmetries = mkAnsatzTensorEig ord symmetries evalL + where + evalL = filter (`filterAllSym` symmetries) $ allList ord symmetries + +-- | Provides the same functionality as @'mkAnsatzTensorFast'@ with the difference that the list of independent index combinations is automatically computed form the present symmetry. +-- Note that this yields slightly higher computation costs. +mkAnsatzTensorFast' :: forall (n :: Nat). SingI n => Int -> Symmetry -> (AnsatzForestEta, AnsatzForestEpsilon, STTens n 0 AnsVarR) +mkAnsatzTensorFast' ord symmetries = mkAnsatzTensorFast ord symmetries evalL + where + evalL = filter (`filterAllSym` symmetries) $ allList ord symmetries + +--abstract tensor evaluation lists + +--finally the lists for the evaluation + +--triangle maps converting from abstract indices to spacetime indices + +trianMapArea :: I.IntMap [Int] +trianMapArea = I.fromList $ zip [1..21] list + where + list = [ [a,b,c,d] | a <- [0..2], b <- [a+1..3], c <- [a..2], d <- [c+1..3], isAreaSorted a b c d] + +trianMap2 :: I.IntMap [Int] +trianMap2 = I.fromList $ zip [1..10] list + where + list = [ [p,q] | p <- [0..3], q <- [p..3]] + +isAreaSorted :: Int -> Int -> Int -> Int -> Bool +isAreaSorted a b c d + | a < c || (a == c && b <= d) = True + | otherwise = False + +--computing the multiplicities that result from the use of the area metric inter twiner + +areaMult :: [Int] -> Int +areaMult [a,b,c,d] + | a == c && b == d = 4 + | otherwise = 8 + +iMult2 :: [Int] -> Int +iMult2 [p,q] = if p == q then 1 else 2 + +--Area metric eval lists + +-- | Evaluation list for \(a^A \). +areaList4 :: [([Int], Int, [IndTupleAbs 1 0 0 0 0 0])] +areaList4 = list + where + trianArea = trianMapArea + list = [ let a' = (I.!) trianArea a in (a', areaMult a', [(singletonInd (Ind20 $ a-1), Empty, Empty, Empty, Empty, Empty)]) | a <- [1..21] ] + +-- | Evaluation list for \(a^{AI} \). +areaList6 :: [([Int], Int, [IndTupleAbs 1 0 1 0 0 0])] +areaList6 = list + where + trian2 = trianMap2 + trianArea = trianMapArea + list = [ let (a',i') = ((I.!) trianArea a, (I.!) trian2 i) in (a' ++ i', areaMult a' * iMult2 i', [(singletonInd (Ind20 $ a-1), Empty, singletonInd (Ind9 $ i-1), Empty, Empty, Empty)]) | a <- [1..21], i <- [1..10]] + +-- | Evaluation list for \(a^{A B}\). Note that also when using the abstract indices this ansatz still features the \( A \leftrightarrow B \) symmetry. +areaList8 :: [([Int], Int, [IndTupleAbs 2 0 0 0 0 0])] +areaList8 = list + where + trian2 = trianMap2 + trianArea = trianMapArea + list = [ let (a',b') = ((I.!) trianArea a, (I.!) trianArea b) in (a' ++ b', areaMult a' * areaMult b', map (\[a,b] -> (Append (Ind20 $ a-1) $ singletonInd (Ind20 $ b-1), Empty, Empty, Empty, Empty, Empty)) $ nub $ permutations [a,b] ) | a <- [1..21], b <- [a..21]] + +-- | Evaluation list for \(a^{Ap Bq}\). Note that also when using the abstract indices this ansatz still features the \( (Ap) \leftrightarrow (Bq) \) symmetry. +areaList10_1 :: [([Int], Int, [IndTupleAbs 2 0 0 0 2 0])] +areaList10_1 = list + where + trian2 = trianMap2 + trianArea = trianMapArea + list = [ let (a',b') = ((I.!) trianArea a, (I.!) trianArea b) in (a' ++ p : b' ++ [q], areaMult a' * areaMult b', map (\[[a,p],[b,q]] -> (Append (Ind20 $ a-1) $ singletonInd (Ind20 $ b-1), Empty, Empty, Empty, Append (Ind3 p) $ singletonInd (Ind3 q), Empty)) $ nub $ permutations [[a,p],[b,q]]) | a <- [1..21], b <- [a..21], p <- [0..3], q <- [0..3], not (a==b && p>q)] + +-- | Evaluation list for \(a^{ABI} \). +areaList10_2 :: [([Int], Int, [IndTupleAbs 2 0 1 0 0 0])] +areaList10_2 = list + where + trian2 = trianMap2 + trianArea = trianMapArea + list = [ let (a',b',i') = ((I.!) trianArea a, (I.!) trianArea b, (I.!) trian2 i) in (a' ++ b' ++ i', areaMult a' * areaMult b' * iMult2 i', [ (Append (Ind20 $ a-1) $ singletonInd (Ind20 $ b-1), Empty, singletonInd (Ind9 $ i-1), Empty, Empty, Empty)] ) | a <- [1..21], b <- [1..21], i <- [1..10] ] + +-- | Evaluation list for \(a^{ABC} \). Note that also when using the abstract indices this ansatz still features the symmetry under arbitrary permutations of \( ABC\). +areaList12 :: [([Int], Int, [IndTupleAbs 3 0 0 0 0 0])] +areaList12 = list + where + trian2 = trianMap2 + trianArea = trianMapArea + list = [ let (a',b',c') = ((I.!) trianArea a, (I.!) trianArea b, (I.!) trianArea c) in (a' ++ b' ++ c', areaMult a' * areaMult b' * areaMult c', map (\[a,b,c] -> (Append (Ind20 $ a-1) $ Append (Ind20 $ b-1) $ singletonInd (Ind20 $ c-1), Empty, Empty, Empty, Empty, Empty)) $ nub $ permutations [a,b,c] )| a <- [1..21], b <- [a..21], c <- [b..21] ] + +--AI:BJ +areaList12_1 :: [([Int], Int, [IndTupleAbs 2 0 2 0 0 0])] +areaList12_1 = list + where + trian2 = trianMap2 + trianArea = trianMapArea + list = [ let (a',i',b',j') = ((I.!) trianArea a, (I.!) trian2 i, (I.!) trianArea b, (I.!) trian2 j) in (a' ++ i' ++ b' ++ j' , areaMult a' * areaMult b' * iMult2 i' * iMult2 j', map (\[[a,i],[b,j]] -> (Append (Ind20 $ a-1) $ singletonInd (Ind20 $ b-1), Empty, Append (Ind9 $ i-1) $ singletonInd (Ind9 $ j-1), Empty, Empty, Empty)) $ nub $ permutations [[a,i],[b,j]] ) | a <- [1..21], b <- [a..21], i <- [1..10], j <- [1..10], not (a==b && i>j) ] + +-- | Evaluation list for \(a^{ABp Cq}\). Note that also when using the abstract indices this ansatz still features the \( (Bp) \leftrightarrow (Cq) \) symmetry. +areaList14_1 :: [([Int], Int, [IndTupleAbs 3 0 0 0 2 0])] +areaList14_1 = list + where + trian2 = trianMap2 + trianArea = trianMapArea + list = [ let (a',b',c') = ((I.!) trianArea a, (I.!) trianArea b, (I.!) trianArea c) in (a' ++ b' ++ p : c' ++ [q], areaMult a' * areaMult b' * areaMult c', map (\[[b,p],[c,q]] -> (Append (Ind20 $ a-1) $ Append (Ind20 $ b-1) $ singletonInd (Ind20 $ c-1), Empty, Empty, Empty, Append (Ind3 p) $ singletonInd (Ind3 q), Empty)) $ nub $ permutations [[b,p],[c,q]]) | a <- [1..21], b <- [1..21], c <- [b..21], p <- [0..3], q <- [0..3], not (b==c && p>q) ] + +-- | Evaluation list for \(a^{A B C I}\). Note that also when using the abstract indices this ansatz still features the \( (A) \leftrightarrow (B) \) symmetry. +areaList14_2 :: [([Int], Int, [IndTupleAbs 3 0 1 0 0 0])] +areaList14_2 = list + where + trian2 = trianMap2 + trianArea = trianMapArea + list = [ let (a',b',c',i') = ((I.!) trianArea a, (I.!) trianArea b, (I.!) trianArea c, (I.!) trian2 i) in ( a' ++ b' ++ c' ++ i', areaMult a' * areaMult b' * areaMult c' * iMult2 i', map (\[a,b] -> (Append (Ind20 $ a-1) $ Append (Ind20 $ b-1) $ singletonInd (Ind20 $ c-1), Empty, singletonInd (Ind9 $ i-1), Empty, Empty, Empty)) $ nub $ permutations [a,b] ) | a <- [1..21], b <- [a..21], c <- [1..21], i <- [1..10] ] + +--Ap:Bq:CI +areaList16_1 :: [([Int], Int, [IndTupleAbs 3 0 1 0 2 0])] +areaList16_1 = list + where + trian2 = trianMap2 + trianArea = trianMapArea + list = [ let (a',b',c',i') = ((I.!) trianArea a, (I.!) trianArea b, (I.!) trianArea c, (I.!) trian2 i) in (a' ++ p : b' ++ q : c' ++ i' , areaMult a' * areaMult b' * areaMult c' * iMult2 i', map (\[[a,p],[b,q]] -> (Append (Ind20 $ a-1) $ Append (Ind20 $ b-1) $ singletonInd (Ind20 $ c-1), Empty, singletonInd (Ind9 $ i-1), Empty, Append (Ind3 p) $ singletonInd (Ind3 q), Empty)) $ nub $ permutations [[a,p],[b,q]]) | a <- [1..21], b <- [a..21], c <- [1..21], i <- [1..10], p <- [0..3], q <- [0..3], not (a==b && p>q) ] + +--A:BI:CJ +areaList16_2 :: [([Int], Int, [IndTupleAbs 3 0 2 0 0 0])] +areaList16_2 = list + where + trian2 = trianMap2 + trianArea = trianMapArea + list = [let (a',b',c',i', j') = ((I.!) trianArea a, (I.!) trianArea b, (I.!) trianArea c, (I.!) trian2 i, (I.!) trian2 j) in (a' ++ b' ++ i' ++ c' ++ j', areaMult a' * areaMult b' * areaMult c' * iMult2 i' * iMult2 j', map (\[[b,i],[c,j]] -> (Append (Ind20 $ a-1) $ Append (Ind20 $ b-1) $ singletonInd (Ind20 $ c-1), Empty, Append (Ind9 $ i-1) $ singletonInd (Ind9 $ j-1), Empty, Empty, Empty) ) $ nub $ permutations [[b,i],[c,j]])| a <- [1..21], b <- [1..21], c <- [b..21], i <- [1..10], j <- [1..10], not (b==c && i>j)] + +--AI:BJ:CK +areaList18 :: [([Int], Int, [IndTupleAbs 3 0 3 0 0 0])] +areaList18 = list + where + trian2 = trianMap2 + trianArea = trianMapArea + list = [ let (a',b',c',i', j', k') = ((I.!) trianArea a, (I.!) trianArea b, (I.!) trianArea c, (I.!) trian2 i, (I.!) trian2 j, (I.!) trian2 k) in (a' ++ i' ++ b' ++ j' ++ c' ++ k', areaMult a' * areaMult b' * areaMult c' * iMult2 i' * iMult2 j' * iMult2 k', map (\[[a,i],[b,j],[c,k]] -> (Append (Ind20 $ a-1) $ Append (Ind20 $ b-1) $ singletonInd (Ind20 $ c-1), Empty, Append (Ind9 $ i-1) $ Append (Ind9 $ j-1) $ singletonInd (Ind9 $ k-1), Empty, Empty, Empty) ) $ nub $ permutations [[a,i],[b,j],[c,k]]) | a <- [1..21], b <- [a..21], c <- [b..21], i <- [1..10], j <- [1..10], not (a==b && i>j), k <- [1..10], not (b==c && j>k) ] + +--order 4 + +--A:B:C_D +areaList16 :: [([Int], Int, [IndTupleAbs 4 0 0 0 0 0])] +areaList16 = list + where + trian2 = trianMap2 + trianArea = trianMapArea + list = [ let (a',b',c', d') = ((I.!) trianArea a, (I.!) trianArea b, (I.!) trianArea c, (I.!) trianArea d) in (a' ++ b' ++ c' ++ d', areaMult a' * areaMult b' * areaMult c' * areaMult d', map (\[a,b,c,d] -> (Append (Ind20 $ a-1) $ Append (Ind20 $ b-1) $ Append (Ind20 $ c-1) $ singletonInd (Ind20 $ d-1), Empty, Empty, Empty, Empty, Empty)) $ nub $ permutations [a,b,c,d] )| a <- [1..21], b <- [a..21], c <- [b..21], d <- [c..21] ] + +--A:B:C:DI +areaList18_2 :: [( [Int], Int, [IndTupleAbs 4 0 1 0 0 0])] +areaList18_2 = list + where + trian2 = trianMap2 + trianArea = trianMapArea + list = [ let (a',b',c',d',i') = ((I.!) trianArea a, (I.!) trianArea b, (I.!) trianArea c, (I.!) trianArea d, (I.!) trian2 i) in (a' ++ b' ++ c'++d'++i', areaMult a' * areaMult b' * areaMult c' * areaMult d' * iMult2 i', map (\[a,b,c] -> (Append (Ind20 $ a-1) $ Append (Ind20 $ b-1) $ Append (Ind20 $ c-1) (singletonInd (Ind20 $ d-1)), Empty, singletonInd (Ind9 $ i-1), Empty, Empty, Empty) ) $ nub $ permutations [a,b,c] ) | a <- [1..21], b <- [a..21], c <- [b..21], d <- [1..21], i <- [1..10] ] + +--A:B:Cp:Dq +areaList18_3 :: [([Int], Int, [IndTupleAbs 4 0 0 0 2 0])] +areaList18_3 = list + where + trian2 = trianMap2 + trianArea = trianMapArea + list = [ let (a',b',c',d') = ((I.!) trianArea a, (I.!) trianArea b, (I.!) trianArea c, (I.!) trianArea d) in (a' ++ b' ++ c'++ p : d'++[q], areaMult a' * areaMult b' * areaMult c' * areaMult d', map ( \(a,b,c,p,d,q) -> (Append (Ind20 $ a-1) $ Append (Ind20 $ b-1) $ Append (Ind20 $ c-1) (singletonInd (Ind20 $ d-1)), Empty, Empty, Empty, Append (Ind3 p) (singletonInd (Ind3 q)), Empty) ) $ nub [(a,b,c,p,d,q),(b,a,c,p,d,q),(a,b,d,q,c,p),(b,a,d,q,c,p)] ) | a <- [1..21], b <- [a..21], c <- [1..21], d <- [c..21], p <- [0..3], q <- [0..3] , not (c == d && p > q) ] + +--order 5 + +areaList20 :: [( [Int], Int, [IndTupleAbs 5 0 0 0 0 0])] +areaList20 = list + where + trian2 = trianMap2 + trianArea = trianMapArea + list = [ let (a',b',c', d', e') = ((I.!) trianArea a, (I.!) trianArea b, (I.!) trianArea c, (I.!) trianArea d, (I.!) trianArea e) in (a' ++ b' ++ c' ++ d' ++ e', areaMult a' * areaMult b' * areaMult c' * areaMult d' * areaMult e', map (\[a,b,c,d,e] -> (Append (Ind20 $ a-1) $ Append (Ind20 $ b-1) $ Append (Ind20 $ c-1) $ Append (Ind20 $ d-1) $ singletonInd (Ind20 $ e-1), Empty, Empty, Empty, Empty, Empty)) $ nub $ permutations [a,b,c,d,e] )| a <- [1..21], b <- [a..21], c <- [b..21], d <- [c..21], e <- [d..21] ] + +--for the kinetic Ansätze for the Rom calculations -> extra symmetry + +--Ap:Bq +areaList10Rom :: [( [Int], Int, [IndTupleAbs 2 0 0 0 2 0])] +areaList10Rom = list + where + trian2 = trianMap2 + trianArea = trianMapArea + list = [ let (a',b') = ((I.!) trianArea a, (I.!) trianArea b) in (a' ++ p : b' ++ [q], areaMult a' * areaMult b', map (\[a,p,b,q] -> (Append (Ind20 $ a-1) $ singletonInd (Ind20 $ b-1), Empty, Empty, Empty, Append (Ind3 p) $ singletonInd (Ind3 q), Empty)) $ nub [[a,p,b,q], [a,q,b,p], [b,p,a,q], [b,q,a,p]]) | a <- [1..21], b <- [a..21], p <- [0..3], q <- [p..3]] + +--Ap:Bq:C + +areaList14Rom :: [( [Int], Int, [IndTupleAbs 3 0 0 0 2 0])] +areaList14Rom = list + where + trian2 = trianMap2 + trianArea = trianMapArea + list = [ let (a',b',c') = ((I.!) trianArea a, (I.!) trianArea b, (I.!) trianArea c) in (a' ++ p : b' ++ q : c' , areaMult a' * areaMult b' * areaMult c', map (\[[a,p],[b,q]] -> (Append (Ind20 $ a-1) $ Append (Ind20 $ b-1) $ singletonInd (Ind20 $ c-1), Empty, Empty, Empty, Append (Ind3 p) $ singletonInd (Ind3 q), Empty)) $ nub $ permutations [[a,p],[b,q]]) | a <- [1..21], b <- [a..21], c <- [1..21], p <- [0..3], q <- [0..3], not (a==b && p>q) ] + + +--now the same for the metric ansätze + + +-- | Evaluation list for \(a^{A} \). +metricList2 :: [( [Int], Int, [IndTupleAbs 0 0 1 0 0 0])] +metricList2 = list + where + trianMetric = trianMap2 + list = [ let a' = (I.!) trianMetric a in (a', iMult2 a', [(Empty, Empty, singletonInd (Ind9 $ a-1), Empty, Empty, Empty)]) | a <- [1..10] ] + + +--(first metric indices) +-- | Evaluation list for \(a^{AI} \). +metricList4_1 :: [( [Int], Int, [IndTupleAbs 0 0 2 0 0 0])] +metricList4_1 = list + where + trianMetric = trianMap2 + list = [ let (a',i') = ((I.!) trianMetric a, (I.!) trianMetric i) in (a'++i', iMult2 a' * iMult2 i', [(Empty, Empty, Append (Ind9 $ a-1) (singletonInd (Ind9 $ i-1)), Empty, Empty, Empty)]) | a <- [1..10], i <- [1..10] ] + + +-- | Evaluation list for \(a^{A B}\). Note that also when using the abstract indices this ansatz still features the \( A \leftrightarrow B \) symmetry. +metricList4_2 :: [( [Int], Int, [IndTupleAbs 0 0 2 0 0 0])] +metricList4_2 = list + where + trianMetric = trianMap2 + list = [ let (a',b') = ((I.!) trianMetric a, (I.!) trianMetric b) in (a' ++ b', iMult2 a' * iMult2 b', map (\[a,b] -> (Empty, Empty, Append (Ind9 $ a-1) $ singletonInd (Ind9 $ b-1), Empty, Empty, Empty)) $ nub $ permutations [a,b] ) | a <- [1..10], b <- [a..10]] + + +-- | Evaluation list for \(a^{Ap Bq}\). Note that also when using the abstract indices this ansatz still features the \( (Ap) \leftrightarrow (Bq) \) symmetry. +metricList6_1 :: [( [Int], Int, [IndTupleAbs 0 0 2 0 2 0])] +metricList6_1 = list + where + trianMetric = trianMap2 + list = [ let (a',b') = ((I.!) trianMetric a, (I.!) trianMetric b) in (a' ++ p : b' ++ [q], iMult2 a' * iMult2 b', map (\[[a,p],[b,q]] -> (Empty, Empty, Append (Ind9 $ a-1) $ singletonInd (Ind9 $ b-1), Empty, Append (Ind3 p) $ singletonInd (Ind3 q), Empty)) $ nub $ permutations [[a,p],[b,q]]) | a <- [1..10], b <- [a..10], p <- [0..3], q <- [0..3], not (a==b && p>q)] + + +-- | Evaluation list for \(a^{ABI} \). +metricList6_2 :: [( [Int], Int, [IndTupleAbs 0 0 3 0 0 0])] +metricList6_2 = list + where + trianMetric = trianMap2 + list = [ let (a',b',i') = ((I.!) trianMetric a, (I.!) trianMetric b, (I.!) trianMetric i) in (a' ++ b' ++ i', iMult2 a' * iMult2 b' * iMult2 i', [ (Empty, Empty, Append (Ind9 $ a-1) $ Append (Ind9 $ b-1) $ singletonInd (Ind9 $ i-1), Empty, Empty, Empty)] ) | a <- [1..10], b <- [1..10], i <- [1..10] ] + + +-- | Evaluation list for \(a^{ABC} \). Note that also when using the abstract indices this ansatz still features the symmetry under arbitrary permutations of \( ABC\). +metricList6_3 :: [( [Int], Int, [IndTupleAbs 0 0 3 0 0 0])] +metricList6_3 = list + where + trianMetric = trianMap2 + list = [ let (a',b',c') = ((I.!) trianMetric a, (I.!) trianMetric b, (I.!) trianMetric c) in (a' ++ b' ++ c', iMult2 a' * iMult2 b' * iMult2 c', map (\[a,b,c] -> (Empty, Empty, Append (Ind9 $ a-1) $ Append (Ind9 $ b-1) $ singletonInd (Ind9 $ c-1), Empty, Empty, Empty)) $ nub $ permutations [a,b,c] )| a <- [1..10], b <- [a..10], c <- [b..10] ] + + +-- | Evaluation list for \(a^{ABp Cq}\). Note that also when using the abstract indices this ansatz still features the \( (Bp) \leftrightarrow (Cq) \) symmetry. +metricList8_1 :: [( [Int], Int, [IndTupleAbs 0 0 3 0 2 0])] +metricList8_1 = list + where + trianMetric = trianMap2 + list = [ let (a',b',c') = ((I.!) trianMetric a, (I.!) trianMetric b, (I.!) trianMetric c) in (a' ++ b' ++ p : c' ++ [q], iMult2 a' * iMult2 b' * iMult2 c', map (\[[b,p],[c,q]] -> (Empty, Empty, Append (Ind9 $ a-1) $ Append (Ind9 $ b-1) $ singletonInd (Ind9 $ c-1), Empty, Append (Ind3 p) $ singletonInd (Ind3 q), Empty)) $ nub $ permutations [[b,p],[c,q]]) | a <- [1..10], b <- [1..10], c <- [b..10], p <- [0..3], q <- [0..3], not (b==c && p>q) ] + + +-- | Evaluation list for \(a^{A B C I}\). Note that also when using the abstract indices this ansatz still features the \( (A) \leftrightarrow (B) \) symmetry. +metricList8_2 :: [( [Int], Int, [IndTupleAbs 0 0 4 0 0 0])] +metricList8_2 = list + where + trianMetric = trianMap2 + list = [ let (a',b',c',i') = ((I.!) trianMetric a, (I.!) trianMetric b, (I.!) trianMetric c, (I.!) trianMetric i) in ( a' ++ b' ++ c' ++ i', iMult2 a' * iMult2 b' * iMult2 c' * iMult2 i', map (\[a,b] -> (Empty, Empty, Append (Ind9 $ a-1) $ Append (Ind9 $ b-1) $ Append (Ind9 $ c-1) $ singletonInd (Ind9 $ i-1), Empty, Empty, Empty)) $ nub $ permutations [a,b] ) | a <- [1..10], b <- [a..10], c <- [1..10], i <- [1..10] ] + +--symLists for the ansätze + +-- | Symmetry list for @'areaList4'@. +symList4 :: Symmetry +symList4 = ([], [(1,2),(3,4)], [([1,2],[3,4])], [], []) + +-- | Symmetry list for @'areaList6'@. +symList6 :: Symmetry +symList6 = ([(5,6)], [(1,2),(3,4)], [([1,2],[3,4])], [], []) + +-- | Symmetry list for @'areaList8'@. +symList8 :: Symmetry +symList8 = ([], [(1,2),(3,4),(5,6),(7,8)], [([1,2],[3,4]),([5,6],[7,8]),([1,2,3,4],[5,6,7,8])], [], []) + +-- | Symmetry list for @'areaList10_1'@. +symList10_1 :: Symmetry +symList10_1 = ([], [(1,2),(3,4),(6,7),(8,9)], [([1,2],[3,4]),([6,7],[8,9]),([1,2,3,4,5],[6,7,8,9,10])], [], []) + +-- | Symmetry list for @'areaList10_2'@. +symList10_2 :: Symmetry +symList10_2 = ([(9,10)], [(1,2),(3,4),(5,6),(7,8)], [([1,2],[3,4]),([5,6],[7,8])], [], []) + +-- | Symmetry list for @'areaList12'@. +symList12 :: Symmetry +symList12 = ([], [(1,2),(3,4),(5,6),(7,8),(9,10),(11,12)], [([1,2],[3,4]),([5,6],[7,8]),([9,10],[11,12])], [], [[[1,2,3,4],[5,6,7,8],[9,10,11,12]]]) + +symList12_1 :: Symmetry +symList12_1 = ([(5,6),(11,12)], [(1,2),(3,4),(7,8),(9,10)], [([1,2],[3,4]),([7,8],[9,10]),([1,2,3,4,5,6],[7,8,9,10,11,12])], [], []) + +-- | Symmetry list for @'areaList14_1'@. +symList14_1 :: Symmetry +symList14_1 = ([], [(1,2),(3,4),(5,6),(7,8),(10,11),(12,13)], [([1,2],[3,4]),([5,6],[7,8]),([10,11],[12,13]),([5,6,7,8,9],[10,11,12,13,14])], [], []) + +-- | Symmetry list for @'areaList14_2'@. +symList14_2 :: Symmetry +symList14_2 = ([(13,14)], [(1,2),(3,4),(5,6),(7,8),(9,10),(11,12)], [([1,2],[3,4]),([5,6],[7,8]),([9,10],[11,12]),([1,2,3,4],[5,6,7,8])], [], []) + +symList16_1 :: Symmetry +symList16_1 = ([(15,16)], [(1,2),(3,4),(6,7),(8,9),(11,12),(13,14)], [([1,2],[3,4]),([6,7],[8,9]),([11,12],[13,14]),([1,2,3,4,5],[6,7,8,9,10])], [], []) + +symList16_2 :: Symmetry +symList16_2 = ([(9,10),(15,16)], [(1,2),(3,4),(5,6),(7,8),(11,12),(13,14)], [([1,2],[3,4]),([5,6],[7,8]),([11,12],[13,14]),([5,6,7,8,9,10],[11,12,13,14,15,16])], [], []) + +symList18 :: Symmetry +symList18 = ([(5,6),(11,12),(17,18)], [(1,2),(3,4),(7,8),(9,10),(13,14),(15,16)], [([1,2],[3,4]),([7,8],[9,10]),([13,14],[15,16])], [], [[[1,2,3,4,5,6],[7,8,9,10,11,12],[13,14,15,16,17,18]]]) + +--order 4 + +symList16 :: Symmetry +symList16 = ([], [(1,2),(3,4),(5,6),(7,8),(9,10),(11,12),(13,14),(15,16)], [([1,2],[3,4]),([5,6],[7,8]),([9,10],[11,12]),([13,14],[15,16])], [], [[[1,2,3,4],[5,6,7,8],[9,10,11,12],[13,14,15,16]]]) + +symList18_2 :: Symmetry +symList18_2 = ([(17,18)], [(1,2),(3,4),(5,6),(7,8),(9,10),(11,12),(13,14),(15,16)], [([1,2],[3,4]),([5,6],[7,8]),([9,10],[11,12]),([13,14],[15,16])], [], [[[1,2,3,4],[5,6,7,8],[9,10,11,12]]]) + +symList18_3 :: Symmetry +symList18_3 = ([], [(1,2),(3,4),(5,6),(7,8),(9,10),(11,12),(14,15),(16,17)], [([1,2],[3,4]),([5,6],[7,8]),([9,10],[11,12]),([14,15],[16,17]),([1,2,3,4],[5,6,7,8]),([9,10,11,12,13],[14,15,16,17,18])], [], []) + +--order 5 + +symList20 :: Symmetry +symList20 = ([], [(1,2),(3,4),(5,6),(7,8),(9,10),(11,12),(13,14),(15,16),(17,18),(19,20)], [([1,2],[3,4]),([5,6],[7,8]),([9,10],[11,12]),([13,14],[15,16]),([17,18],[19,20])], [], [[[1,2,3,4],[5,6,7,8],[9,10,11,12],[13,14,15,16],[17,18,19,20]]]) + +--lists for rom ansätze + +symList10Rom :: Symmetry +symList10Rom = ([(5,10)], [(1,2),(3,4),(6,7),(8,9)], [([1,2],[3,4]),([6,7],[8,9]),([1,2,3,4],[6,7,8,9])], [], []) + +symList14Rom :: Symmetry +symList14Rom = ([], [(1,2),(3,4),(6,7),(8,9),(11,12),(13,14)], [([1,2],[3,4]),([6,7],[8,9]),([11,12],[13,14]),([1,2,3,4,5],[6,7,8,9,10])], [], []) + + +--extra symLists for the metric ansätze + +--A ansatz + +-- | Symmetry list for @'metricList2'@. +metricsymList2 :: Symmetry +metricsymList2 = ([(1,2)], [], [], [], []) + +--AI ansatz + +-- | Symmetry list for @'metricList4_1'@. +metricsymList4_1 :: Symmetry +metricsymList4_1 = ([(1,2),(3,4)], [], [], [], []) + + +--A:B ansatz + +-- | Symmetry list for @'metricList4_2'@. +metricsymList4_2 :: Symmetry +metricsymList4_2 = ([(1,2),(3,4)], [], [([1,2],[3,4])], [], []) + + +--Ap:Bq ansatz + +-- | Symmetry list for @'metricList6_1'@. +metricsymList6_1 :: Symmetry +metricsymList6_1 = ([(1,2),(4,5)], [], [([1,2,3],[4,5,6])], [], []) + +--A:BI ansatz + +-- | Symmetry list for @'metricList6_2'@. +metricsymList6_2 :: Symmetry +metricsymList6_2 = ([(1,2),(3,4),(5,6)], [], [], [], []) + +--A:B:C ansatz + +-- | Symmetry list for @'metricList6_3'@. +metricsymList6_3 :: Symmetry +metricsymList6_3 = ([(1,2),(3,4),(5,6)], [], [], [], [[[1,2],[3,4],[5,6]]]) + +--A:Bp:Cq ansatz + +-- | Symmetry list for @'metricList8_1'@. +metricsymList8_1 :: Symmetry +metricsymList8_1 = ([(1,2),(3,4),(6,7)], [], [([3,4,5],[6,7,8])], [], []) + +--A:B:CI ansatz + +-- | Symmetry list for @'metricList8_2'@. +metricsymList8_2 :: Symmetry +metricsymList8_2 = ([(1,2),(3,4),(5,6),(7,8)], [], [([1,2],[3,4])], [], [])