Fast enumeration of all perfect matchings in complete graph

Question

I have a code that generates the list with all possible Perfect Matchings (PM) of a fully connected graph. Each edge of the graph is mono or bi-colored with up to cmax different colors. Each edge is labeled as w[c1, c2, a, b], where c1 and c2 are the colors of vertex a and vertex b respectively, with c1,c2 = 0,...,cmax. More than one PM will generate the same coloring. For example, take a graph with 4 vertices a,b,c,d: the PM w[0, 1, a, b]*w[0, 0, c, d] and the PM w[0, 0, a, c]*w[1, 0, b, d] have the same coloring ( [0, 1, 0, 0] color in vertices (a, b, c, d) respectively). I also want to group together all PM that generate the same colorings.

As the number of graph vertices and/or colors increases, the PM generation slows down pretty quickly. I wonder if there's a way to speed things up. My strategy is the following:

1. Generate all (unweighted) PM
2. Generate a list with all color combinations
3. Assign all possible weight combinations to these PM
4. Save the different colorings

This is my code. It takes 2 seconds for cmax = 3 and n=6 but 39 seconds for cmax = 3 and n = 8.

cmax = 3; (* number of colors *)
pathmax = 8; (* number of vertices *)

(* Generate all PM *)
set = ToExpression[FromLetterNumber[Range[pathmax]]];
PMpaths = Union[Sort /@ (Sort /@ Partition[#, 2] & /@ Permutations[set, {pathmax}])]; 
Print["Number of PM: ", Length[PMpaths]];
cols = Tuples[Range[cmax] - 1, pathmax/2];

(* Generate all weighted PM *)
AllColoredPMs = ConstantArray[0, Length[cols]^2*Length[PMpaths]];
VertexColorings = ConstantArray[0, Length[cols]^2*Length[PMpaths]];
ccPMidx = 1;
ccPMidx2 = 1;
For[ii = 1, ii <= Length[PMpaths], ii++,
  For[jj = 1, jj <= Length[cols], jj++,
    For[jj2 = 1, jj2 <= Length[cols], jj2++,
      PMtmp = 1;
      For[kk = 1, kk <= pathmax/2, kk++,
       wtmp = w[cols[[jj, kk]], cols[[jj2, kk]], PMpaths[[ii, kk, 1]], PMpaths[[ii, kk, 2]]];
       PMtmp = PMtmp*wtmp (* construct the PM adding weight by weight *)
       ];
      AllColoredPMs[[ccPMidx++]] = PMtmp;
      (* identify the colors of each PM and save it*)
      CurrVC = PMtmp /. {w[cc1_, cc2_, a_, b_] -> a[cc1]*b[cc2]} /. {Times -> List} /. {x_[c_] -> c};
      VertexColorings[[ccPMidx2++]] = CurrVC;
      ];
    ];
  ];
(* Unique colored *)
UniqueVertexColorings = DeleteDuplicates[VertexColorings];

AllWeights = DeleteDuplicates[Cases[AllColoredPMs, _w, {1, Infinity}]];
Print["Number of PM with all color combinations: ", Length[AllColoredPMs]];
Print["Number of different PM: ", Length[UniqueVertexColorings]];
Print["Total number of weights: ", Length[AllWeights]];

Answer 1

Consider the case pathmax=6, I try to use the form {a,b,c,d,e,f} instead of {{a,b},{c,d},{e,f}} for the perfect matchings PMpaths. Then I create all possiable color numbers stored in cols, and map each entry in cols to PMpaths (rearrange the the values in cols with the position described by PMpaths, see the link). Therefore, I can obtain the color assignment for vertices VertexColorings.

Instead of using w[0, 1, a, b]*w[0, 0, c, d]*w[0, 0, e, f] as weighted perfect matchings, I use the form {0, 1, 0, 0, 0, 0, a, b, c, d, e, f} for AllColoredPMs; then I decompose the AllColoredPMs into the used perfect matchings. For example {0, 1, 0, 0, 0, 0, a, b, c, d, e, f} is decomposed into the form {{0, 1, a, b}, {0, 0, c, d}, {0, 0, e, f}}.

Please see the following code:

cmax = 3; 
pathmax = 6; 
set = FromLetterNumber[Range[pathmax]];
PMpaths = Union[Sort /@ (Sort /@ Partition[#, 2] & /@ Permutations[set, {pathmax}])];
PMpaths = Flatten[Map[Flatten, {PMpaths}, {-3}], 1];
Print["Number of PM: ", Length[PMpaths]];

cols = Tuples[Range[cmax]-1, {pathmax}];
VertexColorings = cols[[All, Ordering@#]] & /@ PMpaths;
UniqueVertexColorings = DeleteDuplicates[Flatten[VertexColorings, 1]];
AllColoredPMs = Array[Join[cols[[#2]], PMpaths[[#]]] &, Length /@ {PMpaths, cols}];

AllWeightsTmp = Flatten[AllColoredPMs, 1];
AllWeights = Map[Flatten[TakeDrop[#, Length[#]/2] &@Partition[#, 2], {{2}, {1, 3}}]&, AllWeightsTmp];
AllWeights = DeleteDuplicates[Flatten[AllWeights, 1]];

Print["Number of PM with all color combinations: ", Length[Flatten[AllColoredPMs, 1]]];
Print["Number of different PM: ", Length[UniqueVertexColorings]];
Print["Total number of weights: ", Length[AllWeights]];

For testing time-consuming in the computer:

pathmax=6, your code: 1.1797901sec, the new code: 0.3312204sec
pathmax=8, your code: 91.0197936sec, the new code: 19.4640014sec

Hope it helps!