Harmonious graph labeling

Question

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.

Answer 1

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[]

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

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

Answer 2

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]

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:

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:

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