任意区域涂色方法数以及涂色多项式的编程计算
本帖将试图解决两个问题：（1）任意给定复杂涂色区域和颜色数量。相邻区域不允许涂成同一种颜色，问：共有多少种不同的涂色方法？用 mathematica 编程计算。
（2）任意给定复杂涂色区域和 m 种颜色数量。相邻区域不允许涂成同一种颜色，则涂色方法数目是 m 的多项式函数，可称之为“涂色多项式”。用 mathematica 编程求这个多项式。
第（1）个问题是台湾台北市立阳明高中某数学老师写的一篇论文，说的是复杂区域涂色方法数如何计算的分析过程，以及用 mathematica 写的计算程序。本人只是转发了一下（只对其中一句稍做了一点必要的修改）。
第（2）个问题是在上述问题的基础上，本人独立解决的。但是程序是否好，如何改进，是需要大家研究的。 [i=s] 本帖最后由 TSC999 于 2017-5-19 18:49 编辑 [/i]
例 1. 如下图，用 5 种颜色对一个九宫格图涂色，相邻区域不得使用同一种颜色。问，共有多少种不同的涂色方法？
[attach]4966[/attach]
程序如下：[code]f[k_, m_, {}] := m^k
f[k_, m_, s_] :=
Module[{s1, s2, node1, node2}, node1 = s[[1]][[1]];
node2 = s[[1]][[2]]; s1 = Delete[s, 1];
s2 = Union[s1 /. node1 -> node2];
f[k, m, s1] - f[k - 1, m, s2]
];
s = Sort[{{1, 2}, {1, 4}, {2, 3}, {2, 5}, {3, 6}, {4, 5}, {4, 7}, {5,
6}, {5, 8}, {6, 9}, {7, 8}, {8, 9}}];
(* 注意啦！上面任何一组数，都必须是小的在前，大的在后，不允许大的在前面哈！不然计算就可能出错啦！*)
(* 注意啦！多加了花括号也会出错的！Sort[{{{1,2},{1,4},{2,3},{2,5},{3,6},{4,5},{4,7},{5,\
6},{5,8},{6,9},{7,8},{8,9}}}]; *)
f[9, 5, s] [/code]运行结果为 142820。
原帖名称及网址：旧的涂色问题，新的计算方法
[url]http://www.doc88.com/p-5455415246899.html[/url] 上面这个九区域图，如果用 $m$ 种颜色来涂，相邻区域不同色，涂色方法数 $ f(m) $ 将是 $m$ 的函数。问：如何求出这个 $ f(m) $ 函数？
下面以九宫格区域为例，说明编程方法。[code]Clear["Global`*"];
Array[g, 20]; Array[c, 20];
f[k_, m_, {}] := m^k
For[i = 2, i <= 11, i++,
f[k_, m_, s_] :=
Module[{s1, s2, node1, node2}, node1 = s[[1]][[1]];
node2 = s[[1]][[2]]; s1 = Delete[s, 1];
s2 = Union[s1 /. node1 -> node2];
f[k, m, s1] - f[k - 1, m, s2]
];
s = Sort[{{5, 6}, {1, 4}, {5, 8}, {6, 9}, {2, 3}, {2, 5}, {3,
6}, {4, 5}, {4, 7}, {1, 2}, {7, 8}, {8, 9}}];
g[i] = f[9, i, s];
];
a = {a9, a8, a7, a6, a5, a4, a3, a2, a1} /.
NSolve[{a9 + a8 + a7 + a6 + a5 + a4 + a3 + a2 + a1 == g[2],
a9 2^9 + a8 2^8 + a7 2^7 + a6 2^6 + a5 2^5 + a4 2^4 + a3 2^3 +
a2 2^2 + a1 2^1 == g[3],
a9 3^9 + a8 3^8 + a7 3^7 + a6 3^6 + a5 3^5 + a4 3^4 + a3 3^3 +
a2 3^2 + a1 3^1 == g[4],
a9 4^9 + a8 4^8 + a7 4^7 + a6 4^6 + a5 4^5 + a4 4^4 + a3 4^3 +
a2 4^2 + a1 4^1 == g[5],
a9 5^9 + a8 5^8 + a7 5^7 + a6 5^6 + a5 5^5 + a4 5^4 + a3 5^3 +
a2 5^2 + a1 5^1 == g[6],
a9 6^9 + a8 6^8 + a7 6^7 + a6 6^6 + a5 6^5 + a4 6^4 + a3 6^3 +
a2 6^2 + a1 6^1 == g[7],
a9 7^9 + a8 7^8 + a7 7^7 + a6 7^6 + a5 7^5 + a4 7^4 + a3 7^3 +
a2 7^2 + a1 7^1 == g[8],
a9 8^9 + a8 8^8 + a7 8^7 + a6 8^6 + a5 8^5 + a4 8^4 + a3 8^3 +
a2 8^2 + a1 8^1 == g[9],
a9 9^9 + a8 9^8 + a7 9^7 + a6 9^6 + a5 9^5 + a4 9^4 + a3 9^3 +
a2 9^2 + a1 9^1 == g[10]}, {a9, a8, a7, a6, a5, a4, a3, a2,
a1}, Integers];
b = a[[1]];
For[i = 1, i <= 9, i++,
c[i] = b[[i]];
];
Print["f(n)=",
Factor[ c[1] n^9 + c[2] n^8 + c[3] n^7 + c[4] n^6 + c[5] n^5 +
c[6] n^4 + c[7] n^3 + c[8] n^2 + c[9] n]]
f[n_] := Factor[
c[1] n^9 + c[2] n^8 + c[3] n^7 + c[4] n^6 + c[5] n^5 + c[6] n^4 +
c[7] n^3 + c[8] n^2 + c[9] n]
For[n = 1, n <= 19, n++,
Print["m=", n + 1, "时，n=", n, "，f(", n, ")=", f[n]]
][/code]运行结果为：
[attach]4967[/attach] 再来第二个例子，对于下面这个八区域，求其染色多项式：
[attach]4970[/attach]
为求出上面区域的染色多项式，编程如下：[code]Clear["Global`*"];
Array[g, 20]; Array[c, 20];
f[k_, m_, {}] := m^k
For[i = 2, i <= 11, i++,
f[k_, m_, s_] :=
Module[{s1, s2, node1, node2}, node1 = s[[1]][[1]];
node2 = s[[1]][[2]]; s1 = Delete[s, 1];
s2 = Union[s1 /. node1 -> node2];
f[k, m, s1] - f[k - 1, m, s2]
];
s = Sort[{{1, 2}, {1, 3}, {2, 3}, {2, 4}, {2, 5}, {3, 5}, {3,
6}, {4, 5}, {4, 7}, {4, 8}, {5, 6}, {5, 7}, {6, 7}, {7, 8}}];
g[i] = f[8, i, s];
];
a = {a8, a7, a6, a5, a4, a3, a2, a1} /.
NSolve[{a8 + a7 + a6 + a5 + a4 + a3 + a2 + a1 == g[2],
a8 2^8 + a7 2^7 + a6 2^6 + a5 2^5 + a4 2^4 + a3 2^3 + a2 2^2 +
a1 2^1 == g[3],
a8 3^8 + a7 3^7 + a6 3^6 + a5 3^5 + a4 3^4 + a3 3^3 + a2 3^2 +
a1 3^1 == g[4],
a8 4^8 + a7 4^7 + a6 4^6 + a5 4^5 + a4 4^4 + a3 4^3 + a2 4^2 +
a1 4^1 == g[5],
a8 5^8 + a7 5^7 + a6 5^6 + a5 5^5 + a4 5^4 + a3 5^3 + a2 5^2 +
a1 5^1 == g[6],
a8 6^8 + a7 6^7 + a6 6^6 + a5 6^5 + a4 6^4 + a3 6^3 + a2 6^2 +
a1 6^1 == g[7],
a8 7^8 + a7 7^7 + a6 7^6 + a5 7^5 + a4 7^4 + a3 7^3 + a2 7^2 +
a1 7^1 == g[8],
a8 8^8 + a7 8^7 + a6 8^6 + a5 8^5 + a4 8^4 + a3 8^3 + a2 8^2 +
a1 8^1 == g[9]}, {a8, a7, a6, a5, a4, a3, a2, a1}, Integers];
b = a[[1]];
For[i = 1, i <= 8, i++,
c[i] = b[[i]];
];
Print["f(n)=",
Factor[ c[1] n^8 + c[2] n^7 + c[3] n^6 + c[4] n^5 + c[5] n^4 +
c[6] n^3 + c[7] n^2 + c[8] n]]
f[n_] := Factor[
c[1] n^8 + c[2] n^7 + c[3] n^6 + c[4] n^5 + c[5] n^4 + c[6] n^3 +
c[7] n^2 + c[8] n]
For[n = 1, n <= 19, n++,
Print["m=", n + 1, "时，n=", n, "，f(", n, ")=", f[n]]
]
[/code]程序运行结果如下（注意，式中 n=m-1，所以当 m=3 时， n=2，f(n)=f(2) 即是用 3 种颜色时的涂色方法数。余类推）：
[attach]4971[/attach]
页:
[1]