4
$\begingroup$

Is it possible to harmoniously label a graph in Mathematica? I would like a function, that when given a graph, would return a harmonious labeling. If not, is there other software that can do it?

A Mathematica program that can do it for me would be great. Maybe use heruistics to do it. Consider all labelings and find one/several harmonious labelings? I dont think I have the programming chops to do it myself.

$\endgroup$
  • 3
    $\begingroup$ What is a harmonious label? $\endgroup$ – rm -rf Jul 18 '14 at 4:33
  • 2
    $\begingroup$ @rm-rf: Apparently this. $\endgroup$ – Rahul Jul 18 '14 at 4:39
6
$\begingroup$

As an addendum to @ubpdqn's answer, this is an attempt to tackle the problem in a slightly less brute-force way. The idea is to make use of the symmetry of the graph in question. In the end we'll obtain all the harmonious labelings that are not related to each other via the symmetry of the graph. Note that this approach is only less brute-force for graphs that have some degree of symmetry. If they don't, ubpdqn's approach is more efficient.

As an example we'll take the Petersen graph:

graph = PetersenGraph[]

Mathematica graphics

Its automorphism group is $S_5$ (the symmetric group on five elements), so instead of churning through all $10!$ permutations of its vertices, we can restrict ourselves to the coset representatives of $S_{10} / S_5$, of which there are $\frac{10!}{5!} = 30240$. The coset representatives are a subset of permutations of the vertices that are not related to each other via symmetries of the graph.

The problem is finding these coset representatives. Although Mathematica has some nice built in group theory tools, it can't do that (at least to my knowledge, I'd like to be proven wrong!). So we'll tackle this in a roundabout way.

Step 1: finding the automorphism group

The first step is deriving the automorphism group. Using the Combinatorica package as described in this answer, we find:

Block[{$ContextPath},
 Needs["Combinatorica`"];
 Needs["GraphUtilities`"];
 automorphisms = Combinatorica`Automorphisms @ GraphUtilities`ToCombinatoricaGraph[graph];
];

automorphisms // Length
120

Ok, this is $5!$, so we're on the right track.

Step 2: computing the coset representatives

Next, we convert the automorphism group into a proper Mathematica permutations group:

group = PermutationGroup[FindPermutation /@ automorphisms];

We need to compute the coset representatives of this group as a subgroup of $S_{10}$. For this we'll use the SymManipulator package:

<<xAct`SymManipulator`

(* Derive the strong generating set of the group. *)
stabchain = GroupStabilizerChain[group];
base      = stabchain[[-1, 1]];
genset    = GroupGenerators[stabchain[[1, -1]]];
(* Convert it into xAct language. *)
sgs   = StrongGenSet[base, GenSet @@ genset /. System`Cycles[{args___}] :> xAct`xPerm`Cycles[args]];
range = Range @ VertexCount @ graph;

(* Compute the coset representatives. *)
cosetreps = TransversalInSymmetricGroup[sgs, Symmetric[range];
cosetreps // Length
30240

We're still on the right track!

Step 3: selecting harmonious labelings

Next, we convert the coset representatives into ordinary replacement rules, after which we'll only select those that correspond to harmonious labelings:

(* Convert to a list of replacement rules. *)
cosetrepRules = Thread[range -> PermuteList[range, #]] & /@ cosetreps;

(* Creates a (possibly invalid) harmonious labeling from a list of edges. *)
HarmoniousLabels[edgelist_] := Mod[Plus @@@ edgelist, Length[edgelist]];
(* Checks if a list of edges admits a harmonious labeling. *)
HarmoniousQ[edgelist_]      := Sort@HarmoniousLabels[edgelist] === Range[0, Length[edgelist] - 1];

(* Select those replacement rules of permutations that correspond to harmonious labeling. *)
harmoniousperms = Select[cosetrepRules, HarmoniousQ[EdgeList[graph] /. #] &];
harmoniousperms // Length
21

This is slightly more than I would have expected based on ubpdqn's answer, namely $\frac{1440}{120} = 12$. If anyone can explain why this is the case, I'd be happy to know!

We can proceed to plot all the harmonious graphs:

PetersenGraph[
  5, 2, ImagePadding -> 10, 
  VertexLabels -> Table[i -> Placed[i /. #, Center], {i, 10}], 
  VertexSize -> Large, VertexStyle -> LightBlue, 
  EdgeLabels -> Thread[edgelist -> HarmoniousLabels[edgelist /. #]]
] & /@ harmoniousperms

Mathematica graphics

These are all the distinct harmonious labelings of the Petersen graph that are not related to each other via the symmetry.

$\endgroup$
  • $\begingroup$ Wow thank you guys for your answers. They really help! It's weird that mathematica does not come with labeling built in. Thanks! $\endgroup$ – sarafi Jul 19 '14 at 3:26
5
$\begingroup$

This is an interesting question and I await better answers than mine which is just some musings:

Some functions to visualize and decide if an edge labeling is harmonious:

hlab[list_] := 
 Graph[UndirectedEdge @@@ list, 
  EdgeLabels -> 
   Thread[UndirectedEdge @@@ 
      list -> (Mod[Total@#, Length@list] & /@ list)], 
  EdgeLabelStyle -> Directive[20, Red], 
  VertexLabels -> Placed["Name", Center], VertexSize -> 0.4, 
  VertexLabelStyle -> {Black, 20}]
hlabq[edge_] := 
 Column[{Image[hlab[edge], ImageSize -> 300], 
   If[Length[Union[Mod[Total@#, Length@edge] & /@ (List @@@ edge)]] ==
      Length@edge, 
    Style["This is a harmonious labeling", Darker[Green], Bold], 
    Style["This is NOT a harmonious labeling", Red, Bold]]}]

The natural vertex labeling of cycle graphs leads to harmonious labeling of edges, a small sample:

Grid[Partition[
  Table[hlabq[EdgeList[CycleGraph[j]]], {j, {3, 5, 7, 9}}], 2], 
 Frame -> All]

enter image description here

Now starts my rather brutsh ugly (and memory and time consuming way). There seem to be better ways to reduce the cases but, perhaps, to motivate much better answers:

Consider a Petersen graph:

pg = EdgeList[PetersenGraph[5, 3]];
hlabq[pg]

The 'natural' vertex labeling does not lead to a harmonious labeling:

enter image description here

Now an ugly search for a relabeling (that takes time on my machine):

lpg = List @@@ pg;
perm = Permutations[Range[10]];
rul = Thread[Range[10] -> #] & /@ perm;
testd = (lpg /. #) & /@ rul;
res=Select[testd, 
 Length[Union[Map[Function[u, Mod[Total@u, 15]], #]]] == 15 &];

This leads to 1440 cases of 3628800 permutations (obviously identiy fails and I have not checked for duplicates).

Visualizing one:

enter image description here

I very much look forward to better and more thoughtful answers.

$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.