数学研发论坛

 找回密码
 欢迎注册
查看: 374|回复: 18

[讨论] 有黄绿红三种颜色的珠子各 4、4、1个。用它们穿成 9 颗珠子的手串,有多少种组合?

[复制链接]
发表于 2021-7-4 23:19:56 | 显示全部楼层 |阅读模式

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

您需要 登录 才可以下载或查看,没有帐号?欢迎注册

x
有大小相同的珠子共 9 个,其中黄色的 4 颗,绿色的 4 颗,红色的 1 颗。用它们穿成 9 颗珠子的手串,有多少种不同的花色组合?

可以参考常新德(河南永城职业学院老师)写的论文。网址:https://max.book118.com/html/2017/0729/125132578.shtm

本帖的目的,就是探讨一下上面这篇论文中的公式是否全都正确。


补充内容 (2021-7-9 08:47):
5 天后编写了计算程序(见后面)。用程序计算 3 种颜色(1 红、4 黄、4 绿)的花色组合数为 38 种。用常新德公式计算也是 38 种。即在 m=3,n1=1,n2=4,n3=4 时程序与公式计算结果相同。但其它情况下有不一致的。
毋因群疑而阻独见  毋任己意而废人言
毋私小惠而伤大体  毋借公论以快私情
 楼主| 发表于 2021-7-7 21:58:57 | 显示全部楼层
本帖最后由 TSC999 于 2021-7-8 06:06 编辑

本帖目的在主帖中说了,是为了改进常新德老师(河南永城职业学院)大约在 2008 年写的论文《有重复元素的圆排列和环排列的计数问题》。见网址:https://max.book118.com/html/2017/0729/125132578.shtm
对于有 m 种颜色,每种颜色的珠子分别有 n(1)、n(2)、......、n(m) 颗,能穿成多少种花色的手串问题(手串共有 n(1)+n(2)+......+n(m) 颗珠子),论文给出的计算公式中,要求各种颜色的珠子数目,至多只能有两个是奇数。
这就限制了应用范围。比如现在有 3 种颜色红、绿、黄,其中红珠 3 颗,绿珠 1 颗, 黄珠 1 颗,由于每种颜色的珠子数目都是奇数,不符合公式约定的 “珠子数目至多只能有两个是奇数” 这一要求, 所以计算结果是一个分数。
如果把分数结果取整,舍掉小数部分,好像能得到正确结果。为了验证这个想法是否正确,我们必须事先写一个计算程序作为裁判,以便由程序给出一个可信赖的结果。

我用 mathematica 初步写了一个程序,似能正确运行,但是尚缺最后一步即如何加上一个循环语句。
在程序中设定共有红、绿、黄 3 种颜色即 m=3。其中红珠 3 颗,绿珠 1 颗,黄珠 1 颗。对于这种非常简单的情况,只有 2 种可能的花色,见下图。

2 种花色.png

