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:
