论坛 › 小题大作 › 复杂区域涂色方法数通用计算程序

TSC999 发表于 2017-4-25 10:13:49

复杂区域涂色方法数通用计算程序

去年，从网上偶然搜到一篇台湾台北市立阳明高中某数学老师写的一篇论文，说的是复杂区域涂色方法数如何计算的分析过程，以及用 mathematica 写的计算程序。

对一些实际问题，本人使用该程序（本人对原程序只作了一点小的改进，增加了一个 Sort 语句 ）进行了计算，与人工计算结果相比较，二者完全相同。我觉得这篇文章写成不错，程序也是可信的，特发在此供网友们分享。

唉，图片文件太大，发不上来。原文的地址又忘记了，找不到了。先把 mathematica 程序发上来吧。



对于上图中的九个区域，用 5 种颜色涂色，相邻区域不能涂成相同的颜色。有多少种涂色方法？ 程序如下：

f := m^k
f :=
Module[{s1, s2, node1, node2}, node1 = s[][];
   node2 = s[][]; s1 = Delete;
   s2 = Union;
   f - f
   ];
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(*正解 142820 *)

请读过原文并知道原文网址的，把网址发上来供大家分享哈。






补充内容 (2017-4-26 19:34):
旧的涂色问题，新的计算方法
http://www.doc88.com/p-5455415246899.html

TSC999 发表于 2017-4-26 11:17:42

本帖最后由 TSC999 于 2017-4-26 14:23 编辑

9 区域（图见上面 1# 楼）， 3 种颜色，涂色方案数按下面程序计算为 246 种。 4 种颜色，涂色方案数为 9612 种。

经手工计算，上面两个结果与电脑程序计算结果完全相同。

f := m^k
f :=
Module[{s1, s2, node1, node2}, node1 = s[][];
   node2 = s[][]; s1 = Delete;
   s2 = Union;
   f - f
   ];
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}}];(*9区3色 246 *)
f

TSC999 发表于 2017-4-28 23:18:51

本帖最后由 TSC999 于 2017-4-28 23:32 编辑

上面这个九区域图，如果用 \( m \) 种颜色来涂，相邻区域不同色，涂色方法数 \(f(m) \) 将是 \( m \) 的函数。问：如何求出这个 \(f(m) \) 函数？

mathe 发表于 2017-4-29 17:44:09

计算染色多项式没有效率很高的算法。
比如对于本题，假设有X种颜色，先对一号点染色，有X种选择，然后二号点(X-1)种选择，三号，四号都(X-1)种选择方案
但是到了5号点我们遇上问题了，这是因为我们不知道2号和4号是否同种颜色。为此我们需要将图分裂成两种情况，2号于4号不同色的图（相当于添加一条边连接2号和4号点），以及2号和4号同色的图(相当于合并2号和4号点得到的图),然后我们继续同样的过程，可以知道遇上5，6，8，9号点时都需要对于前面的点进行处理，由此可以分裂出16个不同的子图，然后对于每个子图用上面的方法简单的使用乘法原理就可以计算出结果，最后相加即可

TSC999 发表于 2017-4-30 10:11:20

本帖最后由 TSC999 于 2017-4-30 10:29 编辑

对于下面这个【九宫格】区域：



为了求出其染色多项式，有下面的 mathematica 程序：
Clear["Global`*"];
Array; Array;
f := m^k
For[i = 2, i <= 11, i++,
f :=
   Module[{s1, s2, node1, node2}, node1 = s[][];
    node2 = s[][]; s1 = Delete;
    s2 = Union;
    f - f
    ];
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 = f;
];
a = {a9, a8, a7, a6, a5, a4, a3, a2, a1} /.
   NSolve[{a9 + a8 + a7 + a6 + a5 + a4 + a3 + a2 + a1 == g,
   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,
   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,
   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,
   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,
   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,
   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,
   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,
   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}, {a9, a8, a7, a6, a5, a4, a3, a2,
   a1}, Integers];
b = a[];
For[i = 1, i <= 9, i++,
c = b[];
];
Print["f(n)=",
Factor[ c n^9 + c n^8 + c n^7 + c n^6 + c n^5 +
   c n^4 + c n^3 + c n^2 + c n]]
f := Factor[
c n^9 + c n^8 + c n^7 + c n^6 + c n^5 + c n^4 +
   c n^3 + c n^2 + c n]
For[n = 1, n <= 19, n++,
Print["m=", n + 1, "时，n=", n, "，f(", n, ")=", f]
]

以上程序运行结果如下（注意，式中 n=m-1，因此 f(n)=f(1) 表示 m=2 即 2 种颜色时的涂色方法数目，余类推）：

TSC999 发表于 2017-4-30 10:27:24

本帖最后由 TSC999 于 2017-4-30 10:28 编辑

再来第二个例子，对于下面这个八区域，求其染色多项式：



为求出上面区域的染色多项式，编程如下：
Clear["Global`*"];
Array; Array;
f := m^k
For[i = 2, i <= 11, i++,
f :=
   Module[{s1, s2, node1, node2}, node1 = s[][];
    node2 = s[][]; s1 = Delete;
    s2 = Union;
    f - f
    ];
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 = f;
];
a = {a8, a7, a6, a5, a4, a3, a2, a1} /.
   NSolve[{a8 + a7 + a6 + a5 + a4 + a3 + a2 + a1 == g,
   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,
   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,
   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,
   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,
   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,
   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,
   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}, {a8, a7, a6, a5, a4, a3, a2, a1}, Integers];
b = a[];
For[i = 1, i <= 8, i++,
c = b[];
];
Print["f(n)=",
Factor[ c n^8 + c n^7 + c n^6 + c n^5 + c n^4 +
   c n^3 + c n^2 + c n]]
f := Factor[
c n^8 + c n^7 + c n^6 + c n^5 + c n^4 + c n^3 +
   c n^2 + c n]
For[n = 1, n <= 19, n++,
Print["m=", n + 1, "时，n=", n, "，f(", n, ")=", f]
]


程序运行结果如下（注意，式中 n=m-1，所以当 m=3 时， n=2，f(n)=f(2) 即是用 3 种颜色时的涂色方法数。余类推）：

查看完整版本: 复杂区域涂色方法数通用计算程序