程序调试成功后,可将颜色数目和各色珠子数量随意修改。目前程序尚未最终完成,但程序能给出正确的计算结果。程序如下:
  1. Clear["Global`*"];
  2. Array[a, 20];
  3. ss = {};     (* 所有的方案数列表 *)
  4. a = Permutations[{"黄", "绿", "红", "红",
  5.    "红"}, {5}]; (* 5个有重复元素的全排列,a 是个列表*)
  6. L = Length[a];       (* 共有多少种线排列? *)
  7. (* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
  8. s = a[[1]];  (* 候选方案*)
  9. ss = Append[ss, s];
  10. s1 = Reverse[s];  (* 候选方案反排*)
  11. Do[If[a[[i]] == s || a[[i]] == s1, a[[i]] = {}], {i, 2,
  12.   L}]; (* s 左移,s1右移之前,先筛一次 *)
  13. Do[s = RotateLeft[s];
  14. s1 = RotateRight[s1]; (* s 左移一位,并存到 s 中; s1右移一位,并存到 s1 中*)
  15. Do[If[a[[i]] == s || a[[i]] == s1, a[[i]] = {}], {i, 2, L}];
  16. , {i, 1,
  17.   4}];     (* s每左移一位、s1每右移一位,与其余的比较,若有一个是相同的,将那个其余清空。共筛 4 次 *)
  18. a = DeleteCases[a, {}]; (* 去掉 a 中的所有空集 *)
  19. a = Delete[a, 1]    (* 去掉 a 中的候选方案 a[[1]] 后的 a 列表 *)
  20. L = Length[a]       (* 筛一轮后的 a 还有多少种线排列? *)
  21. If[L == 0, Print[ss, " 所有方案展示"]];
  22. Print[" ########################################## "];
  23. s = a[[1]];  (* 候选方案*)
  24. ss = Append[ss, s];
  25. s1 = Reverse[s];  (* 候选方案反排*)
  26. Do[If[a[[i]] == s || a[[i]] == s1, a[[i]] = {}], {i, 2,
  27.   L}]; (* s 左移,s1右移之前,先筛一次 *)
  28. Do[s = RotateLeft[s];
  29. s1 = RotateRight[s1]; (* s 左移一位,并存到 s 中; s1右移一位,并存到 s1 中*)
  30. Do[If[a[[i]] == s || a[[i]] == s1, a[[i]] = {}], {i, 2, L}];
  31. , {i, 1,
  32.   4}];     (* s每左移一位、s1每右移一位,与其余的比较,若有一个是相同的,将那个其余清空。共筛 4 次 *)
  33. a = DeleteCases[a, {}]; (* 去掉 a 中的所有空集 *)
  34. a = Delete[a, 1]    (* 去掉 a 中的候选方案 a[[1]] 后的 a 列表 *)
  35. L = Length[a]       (* 筛一轮后的 a 还有多少种线排列? *)
  36. If[L == 0, Print[ss, " 所有方案展示"]];
  37. Print[" ########################################## "];
复制代码


上面这程序运行结果为:

运行结果.png

上面程序尚存在毛病,因为有两段相邻程序是完全相同的,必须把它们放进一个 While 循环语句中去以控制循环次数才行。试改如下:
  1. Clear["Global`*"];
  2. Array[a, 20];
  3. ss = {};     (* 所有的方案数列表 *)
  4. a = Permutations[{"黄", "绿", "红", "红",
  5.    "红"}, {5}]; (* 5个有重复元素的全排列,a 是个列表*)
  6. L = Length[a];       (* 共有多少种线排列? *)
  7. (* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
  8. While[L > 0,
  9. s = a[[1]];  (* 候选方案*)
  10. ss = Append[ss, s];
  11. s1 = Reverse[s];  (* 候选方案反排*)
  12. Do[If[a[[i]] == s || a[[i]] == s1, a[[i]] = {}], {i, 2,
  13.    L}]; (* s 左移,s1右移之前,先筛一次 *)
  14. Do[s = RotateLeft[s]; s1 = RotateRight[s1]; (* s 左移一位,并存到 s 中;
  15.   s1右移一位,并存到 s1 中*)
  16.   Do[If[a[[i]] == s || a[[i]] == s1, a[[i]] = {}], {i, 2, L}];
  17.   , {i, 1, 4}];     (* s每左移一位、s1每右移一位,与其余的比较,若有一个是相同的,将那个其余清空。共筛 4 次 *)
  18. a = DeleteCases[a, {}]; (* 去掉 a 中的所有空集 *)
  19. a = Delete[a, 1]    (* 去掉 a 中的候选方案 a[[1]] 后的 a 列表 *)
  20.     L = Length[a]       (* 筛一轮后的 a 还有多少种线排列? *)
  21.     If[L == 0, Print[ss, " 所有方案展示"]];
  22. Print[" ########################################## "];
  23. ]
复制代码


上面这样改动以后程序不能运行。不知应当如何改才行?

补充内容 (2021-7-8 12:03):
程序中第 2 行的 Array[a, 20]; 无用,应该去掉。

补充内容 (2021-7-9 08:54):
上面加入 While 循环语句后程序出错,问题是 While 循环内的所有语句后必须用分号才行。改正后的程序见下页。
毋因群疑而阻独见  毋任己意而废人言
毋私小惠而伤大体  毋借公论以快私情
 楼主| 发表于 2021-7-8 23:18:54 | 显示全部楼层
本帖最后由 TSC999 于 2021-7-9 09:11 编辑

下面是用改正错误后的程序进行计算,并与常新德公式计算结果对比。有时二者完全相同,但有时二者不一样,需要判定是哪个有错。例如下面的例子:

下面是四色珠子,黄色 1 颗、蓝色 1 颗、绿色 2 颗、红色 3 颗。手串共由这 7 颗珠子穿成。

按程序计算,共有 30 种花色如下图所示。但是按照常新德的公式计算,却有 31 种花色。问题来了,是公式错了还是程序错了?

4-1123的花色数.png

上图中有没有花色重复的? 有没有遗漏的?

下面是程序计算和常新德公式计算,程序代码放在一起了。
有个疑问,公式计算中,算出了有 2 个圆排列是对称的,结果就折算成了 1 个环排列。我咋看不出哪个环排列是对称的?

  1. Clear["Global`*"];   
  2. m = 4; n[1] = 1; n[2] = 1; n[3] = 2; n[4] = 3;
  3. Subscript[S, n] = \!\(
  4. \*UnderoverscriptBox[\(\[Sum]\), \(i = 1\), \(m\)]\(n[i]\)\);
  5. ss = {};     (* 所有的方案数列表 *)
  6. a = Permutations[{"黄", "蓝", "绿", "绿", "红", "红", "红"}, {Subscript[S,
  7.    n]}]; (* Subscript[S, n] 个有重复元素的全排列 *)
  8. L = Length[a];       (* 共有多少种线排列? *)
  9. k = 0;
  10. While[L > 0,
  11.   s = a[[1]];  (* 候选方案*)
  12.   ss = Append[ss, s];
  13.   s1 = Reverse[s];  (* 候选方案反排*)
  14.   Do[If[a[[i]] == s || a[[i]] == s1, a[[i]] = {}], {i, 2, L}]; (*
  15.   s 左移,s1右移之前,先筛一次 *)
  16.   Do[s = RotateLeft[s]; s1 = RotateRight[s1]; (* s 左移一位,并存到 s 中;
  17.    s1右移一位,并存到 s1 中*)
  18.    Do[If[a[[i]] == s || a[[i]] == s1, a[[i]] = {}], {i, 2, L}];
  19.    , {i, 1, Subscript[S, n] - 1}];     (*
  20.   s每左移一位、s1每右移一位,与其余的比较,若有一个是相同的,将那个其余清空。共筛 Subscript[S, n] 次 *)
  21.   a = DeleteCases[a, {}]; (* 去掉 a 中的所有空集 *)
  22.   a = Delete[a, 1];    (* 去掉 a 中的候选方案 a[[1]] 后的 a 列表 *)
  23.   L = Length[a];       (* 筛一轮后的 a 还有多少种线排列? *)
  24.   k = k + 1;
  25.   If[L == 0, Print[ss, " 所有花色方案展示,方案数 = ", k]];
  26.   ];
  27. (*以下是按常新德公式计算*)
  28. Q = Sum[EulerPhi[d] *(Subscript[S, n]/d)!/\!\(
  29. \*UnderoverscriptBox[\(\[Product]\), \(i = 1\), \(m\)]\(\((
  30. \*FractionBox[\(n[i]\), \(d\)])\)!\)\), {d,
  31.    Divisors[GCD[n[1], n[2], n[3], n[4]]]}]/Subscript[S, n](*圆排列数*)
  32. M = (\!\(
  33. \*UnderoverscriptBox[\(\[Sum]\), \(i = 1\), \(m\)]\(\[LeftFloor]
  34. \*FractionBox[\(n[i]\), \(2\)]\[RightFloor]\)\))!/\!\(
  35. \*UnderoverscriptBox[\(\[Product]\), \(i = 1\), \(m\)]\(\[LeftFloor]
  36. \*FractionBox[\(n[i]\), \(2\)]\[RightFloor]!\)\)(*圆排列中的对称排列数*)
  37. \[CapitalPhi] = (Q + M)/2(*环排列数*)

复制代码


上面程序运行结果是: 程序算出环排列数为 30,它们的具体排列方案见上图。常新德公式计算圆排列数为 Q = 60 种,其中对称排列的为  M = 2 种,所以环排列数  Φ =(Q+M)/2 = 31 种,比程序算的多了一种。

我看不出来存在 2 种对称的圆排列,如果有,它是什么模样的? 黄珠 1 颗、蓝珠 1 颗、绿珠 2 颗、红珠 3 颗。它们的圆排列咋能有对称的呢? 哪位网友发现有对称的,请告知一下。

补充内容 (2021-7-15 08:57):
最终发现程序没错,常新德公式也没错,错在我马虎了,没有认真看常新德老师的论文。各色珠子个数有奇有偶,若奇数个数大于 2 则 M=0,不存在对称圆排列,不用按公式计算了。当奇数个数是0、1、2 时才按公式计算。
毋因群疑而阻独见  毋任己意而废人言
毋私小惠而伤大体  毋借公论以快私情
 楼主| 发表于 2021-7-14 21:35:26 | 显示全部楼层
本帖最后由 TSC999 于 2021-7-15 09:13 编辑

今天这个帖子的问题可以彻底结束了。经编程试验知:

m = 4; n[1] = 1; n[2] = 1; n[3] = 1;  n[4] = 3  时,环排列数为 10 种,  公式算为 10.5 种。公式算的对称圆排列为 1个,实际应当是 0 个。
m = 4; n[1] = 1; n[2] = 1; n[3] = 2;  n[4] = 3  时,环排列数为 30 种, 公式算为 31 种。公式算的对称圆排列为 2个, 实际应当是 0 个。
m = 4; n[1] = 1; n[2] = 1; n[3] = 1;  n[4] = 2  时,环排列数为  6 种,  公式算为 6.5 种。公式算的对称圆排列为 1个, 实际应当是 0 个。
m = 4; n[1] = 1; n[2] = 3; n[3] = 3;  n[4] = 3  时,环排列数为 840 种, 公式算为 843 种。公式算的对称圆排列为 6个,实际应当是 0 个。
m = 3; n[1] = 1; n[2] = 1; n[3] = 3  时,环排列数为 2 种, 公式算为 2.5 种。公式算的对称圆排列为 1个,实际应当是 0 个。
m = 3; n[1] = 3; n[2] = 3; n[3] = 5  时,环排列数为 420 种, 公式算为 426 种。公式算的对称圆排列为 12个,实际应当是 0 个。
m = 3; n[1] = 1; n[2] = 1; n[3] = 1  时,环排列数为 1 种, 公式算为 1.5 种。公式算的对称圆排列为 1个,实际应当是 0 个。
m = 3; n[1] = 3; n[2] = 3; n[3] = 3  时,环排列数为 94 种, 公式算为 97 种。公式算的对称圆排列为 6个,实际应当是 0 个。
m = 5; n[1] = 1; n[2] = 1; n[3] = 1; n[4] = 2; n[5] = 2 时环排列数为 90 种, 公式算为 91 种。公式算的对称圆排列为 2个,实际应当是 0 个。
m = 5; n[1] = 1; n[2] = 1; n[3] = 1; n[4] = 2; n[5] = 3 时环排列数为 210 种, 公式算为 211 种。公式算的对称圆排列为 2个,实际应当是 0 个。
m = 5; n[1] = 1; n[2] = 1; n[3] = 2; n[4] = 2; n[5] = 3  时环排列数为 840 种, 公式算为 843 种。公式算的对称圆排列为 6个,实际应当是 0 个。
m = 5; n[1] = 1; n[2] = 1; n[3] = 1; n[4] = 2; n[5] = 2  时环排列数为 90 种, 公式算为 91 种。公式算的对称圆排列为 2个,实际应当是 0 个。

这就说明,当各种颜色的珠子个数有奇有偶,而奇数个数多于两个时,对称圆排列是没有的,即此时 M=0,此时环排列的数目等于圆排列数目的一半。

而当奇数个数为 0、1、2 时,M 不等于 0,其值需要按公式计算,此时环排列的数目等于圆排列数目的一半再加上 M 的一半。

再回头看看常新德老师的论文,才发现人家已经把这个问题说明白了,而且论证了为什么奇数个数多于两个时,对称圆排列是不存的。见下图:

奇数个数超过 2 个则对称圆排列数为零.png

这就对了,主帖提出的疑问是不存在的,常新德的公式是完全正确的。

为什么奇数个数多于两个时,对称圆排列不存在,见原著中的证明:

证明.png

折腾了好几天,最终证明是程序没有错,常新德公式也没有错。错在本人马虎了,没有认真阅读常新德老师的那篇论文。只是跑马观花地瞄了一眼。论文本身也有一点点小瑕疵,
如果多说一句话就好了——当奇数个数大于等于 3 时 M=0,此时按公式算出的 M 值不能用。小于等于 2 时才能按公式算 M。




毋因群疑而阻独见  毋任己意而废人言
毋私小惠而伤大体  毋借公论以快私情
 楼主| 发表于 2021-7-4 23:25:17 | 显示全部楼层
为什么《 数学研究》 网站现在发不了图片呢?我前不久还能发呢。如果是我的电脑有了问题,为什么我能在《 数学中国》 网站发图片,在《初等数学讨论》 网站也能发图片?

在这个网站发图片时,点击 “图片”,出不来 “选择图片” 的提示。但是以前可以。

点评

由360安全游览器换成了 360 急速游览器,能发图了。谢谢 gxqcn 站长!  发表于 2021-7-5 17:37
再换一款浏览器试试  发表于 2021-7-5 13:09
去掉右上角“纯文本” 的勾,也不行。右上角的 “常用” 改 “高级”,仍不行。  发表于 2021-7-5 08:24
请把右上角的“纯文本”勾选项取消,切换成“所见即所得模式”看看  发表于 2021-7-5 07:52
毋因群疑而阻独见  毋任己意而废人言
毋私小惠而伤大体  毋借公论以快私情
 楼主| 发表于 2021-7-5 09:01:43 | 显示全部楼层
本帖最后由 TSC999 于 2021-7-5 09:28 编辑

题目:黄、绿、红三种颜色的彩色珠子,黄珠 4 个,绿珠 4 个, 红珠 1 个。用它们穿成 9 个珠子的手串,有几种穿法?

从常新德老师的论文,按以下公式算出环排列数为 38。

圆排列数为 70,其中对称排列的有 6 个。

  1. Clear["Global`*"];  
  2. m = 3; n[1] = 4; n[2] = 4; n[3] = 1; Subscript[S, n] = \!\(
  3. \*UnderoverscriptBox[\(\[Sum]\), \(i = 1\), \(m\)]\(n[i]\)\);
  4. Q = Sum[EulerPhi[d] *(Subscript[S, n]/d)!/\!\(
  5. \*UnderoverscriptBox[\(\[Product]\), \(i = 1\), \(m\)]\(\((
  6. \*FractionBox[\(n[i]\), \(d\)])\)!\)\), {d,
  7.    Divisors[GCD[n[1], n[2], n[3]]]}]/Subscript[S, n](*圆排列数*)

  8. M = (\!\(
  9. \*UnderoverscriptBox[\(\[Sum]\), \(i = 1\), \(m\)]\(\[LeftFloor]
  10. \*FractionBox[\(n[i]\), \(2\)]\[RightFloor]\)\))!/\!\(
  11. \*UnderoverscriptBox[\(\[Product]\), \(i = 1\), \(m\)]\(\[LeftFloor]
  12. \*FractionBox[\(n[i]\), \(2\)]\[RightFloor]!\)\)(*圆排列中的对称排列数*)
  13. \[CapitalPhi] = (Q + M)/2(*环排列数*)
复制代码

补充内容 (2021-7-9 09:09):
程序计算结果也是 38 种,与常新德公式的计算结果完全相同。
毋因群疑而阻独见  毋任己意而废人言
毋私小惠而伤大体  毋借公论以快私情
 楼主| 发表于 2021-7-5 09:21:48 | 显示全部楼层
本帖最后由 TSC999 于 2021-7-5 09:35 编辑

如果上面的公式正确,计算结果也对。下面改一下参数: 仍是黄、绿、红三种颜色,黄珠 3 个,绿珠 1 个, 红珠 1 个。用它们穿成 5 个珠子的手串,有几种穿法?

仍用上面的程序,计算结果是 5/2 个。手工计算是  2 个。咋办? 是否最后那个公式应该改为取整?

为什么会出现这样的情况呢? 因为常新德论文的定理 6 中说,各种颜色的珠子数目,至多只能有两个奇数。现在是黄珠 3 个,绿珠 1 个, 红珠 1 个,三个都是奇数,所以就出了点问题。或者说这个定理 6 尚不够完善吧?

  1. Clear["Global`*"];  
  2. m = 3; n[1] = 3; n[2] = 1; n[3] = 1; Subscript[S, n] = \!\(
  3. \*UnderoverscriptBox[\(\[Sum]\), \(i = 1\), \(m\)]\(n[i]\)\);
  4. Q = Sum[EulerPhi[d] *(Subscript[S, n]/d)!/\!\(
  5. \*UnderoverscriptBox[\(\[Product]\), \(i = 1\), \(m\)]\(\((
  6. \*FractionBox[\(n[i]\), \(d\)])\)!\)\), {d,
  7.        Divisors[GCD[n[1], n[2], n[3]]]}]/Subscript[S, n](*圆排列数*)

  8. M = (\!\(
  9. \*UnderoverscriptBox[\(\[Sum]\), \(i = 1\), \(m\)]\(\[LeftFloor]
  10. \*FractionBox[\(n[i]\), \(2\)]\[RightFloor]\)\))!/\!\(
  11. \*UnderoverscriptBox[\(\[Product]\), \(i = 1\), \(m\)]\(\[LeftFloor]
  12. \*FractionBox[\(n[i]\), \(2\)]\[RightFloor]!\)\)(*圆排列中的对称排列数*)
  13. \[CapitalPhi] = (Q + M)/2      (*环排列数*)
复制代码


程序运行结果是  Q=4,   M=1,  Φ=(Q+M)/2=(4+1)/2=5/2。
毋因群疑而阻独见  毋任己意而废人言
毋私小惠而伤大体  毋借公论以快私情
 楼主| 发表于 2021-7-5 13:13:08 | 显示全部楼层
当 \( m=3,  n (i) =3, 5, 9 \) 时,结果也是分数 \( 80185/2 \)。 当 \( m=4,  n(i)=3, 1, 1, 1 \) 时,结果也是分数 \( 21/2 \)。例子太多了。
需要编写一个程序,计算环排列的准确值。以便修正常新德的公式。常老师后来好像与另外一个人合写了新的论文,不知道他在新论文中是否对自己原先的公式做了修正。

补充内容 (2021-7-9 09:20):
常新德老师另有一篇类似论文发在网上,是跟别人合著的,那人的名字还在常老师前面写着。我没看这篇,因为它收费。我并非没有钱付费看,凭什么看科技论文还要收费?如果收的钱给了作者还行,那我肯定愿意付费。
毋因群疑而阻独见  毋任己意而废人言
毋私小惠而伤大体  毋借公论以快私情
 楼主| 发表于 2021-7-5 17:33:58 | 显示全部楼层
本帖最后由 TSC999 于 2021-7-5 17:42 编辑

举一个例子,有 n = 8 颗珠子,珠子颜色 m = 2,比如黄色和红色。则按本帖题目内容,共有 30 种花色组合,

如果这 30 种组合细分,就需要按常新德的公式分别计算各种情况:

     8 黄是 1 种,8 红也是 1 种,共 2 种。
     7 黄 1 红是 1 种,1 黄 7 红也是 1 种,共 2 种。
     2 黄 6 红是 4 种,6 黄 2 红也是 4 种,共 8 种。
     3 黄 5 红是 5 种,5 黄 3 红也是 5 种,共 10 种。
     4  黄 4 红是 8 种。

所以共有 2 + 2 + 8 + 10 + 8 = 30 种。具体花色如下图:

2 色 8 珠的组合图案展示.png

换了一个游览器,原先是用 360 安全游览器,不知出了什么毛病,不能发图了。按照本站站长 gxqcn 的指导,换为 360 极速游览器,能发图了。谢谢 gxqcn 站长!

补充内容 (2021-7-9 09:22):
这一页是换了游览以后试试能不能发图。别无深意。
毋因群疑而阻独见  毋任己意而废人言
毋私小惠而伤大体  毋借公论以快私情
 楼主| 发表于 2021-7-7 23:35:45 | 显示全部楼层
本帖最后由 TSC999 于 2021-7-7 23:42 编辑

上面程序的编程思路见程序中的注释,这里补充说明一下。
由黄、绿、红、红、红这 5 个有重复的元素排成一条线,共有 20 种情况。可从中任选一种例如 “黄 绿 红 红 红” 作为一种手串花色方案的样本。可将它想像为下面的手串:

                                    黄
                               绿        红
                                  红  红
                                                      
   将其顺时针旋转一颗珠子,从最高点逆时针方向数就是 “绿 红 红 红 黄” 的线排列,从其余线排列中把这种排列划掉。再顺时针旋转一颗珠子,再与剩余线排列逐个比较,划掉相同者。如此旋转 4 次,比较 4 次,就能筛去一部分相同的圆排列。
把上述样本方案 “黄 绿 红 红 红” 反向排列成 “红 红 红 绿 黄”,与剩余线排列逐个比较一次,划掉相同者。然后再顺时针旋转 4 次并每次与剩余线排列比较,划掉相同者。如此筛选一轮,除去划掉的,就只剩下 10 个线排列了。
从这 10 个线排列中再随便抽取一个,进行又一轮同样的操作,如此进行下去,直到剩余的线排列全部消灭、一个不剩为止。此时那些抽取的样本的集合,就是花色组合数目了。

补充内容 (2021-7-9 09:26):
本页是对下页的编程思路作了一些说明。
毋因群疑而阻独见  毋任己意而废人言
毋私小惠而伤大体  毋借公论以快私情
 楼主| 发表于 2021-7-8 17:30:36 | 显示全部楼层
本帖最后由 TSC999 于 2021-7-8 19:38 编辑

问题解决了!While  循环中的每条语句结尾必须是分号。改后的程序如下:

  1. Clear["Global`*"];
  2. ss = {};     (* 所有的方案数列表 *)
  3. a = Permutations[{"黄", "绿", "红", "红",
  4.     "红"}, {5}]; (* 5个有重复元素的全排列,a 是个列表*)
  5. L = Length[a];       (* 共有多少种线排列? *)
  6. k = 0;
  7. While[L > 0,
  8.   s = a[[1]];  (* 候选方案*)
  9.   ss = Append[ss, s];
  10.   s1 = Reverse[s];  (* 候选方案反排*)
  11.   Do[If[a[[i]] == s || a[[i]] == s1, a[[i]] = {}], {i, 2, L}]; (*
  12.   s 左移,s1右移之前,先筛一次 *)
  13.   Do[s = RotateLeft[s]; s1 = RotateRight[s1]; (* s 左移一位,并存到 s 中;
  14.    s1右移一位,并存到 s1 中*)
  15.    Do[If[a[[i]] == s || a[[i]] == s1, a[[i]] = {}], {i, 2, L}];
  16.    , {i, 1, 4}];     (*
  17.   s每左移一位、s1每右移一位,与其余的比较,若有一个是相同的,将那个其余清空。共筛 4 次 *)
  18.   a = DeleteCases[a, {}]; (* 去掉 a 中的所有空集 *)
  19.   a = Delete[a, 1];    (* 去掉 a 中的候选方案 a[[1]] 后的 a 列表 *)
  20.   Print[a];
  21.   L = Length[a];       (* 筛一轮后的 a 还有多少种线排列? *)
  22.   Print["L= ", L];
  23.   If[L == 0, Print[ss, " 所有方案展示"]];
  24.   k = k + 1;
  25.   Print["以上为第 ", k, " 轮筛选结果。"];
  26.   Print[""];
  27.   ];
复制代码


运行结果是:

运行结果.png
毋因群疑而阻独见  毋任己意而废人言
毋私小惠而伤大体  毋借公论以快私情
 楼主| 发表于 2021-7-8 19:36:54 | 显示全部楼层
下面是 4 种颜色、每种颜色的珠子个数分别为 1、1、1、3, 手串珠子个数为 1+1+1+3 = 6 的花色方案数计算程序:

  1. Clear["Global`*"];   
  2. m = 4; n[1] = 1; n[2] = 1; n[3] = 1;
  3. n[4] = 3; (* m=4;n[1]=1;n[2]=1;n[3]=1;n[4]=3; 环排列数 \[CapitalPhi]=\
  4. \[LeftFloor]21/2\[RightFloor]=10 *)
  5. Subscript[S, n] = \!\(
  6. \*UnderoverscriptBox[\(\[Sum]\), \(i = 1\), \(m\)]\(n[i]\)\);
  7. ss = {};     (* 所有的方案数列表 *)
  8. a = Permutations[{"黄", "绿", "蓝", "红", "红", "红"}, {Subscript[S,
  9.    n]}]; (* Subscript[S, n] 个有重复元素的全排列,a 是个列表*)
  10. L = Length[a];       (* 共有多少种线排列? *)
  11. k = 0;
  12. While[L > 0,
  13.   s = a[[1]];  (* 候选方案*)
  14.   ss = Append[ss, s];
  15.   s1 = Reverse[s];  (* 候选方案反排*)
  16.   Do[If[a[[i]] == s || a[[i]] == s1, a[[i]] = {}], {i, 2, L}]; (*
  17.   s 左移,s1右移之前,先筛一次 *)
  18.   Do[s = RotateLeft[s]; s1 = RotateRight[s1]; (* s 左移一位,并存到 s 中;
  19.    s1右移一位,并存到 s1 中*)
  20.    Do[If[a[[i]] == s || a[[i]] == s1, a[[i]] = {}], {i, 2, L}];
  21.    , {i, 1, Subscript[S, n] - 1}];     (*
  22.   s每左移一位、s1每右移一位,与其余的比较,若有一个是相同的,将那个其余清空。共筛 Subscript[S, n] 次 *)
  23.   a = DeleteCases[a, {}]; (* 去掉 a 中的所有空集 *)
  24.   a = Delete[a, 1];    (* 去掉 a 中的候选方案 a[[1]] 后的 a 列表 *)
  25.   L = Length[a];       (* 筛一轮后的 a 还有多少种线排列? *)
  26.   k = k + 1;
  27.   If[L == 0, Print[ss, " 所有花色方案展示,方案数 = ", k]];
  28.   ];
复制代码


程序运行结果为:

4 色 6 珠.png

用常新德的公式计算结果是个分数  21/2,如果取整等于 10,与程序计算结果相同。
毋因群疑而阻独见  毋任己意而废人言
毋私小惠而伤大体  毋借公论以快私情
您需要登录后才可以回帖 登录 | 欢迎注册

本版积分规则

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

GMT+8, 2021-7-28 11:12 , Processed in 0.081265 second(s), 23 queries .

Powered by Discuz! X3.4

© 2001-2017 Comsenz Inc.

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