Algorithm and answer to query
A Google search will reveal that these graph colorings are counted by
so-called orbital chromatic polynomials (as opposed to ordinary
chromatic polynomials). These count proper colorings under the action
of the automorphism group of the graph.
The algorithm to compute these is documented e.g. at Peter Cameron's
blog. This is really
quite straightforward supposing that the number of automorphisms of
the graph is of a reasonable order, e.g. linear in the number of
vertices as in the case of a bracelet. What we do here is to apply
Burnside, iterating over all automorphisms and computing the number of
proper colorings that they fix and averaging the results. To do this
we factorize the automorphisms into cycles, on which the color has to
be constant. Therefore we have no contribution if a cycle of the
factored automorphism contains two vertices linked by an edge since
these may not be monochrome in a proper coloring. Otherwise we shrink
all the cycles to vertices, creating a reduced graph, where two new
vertices are adjacent if there existed an edge between the vertices on
the cycles in the source graph. The colorings fixed by this
automorphism are then counted by the ordinary chromatic polynomial of
the reduced graph. Hence the orbital chromatic polynomial is
obtained by averaging these over the number of automorphisms.
It is not difficult to implement this in Maple, where the goal was to
get a functioning program to answer the question, which may of course
be optimized in many ways. We decided on a simple data structure
representing graphs and their automorphism group by a list of the
edges, the number of vertices, and the permutations from the group.
We use these as inputs to Burnside where we carry out the iteration
that we described, obtaining the OCP. Numbering the four trees from
left to right we thus obtain for the first tree,
$$1/8\,{k}^{7}-1/2\,{k}^{6}+1/4\,{k}^{2}-1/4\,{k}^{4}
\\-3/8\,{k}^{3}+3/4\,{k}^{5},$$
for the second one,
$$1/6\,{k}^{7}-{k}^{6}+3\,{k}^{5}-16/3\,{k}^{4}
\\+{\frac {35\,{k}^{3}}{6}}-11/3\,{k}^{2}+k$$
for the third one
$$1/24\,{k}^{7}-1/6\,{k}^{5}+1/12\,{k}^{4}
\\+1/8\,{k}^{3}-1/12\,{k}^{2}$$
and for the last one,
$$1/12\,{k}^{7}-1/6\,{k}^{6}+1/6\,{k}^{4}-1/12\,{k}^{3}.$$
The admissible colorings under the action of the automorphism group of
the tree are then computed by instantiating $k$ to the number of
colors.
Sanity checks and more
With these trees having a reasonable number of automorphisms we can
check the correctness of the OCP by enumerating colorings with few
colors. This was done and may be seen in the attached Maple code.
E.g. for tree number three the enumeration routine produces
$$0, 2, 60, 540, 2800, 10500,\ldots $$
which is indeed given by the polynomial listed above.
Similarly the question of proper colorings of bracelets (dihedral
symmetry) recently appeared at this MSE
link. This forms
the second sanity check where for example we obtain matching OCPs from
the cited link and the present document. E.g. for a bracelet on five
beads we obtain by both methods
$$1/10\,{k}^{5}-1/2\,{k}^{4}+{k}^{3}-{k}^{2}+2/5\,k$$
and for six beads,
$$1/12\,{k}^{6}-1/2\,{k}^{5}+3/2\,{k}^{4}-7/3\,{k}^{3}
+{\frac {23\,{k}^{2}}{12}}-2/3\,k.$$
Maple code
We now present the Maple code which uses only one routine from a
library of Polya Enumeration code while the rest translates the
specification of the algorithm with little auxiliary effort required.
with(GraphTheory);
with(combinat);
T1 :=
proc()
option remember;
return
[7,
{{1,2}, {1, 3}, {2, 4}, {2, 5},
{3, 6}, {3, 7}},
[[1,2,3,4,5,6,7],
[1,2,3,5,4,6,7],
[1,2,3,4,5,7,6],
[1,2,3,5,4,7,6],
[1,3,2,6,7,4,5],
[1,3,2,7,6,4,5],
[1,3,2,6,7,5,4],
[1,3,2,7,6,5,4]]];
end;
T2 :=
proc()
option remember;
local automs, src, perm;
src := [[2,3], [4,5], [6,7]];
automs := [];
for perm in permute(3) do
automs :=
[op(automs),
[1,
seq(op(src[perm[q]]),
q=1..3)]];
od;
return
[7,
{{1, 2}, {1, 4}, {1, 6},
{2, 3}, {4, 5}, {6, 7}},
automs];
end;
T3 :=
proc()
option remember;
local automs, perm;
automs := [];
for perm in permute(4) do
automs :=
[op(automs),
[1,2,3, seq(perm[q]+3, q=1..4)]];
od;
return
[7,
{{1, 2}, {2, 3},
{1, 4}, {1, 5}, {1, 6}, {1, 7}},
automs];
end;
T4 :=
proc()
option remember;
local automs, perm1, perm2;
automs := [];
for perm1 in permute(2) do
for perm2 in permute(3) do
automs :=
[op(automs),
[1, 2,
seq(perm1[q]+2, q=1..2),
seq(perm2[q]+4, q=1..3)]];
od;
od;
return
[7,
{{1, 2}, {1, 5}, {1, 6}, {1, 7},
{2, 3}, {2, 4}},
automs];
end;
BRACELET :=
proc(n)
option remember;
local automs, rot, shft, edges;
if n=1 then return [1, {}, [[1]]] fi;
automs := [];
for rot to n do
shft :=
[seq(q, q=rot..n), seq(q, q=1..rot-1)];
automs :=
[op(automs),
shft, [seq(shft[n-q], q=0..n-1)]];
od;
edges :=
{{n, 1},
seq({q, q+1}, q=1..n-1)};
return [n, edges, automs];
end;
pet_autom2cyclesA :=
proc(src, aut)
local numa, numsubs;
local marks, pos, cycs, data, item, cpos, clen;
numsubs := [seq(src[k]=k, k=1..nops(src))];
numa := subs(numsubs, aut);
marks := Array([seq(true, pos=1..nops(aut))]);
cycs := []; pos := 1; data := [];
while pos <= nops(aut) do
if marks[pos] then
clen := 0; item := []; cpos := pos;
while marks[cpos] do
marks[cpos] := false;
item := [op(item), aut[cpos]];
cpos := numa[cpos];
clen := clen+1;
od;
cycs := [op(cycs), clen];
data := [op(data), item];
fi;
pos := pos+1;
od;
return [data, mul(a[cycs[k]], k=1..nops(cycs))];
end;
OCP :=
proc(tdata)
option remember;
local n, edges, automs, autom, src,
cycs, cidx, ccount, admit, edg,
potedg, rededgs, cdx1, cdx2, c1, c2, redG, ocp;
n := tdata[1];
edges := tdata[2];
automs := tdata[3];
src := [seq(q, q=1..n)];
ocp := 0;
for autom in automs do
cycs := pet_autom2cyclesA(src, autom)[1];
ccount := nops(cycs);
admit := true; cidx := 1;
while admit and cidx <= ccount do
for edg in choose(cycs[cidx], 2) do
if {edg[1], edg[2]} in
edges then
admit := false;
break;
fi;
od;
cidx := cidx + 1;
od;
if admit then
rededgs := {};
for cdx1 to ccount do
for cdx2 from cdx1+1 to ccount do
c1 := cycs[cdx1]; c2 := cycs[cdx2];
potedg :=
{seq(seq({c1[p], c2[q]},
p=1..nops(c1)), q=1..nops(c2))};
if edges intersect potedg <> {} then
rededgs :=
{op(rededgs), {cdx1, cdx2}};
fi;
od;
od;
redG :=
Graph([seq(q, q=1..ccount)], rededgs);
ocp := ocp +
ChromaticPolynomial(redG, 'k');
fi;
od;
expand(ocp/nops(automs));
end;
X := (tdata, kval) -> subs('k'=kval, OCP(tdata));
ENUM :=
proc(tdata, k)
option remember;
local n, edges, edg, admit, automs, autom,
orbits, orbit, idx, cols;
n := tdata[1];
edges := tdata[2];
automs := tdata[3];
if k=1 then
return `if`(nops(edges)=0, 1, 0);
fi;
orbits := table();
for idx from k^n to 2*k^n-1 do
cols := convert(idx, base, k)[1..n];
admit := true;
for edg in edges do
if cols[op(1, edg)] = cols[op(2, edg)]
then
admit := false;
break;
fi;
od;
if not admit then next fi;
orbit := [];
for autom in automs do
orbit :=
[op(orbit),
[seq(cols[autom[q]], q=1..n)]];
od;
orbits[sort(orbit)[1]] := 1;
od;
numelems(orbits);
end;