Mathematica Asked by AlbaCL on August 6, 2021
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:
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]];
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!
Correct answer by Xuemei on August 6, 2021
Get help from others!
Recent Questions
Recent Answers
© 2024 TransWikia.com. All rights reserved. Sites we Love: PCI Database, UKBizDB, Menu Kuliner, Sharing RPP