数学研发网设为首页收藏本站
切换到窄版

 找回密码
 欢迎注册
数学研发论坛»论坛 › 【数学研究】 › 小题大作 › 复杂区域涂色方法数通用计算程序
返回列表 发新帖
查看: 15529|回复: 10

[转载] 复杂区域涂色方法数通用计算程序

[复制链接]
TSC999
发表于 2017-4-25 10:13:49 | 显示全部楼层 |阅读模式

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要 登录 才可以下载或查看，没有账号？欢迎注册

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

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

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

涂色区域 1.png

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

  1. f[k_, m_, {}] := m^k
  2. f[k_, m_, s_] :=
  3.   Module[{s1, s2, node1, node2}, node1 = s[[1]][[1]];
  4.    node2 = s[[1]][[2]]; s1 = Delete[s, 1];
  5.    s2 = Union[s1 /. node1 -> node2];
  6.    f[k, m, s1] - f[k - 1, m, s2]
  7.    ];
  8. s = Sort[{{1, 2}, {1, 4}, {2, 3}, {2, 5}, {3, 6}, {4, 5}, {4, 7}, {5,
  9.      6}, {5, 8}, {6, 9}, {7, 8}, {8, 9}}];
  10. (* 注意啦！上面任何一组数，都必须是小的在前，大的在后，不允许大的在前面哈！不然计算就可能出错！*)
  11. (* 注意啦！多加了花括号也会出错！Sort[{{{1,2},{1,4},{2,3},{2,5},{3,6},{4,5},{4,7},{5,\
  12. 6},{5,8},{6,9},{7,8},{8,9}}}]; *)
  13. f[9, 5, s](*正解 142820 *)
复制代码


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





