有黄绿红三种颜色的珠子各 4、4、1个。用它们穿成 9 颗珠子的手串，有多少种组合？

TSC999

有大小相同的珠子共 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 时程序与公式计算结果相同。但其它情况下有不一致的。

TSC999

为什么《 数学研究》 网站现在发不了图片呢？我前不久还能发呢。如果是我的电脑有了问题，为什么我能在《 数学中国》 网站发图片，在《初等数学讨论》 网站也能发图片？

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

TSC999

题目：黄、绿、红三种颜色的彩色珠子，黄珠 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. 
   
9. M = (\!\(
   
10. \*UnderoverscriptBox[\(\[Sum]\), \(i = 1\), \(m\)]\(\[LeftFloor]
    
11. \*FractionBox[\(n[i]\), \(2\)]\[RightFloor]\)\))!/\!\(
    
12. \*UnderoverscriptBox[\(\[Product]\), \(i = 1\), \(m\)]\(\[LeftFloor]
    
13. \*FractionBox[\(n[i]\), \(2\)]\[RightFloor]!\)\)(*圆排列中的对称排列数*)
    
14. \[CapitalPhi] = (Q + M)/2(*环排列数*)
    

复制代码

补充内容 (2021-7-9 09:09):
程序计算结果也是 38 种，与常新德公式的计算结果完全相同。

TSC999

如果上面的公式正确，计算结果也对。下面改一下参数： 仍是黄、绿、红三种颜色，黄珠 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. 
   
9. M = (\!\(
   
10. \*UnderoverscriptBox[\(\[Sum]\), \(i = 1\), \(m\)]\(\[LeftFloor]
    
11. \*FractionBox[\(n[i]\), \(2\)]\[RightFloor]\)\))!/\!\(
    
12. \*UnderoverscriptBox[\(\[Product]\), \(i = 1\), \(m\)]\(\[LeftFloor]
    
13. \*FractionBox[\(n[i]\), \(2\)]\[RightFloor]!\)\)(*圆排列中的对称排列数*)
    
14. \[CapitalPhi] = (Q + M)/2      (*环排列数*)

复制代码

程序运行结果是  Q=4,   M=1,  Φ=(Q+M)/2=(4+1)/2=5/2。

TSC999

当 \( m=3,  n (i) =3, 5, 9 \) 时，结果也是分数 \( 80185/2 \)。 当 \( m=4,  n(i)=3, 1, 1, 1 \) 时，结果也是分数 \( 21/2 \)。例子太多了。
需要编写一个程序，计算环排列的准确值。以便修正常新德的公式。常老师后来好像与另外一个人合写了新的论文，不知道他在新论文中是否对自己原先的公式做了修正。

补充内容 (2021-7-9 09:20):
常新德老师另有一篇类似论文发在网上，是跟别人合著的，那人的名字还在常老师前面写着。我没看这篇，因为它收费。我并非没有钱付费看，凭什么看科技论文还要收费？如果收的钱给了作者还行，那我肯定愿意付费。

TSC999

举一个例子，有 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 种。具体花色如下图：



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

补充内容 (2021-7-9 09:22):
这一页是换了游览以后试试能不能发图。别无深意。

TSC999

本帖目的在主帖中说了，是为了改进常新德老师（河南永城职业学院）大约在 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 种可能的花色，见下图。



程序调试成功后，可将颜色数目和各色珠子数量随意修改。目前程序尚未最终完成，但程序能给出正确的计算结果。程序如下：

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[" ########################################## "];

复制代码

上面这程序运行结果为：



上面程序尚存在毛病，因为有两段相邻程序是完全相同的，必须把它们放进一个 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 循环内的所有语句后必须用分号才行。改正后的程序见下页。

TSC999

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

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

补充内容 (2021-7-9 09:26):
本页是对下页的编程思路作了一些说明。

TSC999

问题解决了！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.   ];
    

复制代码

运行结果是：

TSC999

下面是 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.   ];
    

复制代码

程序运行结果为：



用常新德的公式计算结果是个分数  21/2，如果取整等于 10，与程序计算结果相同。