# Contract two lists

Suppose I have two lists of the equal length in the form

powers= {{rho th},{mu},{beta},{nu},{r},{}}

subscripts={{ }, {a}, {th}, {b}, {r},{mu,al}}

If there is a repeated element (one in the first list and other one in the second list) which I specify (for example in this case it is mu, but not r) then I remove it from both lists and create an element with the rest, for example in this case the out put should be

powers= {{rho th},{beta},{nu},{r},{ }}

subscripts={{ }, {th}, {b}, {r},{a,al}}

I got the removing part

DeleteCases[powers,mu,Infinity]

DeleteCases[subscripts,mu,Infinity]

but struggling with the rest.

UPDATE: I found how to combine the elements, now just need to remove $mu$ from them, but DeleteCases does not work.

posmu1=Position[power,mu][[1,1]]

posmu2=Position[subscipts,mu][[1,1]]

Flatten[powers[[posmu1]]powers[[posmu2]]]

It gives {mu rho th}, but now I cannot delete mu from it using DeleteCases.

• I don't understand the question. Why are a and al part of the same sublist in the output? – Szabolcs Feb 12 '15 at 1:29
• Because they stay next to $mu$. That is the point of the contraction. – Yuri Feb 12 '15 at 1:36
• I think the problem description could use some clarification ... Why isn't the output {{ }, {a,al}, {th}, {b}, {r}}? What if there's more than one mu in both lists? The clearer the question, the better your chances for an answer. – Szabolcs Feb 12 '15 at 1:42
• I have not used it but there is a tensor package called xact – c186282 Feb 12 '15 at 1:43
• I said that mu can only be "one in the first list and other one in the second list" – Yuri Feb 12 '15 at 1:44

This now appears to work

c = First@Flatten@subscripts[[Flatten[Take[Position[powers, mu], All, 1]]]];
Delete[subscripts, Flatten[Take[Position[powers, mu], All, 1]]] /. mu -> c
Delete[powers, Flatten[Take[Position[powers, mu], All, 1]]]


First, find the item in subscripts that corresponds to mu in powers; call it c. Second, delete that item from subscripts. Third, replace mu in subscripts by c. Finally, delete the item containing mu from powers.

Update: cleaner and slightly more general solution

contract[key_, list1_, list2_] := Module[{pos = {Position[list1, key][[1, 1]]}, rep},
rep = If[Flatten@list2[[pos]] != {}, First@Flatten@list2[[pos]], {}];
{Delete[list1, pos], Delete[list2, pos] /. key -> rep /. {{}} -> {}} // MatrixForm]


Then, for instance,

contract[mu, {{mu f}, {a}, {b}, {c}, {d}, {e}} , {{}, {mu}, {beta}, {gamma}, {delta}, {eps}}]


$\left( \begin{array}{ccccc} \{a\} & \{b\} & \{\text{al}\} & \{d\} & \{e\} \\ \{\} & \{\text{beta}\} & \{\text{gamma}\} & \{\text{delta}\} & \{\text{eps}\} \\ \end{array} \right)$

• Thank you very much, but it does not work for the following powers={{mu},{a},{b},{c},{d},{e}} subscripts={al,mu,beta,gamma,delta,eps} It removes two elements in the subscripts. There should be a little modification. Finally it could be {{mu rho},{}...} in the power list, which also does not work. – Yuri Feb 12 '15 at 2:02
• Thanks for pointing out the lack of generality in my solution, which I believe is fixed, at least for the cases given. Note that there is a minor ambiguity in the question relating to whether deleting mu means deleting only mu or the entire item in the list that contains mu. – bbgodfrey Feb 12 '15 at 2:33
• Still there are some cases that do not work. The whole list of possible cases powers={{mu},{a},{b},{c},{d},{e}} subscripts={{al},{mu},{beta},{gamma},{delta},{eps}}; powers={{mu f},{a},{b},{c},{d},{e}} subscripts={{},{mu},{beta},{gamma},{delta},{eps}}; powers={{},{a},{b},{c},{d},{e}} subscripts={{mu f},{mu},{beta},{gamma},{delta},{eps}} – Yuri Feb 12 '15 at 8:01
• @g3n1uss I need clarification in order to proceed. For instance, do you wish {mu f} to transform to {f}, {}, or disappear entirely? Also, can I assume that each item in both lists will be a List itself (i.e., enclosed in curly brackets). – bbgodfrey Feb 12 '15 at 11:30
• each pair of lists should have two elements. In your example the output should be {{a f},{b},{c},{d},{e}}; {{},{beta},{gamma},{delta},{eps}} – Yuri Feb 12 '15 at 18:23

Finally I got it

 posmu1=Position[powers,mu][[1,1]]; posmu2=Position[subscripts,mu][[1,1]]; indpow1=DeleteCases[powers[[posmu1]],mu,Infinity];indpow2=DeleteCases[powers[[posmu2]],mu,Infinity]; If[indpow1!={}&&indpow2!={},powersadd=Join[indpow1 indpow2],powersadd=Join[indpow1,indpow2]]; subscriptsadd=Join[DeleteCases[subscripts[[posmu1]],mu,Infinity],DeleteCases[subscripts[[posmu2]],mu,Infinity]]; powerstmp=Delete[powers,{{posmu1},{posmu2}}]; subscriptstmp=Delete[subscripts,{{posmu1},{posmu2}}]; powersnew=Append[powerstmp,powersadd]; subscriptsnew=Append[subscriptstmp,subscriptsadd]; 

I need this additional to save the structure: powers should not contain comma and subscripts should.