补充内容 (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 种。

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

  1. f[k_, m_, {}] := m^k
  2. f[k_, m_, s_] :=
  3.   Module[{s1, s2, node1, node2}, node1 = s[[1]][[1]];
  4.    node2 = s[[1]][[2]]; s1 = Delete[s, 1];
  5.    s2 = Union[s1 /. node1 -> node2];
  6.    f[k, m, s1] - f[k - 1, m, s2]
  7.    ];
  8. s = Sort[{{1, 2}, {1, 4}, {2, 3}, {2, 5}, {3, 6}, {4, 5}, {4, 7}, {5,
  9.     6}, {5, 8}, {6, 9}, {7, 8}, {8, 9}}];(*9区3色 246 *)
  10. f[9, 3, s]
复制代码
毋因群疑而阻独见　　毋任己意而废人言
毋私小惠而伤大体　　毋借公论以快私情
回复 支持 反对

使用道具 举报

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 编辑

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

九宫格图.png

为了求出其染色多项式，有下面的 mathematica 程序：
  1. Clear["Global`*"];
  2. Array[g, 20]; Array[c, 20];
  3. f[k_, m_, {}] := m^k
  4. For[i = 2, i <= 11, i++,
  5.   f[k_, m_, s_] :=
  6.    Module[{s1, s2, node1, node2}, node1 = s[[1]][[1]];
  7.     node2 = s[[1]][[2]]; s1 = Delete[s, 1];
  8.     s2 = Union[s1 /. node1 -> node2];
  9.     f[k, m, s1] - f[k - 1, m, s2]
  10.     ];
  11.   s = Sort[{{5, 6}, {1, 4}, {5, 8}, {6, 9}, {2, 3}, {2, 5}, {3,
  12.       6}, {4, 5}, {4, 7}, {1, 2}, {7, 8}, {8, 9}}];
  13.   g[i] = f[9, i, s];
  14.   ];
  15. a = {a9, a8, a7, a6, a5, a4, a3, a2, a1} /.
  16.    NSolve[{a9 + a8 + a7 + a6 + a5 + a4 + a3 + a2 + a1 == g[2],
  17.      a9 2^9 + a8 2^8 + a7 2^7 + a6 2^6 + a5 2^5 + a4 2^4 + a3 2^3 +
  18.        a2 2^2 + a1 2^1 == g[3],
  19.      a9 3^9 + a8 3^8 + a7 3^7 + a6 3^6 + a5 3^5 + a4 3^4 + a3 3^3 +
  20.        a2 3^2 + a1 3^1 == g[4],
  21.      a9 4^9 + a8 4^8 + a7 4^7 + a6 4^6 + a5 4^5 + a4 4^4 + a3 4^3 +
  22.        a2 4^2 + a1 4^1 == g[5],
  23.      a9 5^9 + a8 5^8 + a7 5^7 + a6 5^6 + a5 5^5 + a4 5^4 + a3 5^3 +
  24.        a2 5^2 + a1 5^1 == g[6],
  25.      a9 6^9 + a8 6^8 + a7 6^7 + a6 6^6 + a5 6^5 + a4 6^4 + a3 6^3 +
  26.        a2 6^2 + a1 6^1 == g[7],
  27.      a9 7^9 + a8 7^8 + a7 7^7 + a6 7^6 + a5 7^5 + a4 7^4 + a3 7^3 +
  28.        a2 7^2 + a1 7^1 == g[8],
  29.      a9 8^9 + a8 8^8 + a7 8^7 + a6 8^6 + a5 8^5 + a4 8^4 + a3 8^3 +
  30.        a2 8^2 + a1 8^1 == g[9],
  31.      a9 9^9 + a8 9^8 + a7 9^7 + a6 9^6 + a5 9^5 + a4 9^4 + a3 9^3 +
  32.        a2 9^2 + a1 9^1 == g[10]}, {a9, a8, a7, a6, a5, a4, a3, a2,
  33.      a1}, Integers];
  34. b = a[[1]];
  35. For[i = 1, i <= 9, i++,
  36.   c[i] = b[[i]];
  37.   ];
  38. Print["f(n)=",
  39. Factor[ c[1] n^9 + c[2] n^8 + c[3] n^7 + c[4] n^6 + c[5] n^5 +
  40.    c[6] n^4 + c[7] n^3 + c[8] n^2 + c[9] n]]
  41. f[n_] := Factor[
  42.   c[1] n^9 + c[2] n^8 + c[3] n^7 + c[4] n^6 + c[5] n^5 + c[6] n^4 +
  43.    c[7] n^3 + c[8] n^2 + c[9] n]
  44. For[n = 1, n <= 19, n++,
  45. Print["m=", n + 1, "时，n=", n, "，f(", n, ")=", f[n]]
  46. ]
复制代码


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

第一个例子运行结果.png
毋因群疑而阻独见　　毋任己意而废人言
毋私小惠而伤大体　　毋借公论以快私情
回复 支持 反对

使用道具 举报

TSC999
 楼主| 发表于 2017-4-30 10:27:24 | 显示全部楼层
本帖最后由 TSC999 于 2017-4-30 10:28 编辑

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

给区域编号.png

为求出上面区域的染色多项式，编程如下：
  1. Clear["Global`*"];
  2. Array[g, 20]; Array[c, 20];
  3. f[k_, m_, {}] := m^k
  4. For[i = 2, i <= 11, i++,
  5.   f[k_, m_, s_] :=
  6.    Module[{s1, s2, node1, node2}, node1 = s[[1]][[1]];
  7.     node2 = s[[1]][[2]]; s1 = Delete[s, 1];
  8.     s2 = Union[s1 /. node1 -> node2];
  9.     f[k, m, s1] - f[k - 1, m, s2]
  10.     ];
  11.   s = Sort[{{1, 2}, {1, 3}, {2, 3}, {2, 4}, {2, 5}, {3, 5}, {3,
  12.       6}, {4, 5}, {4, 7}, {4, 8}, {5, 6}, {5, 7}, {6, 7}, {7, 8}}];
  13.   g[i] = f[8, i, s];
  14.   ];
  15. a = {a8, a7, a6, a5, a4, a3, a2, a1} /.
  16.    NSolve[{a8 + a7 + a6 + a5 + a4 + a3 + a2 + a1 == g[2],
  17.      a8 2^8 + a7 2^7 + a6 2^6 + a5 2^5 + a4 2^4 + a3 2^3 + a2 2^2 +
  18.        a1 2^1 == g[3],
  19.      a8 3^8 + a7 3^7 + a6 3^6 + a5 3^5 + a4 3^4 + a3 3^3 + a2 3^2 +
  20.        a1 3^1 == g[4],
  21.      a8 4^8 + a7 4^7 + a6 4^6 + a5 4^5 + a4 4^4 + a3 4^3 + a2 4^2 +
  22.        a1 4^1 == g[5],
  23.      a8 5^8 + a7 5^7 + a6 5^6 + a5 5^5 + a4 5^4 + a3 5^3 + a2 5^2 +
  24.        a1 5^1 == g[6],
  25.      a8 6^8 + a7 6^7 + a6 6^6 + a5 6^5 + a4 6^4 + a3 6^3 + a2 6^2 +
  26.        a1 6^1 == g[7],
  27.      a8 7^8 + a7 7^7 + a6 7^6 + a5 7^5 + a4 7^4 + a3 7^3 + a2 7^2 +
  28.        a1 7^1 == g[8],
  29.      a8 8^8 + a7 8^7 + a6 8^6 + a5 8^5 + a4 8^4 + a3 8^3 + a2 8^2 +
  30.        a1 8^1 == g[9]}, {a8, a7, a6, a5, a4, a3, a2, a1}, Integers];
  31. b = a[[1]];
  32. For[i = 1, i <= 8, i++,
  33.   c[i] = b[[i]];
  34.   ];
  35. Print["f(n)=",
  36. Factor[ c[1] n^8 + c[2] n^7 + c[3] n^6 + c[4] n^5 + c[5] n^4 +
  37.    c[6] n^3 + c[7] n^2 + c[8] n]]
  38. f[n_] := Factor[
  39.   c[1] n^8 + c[2] n^7 + c[3] n^6 + c[4] n^5 + c[5] n^4 + c[6] n^3 +
  40.    c[7] n^2 + c[8] n]
  41. For[n = 1, n <= 19, n++,
  42. Print["m=", n + 1, "时，n=", n, "，f(", n, ")=", f[n]]
  43. ]
复制代码


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

第二个例子运行结果.png
毋因群疑而阻独见　　毋任己意而废人言
毋私小惠而伤大体　　毋借公论以快私情
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 欢迎注册

本版积分规则

小黑屋|手机版|数学研发网 ( 苏ICP备07505100号 )

GMT+8, 2024-12-4 17:08 , Processed in 0.035908 second(s), 23 queries .

Powered by Discuz! X3.5

© 2001-2024 Discuz! Team.

快速回复 返回顶部 返回列表