Find independent tensor products using Young Tableaux

Question

I'll present a very simplified version of what I really need to do.

I have the following 2-rank tensors $h_{\mu\nu}$ , $\xi_{\rho\sigma}$, $k_{\alpha\beta}$ where $h$ and $k$ are symmetric under exchange of their indexes whereas $\xi$ is antisymmetric. Moreover, $h$ is traceless, meaning that $h_\mu^\mu=0$.

I want to find all possible independent contractions like $h_{\mu\nu}\xi^{\mu\sigma}k_{\sigma}^\nu$ which gives no zero.

I can do this manually using Young Tableaux, but it's a lengthy computation.

An easy example is $h_{\mu\nu}\otimes h_{\alpha\beta}$; in terms of Young tableaux, I do the following

where the first,third and fourth tableaux vanish when we choose $\alpha,\beta$ in $\{\mu,\nu\}$ because of the antisymmetry. At the same time, the second term drops out because the tensor is traceless. We end up with the last tableau which represents $h_{\mu\nu}h^{\mu\nu}$.

Is there a way to do it with Mathematica? I saw there exists a package Combinatoria but the documentation is poor.

Answer 1

For those who are facing a similar problem, there is a beautiful package xTras which gives all possible contractions taking into account the symmetries of the tensors.

The command is AllContractions; have a look here arxiv.org/1308.3493

Answer 2

Although xTras package is everything you need, I made a function (just for fun) that finds all the contraction of the product of 2-ranked tensors. It uses sort of bruteforce combinatorics, so it will be deadly slow on a large number of tensors. However, 3-5 tensors work just fine.

NiceTensor[ilst_,names_]:=Inner[Subscript[#2,#1]&,
StringJoin[ToString/@#]&/@Partition[ilst,2],
names,CircleTimes]
Contractions[product_,letters_:Alphabet["Greek"]]:=Module[{strProduct,names,uniqueNames,attrs,symTensors,antTensors,tracelessTensors,n,iLetters,iLetterSubs,coupledNames,tpGroup,tpElems,evenSwaps,spElems,symPerms,Canonical,ilsts,MainValue,trlLst,antLst},
strProduct=product/.CircleTimes->List/.a_^b_:>Table[a,{b}];
strProduct=If[Head[strProduct]===List,Flatten[strProduct],{strProduct}];
strProduct=Characters[ToString[#]]&/@strProduct;

names=First/@strProduct;
uniqueNames=DeleteDuplicates@names;
attrs=Rest/@strProduct;
symTensors =Position[attrs,"s"][[All,1]];
antTensors =Position[attrs,"a"][[All,1]];
tracelessTensors =DeleteDuplicates[Position[attrs,"a"|"t"][[All,1]]];
n=Length[strProduct];

iLetters=letters[[;;n]];
iLetterSubs=Thread[iLetters->#]&/@Permutations[iLetters];

coupledNames=Select[Flatten[Position[names, #]]&/@uniqueNames,Length@#>1&];
tpGroup=PermutationGroup[Flatten[Function[l,Cycles[{{First@l,#}}]&/@Rest[l]]/@coupledNames]];
tpElems=GroupElements[tpGroup]/.{i_Integer,j_Integer}:>Sequence[{2i-1,2j-1},{2i,2j}];

evenSwaps=Select[Subsets[Join[symTensors,antTensors]],EvenQ[Length@Intersection[#,antTensors]]&];
spElems=Function[l,Cycles[{2#-1,2#}&/@l]]/@evenSwaps;

symPerms=PermutationReplace[Range[2n],
Flatten@Outer[PermutationProduct,tpElems,spElems]];

Canonical[ilst_]:=First@Sort@Flatten[Outer[ilst[[#1]]/.#2&,symPerms,iLetterSubs,1],1];

trlLst=PermutationReplace[Range[2n],Cycles[{{2#-1,2#}}]&/@tracelessTensors];

ilsts=DeleteDuplicates[Canonical/@Permutations[Join[iLetters,iLetters]]];
If[Length@tracelessTensors>0,
ilsts=Select[ilsts,Function[p,And@@((p=!=p[[#]])&/@trlLst)]];
];
If[Length@antTensors>0,
antLst=PermutationReplace[Range[2n],Cycles[{{2#-1,2#}}]&/@antTensors];
MainValue[ilst_]:=Module[{ants=Canonical@ilst[[#]]&/@antLst},
If[And@@((ilst=!=#)&/@ants),First@Sort@Append[ants,ilst],0]
];
ilsts=Select[DeleteDuplicates[MainValue/@ilsts],#=!=0&];
];
NiceTensor[#,names]&/@ilsts
]

You encode the tensors with the one-letter name and suffices s, a, and t for symmetric, antisymmetric, and traceless properties respectively and use CircleTimes (⋮c*⋮) for a tensor product: