How to construct pairs in a list?

Question

I have an expression like this,

    input = x[1] x[2]^3 x[5]^2;

Fist step, we can get a list from the input expression,

    list0={x[1],x[2],x[2],x[2],x[5],x[5]};

    list1 = {1, 2, 2, 2, 5, 5};

Second step, I want to get all possible pairs in a new list2. Namely, we divide Length[list1]/2 parts in list1 and combine the possible sublist in a new list. Of course, Length[list1]===Even.

   list2 = {{{1, 2}, {2, 2}, {5, 5}}, {{1, 2}, {2, 5}, {2, 5}} , {{1, 5}, {2, 2}, {2, 5}}};

Last step, we get the output expression,

   output = f[1, 2] f[2, 2] f[5, 5] + f[1, 2] f[2, 5]^2 + f[1, 5] f[2, 2] f[2, 5];

How can I transform the input expression into the output result? Can you show me a simple method that will work for the general problem as well as my example?

In addition, we take another example,

    list1 = {1, 1, 2, 4};

the list2 should be

   list2 = {{1, 1}, {2, 4}}, {{1, 2}, {1, 4}};

Answer 1

Another way to get from input to list1:

list1=# & @@@ Flatten[List @@ input /. Power -> ConstantArray]
(* {1, 2, 2, 2, 5, 5} *)

One possible way (without the Combinatorica package and probably not very efficient) to get from list1 to list2:

list2 = Union[
  Select[Subsets[Tuples[list1, {2}], {Length@list1/2}], 
   Sort@Flatten@# == Sort@list1 &], 
  SameTest -> (Sort[Sort /@ #1] == Sort[Sort /@ #2] &)]
(* {{{1, 2}, {2, 2}, {5, 5}}, {{1, 2}, {2, 5}, {2, 5}}, {{1, 5}, {2, 2}, {2, 5}}} *)

And then, borrowing from kguler's answer:

output=Total@((Times @@ f @@@ #) & /@ list2)
(* f[1, 5] f[2, 2] f[2, 5] + f[1, 2] f[2, 5]^2 + f[1, 2] f[2, 2] f[5, 5] *)

Edit: This updated version should be more general. It works with your second example, too.

Edit 2: To get around the problem adressed in the comments you can use this version of list1. It works just as the earlier version, but also includes the case of only one summand (i.e. the head of input is no longer Plus):

input2 = x[1]^2;
newlist1 = # & @@@ Flatten[{input2} /. {Plus -> Sequence, Power -> ConstantArray}]
(* {1, 1} *)

Answer 2

I take it that the OP gets from list1 to list2 by just taking all distinct partitions in pairs (i.e. the set of all 3 pairs forming list1 when joined). Being lazy, I load

Needs["Combinatorica`"]

and then

list2 = Union[
Sort /@ Cases[KSetPartitions[#, Length@#/2], 
  x_ /; (Min[#] == Max[#] &@(Length /@ x))]] &@list1

which results in the desired output:

{{{1, 2}, {2, 2}, {5, 5}}, {{1, 2}, {2, 5}, {2, 5}}, {{1, 5}, {2, 2}, {2, 5}}}

I am sure there is an easier way but let's see if that's what he wants.

Answer 3

A partial answer:

input = x[1] x[2]^3 x[5]^2;
list1 = Flatten[input/.Power|Times->List /.{x[a_], b_}:>ConstantArray[a, {b}] /. x[a_] :> a]
(* {1, 2, 2, 2, 5, 5} *)

list2 = {{{1, 2}, {2, 2}, {5, 5}}, {{1, 2}, {2, 5}, {2, 5}}, {{1, 5}, {2, 2}, {2, 5}}};
output=Total@((Times @@ f @@@ #) & /@ list2)
(* f[1, 5] f[2, 2] f[2, 5] + f[1, 2] f[2, 5]^2 + f[1, 2] f[2, 2] f[5, 5] *)

Missing: how to get list2 from list1 pending clarification from the OP

Answer 4

constructPairs[input_] := Block[{func, f, list1, permutepart, list2},
func[x[t_]] := t;
func[x[t_]^m_] := ConstantArray[t, m];

list1 = Flatten[Map[func]@Cases[input, p : (t_x | x[_]^_) :> p]];
permutepart = Apply[Partition[{##}, 2] &, Permutations[list1], {1}];
list2 = DeleteDuplicates@*Map[Sort]@Cases[permutepart, p : {{_, _} ..} :> Map[Sort, p]];

Plus @@ Times @@@ Apply[f, list2, {2}]
];

supplying input to function:

input = x[1] x[2]^3 x[5]^2;
constructPairs[input]

(* f[1, 5] f[2, 2] f[2, 5] + f[1, 2] f[2, 5]^2 + f[1, 2] f[2, 2] f[5, 5] *)