有黄绿红三种颜色的珠子各 4、4、1个。用它们穿成 9 颗珠子的手串，有多少种组合？
有大小相同的珠子共 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 于 2021-7-5 09:28 编辑
题目：黄、绿、红三种颜色的彩色珠子，黄珠 4 个，绿珠 4 个， 红珠 1 个。用它们穿成 9 个珠子的手串，有几种穿法？
从常新德老师的论文，按以下公式算出环排列数为 38。
圆排列数为 70，其中对称排列的有 6 个。
Clear["Global`*"];
m = 3; n = 4; n = 4; n = 1; Subscript = \!\(
\*UnderoverscriptBox[\(\\), \(i = 1\), \(m\)]\(n\)\);
Q = Sum *(Subscript/d)!/\!\(
\*UnderoverscriptBox[\(\\), \(i = 1\), \(m\)]\(\((
\*FractionBox[\(n\), \(d\)])\)!\)\), {d,
Divisors, n, n]]}]/Subscript(*圆排列数*)
M = (\!\(
\*UnderoverscriptBox[\(\\), \(i = 1\), \(m\)]\(\
\*FractionBox[\(n\), \(2\)]\\)\))!/\!\(
\*UnderoverscriptBox[\(\\), \(i = 1\), \(m\)]\(\
\*FractionBox[\(n\), \(2\)]\!\)\)(*圆排列中的对称排列数*)
\ = (Q + M)/2(*环排列数*)
补充内容 (2021-7-9 09:09):
程序计算结果也是 38 种，与常新德公式的计算结果完全相同。 本帖最后由 TSC999 于 2021-7-5 09:35 编辑
如果上面的公式正确，计算结果也对。下面改一下参数： 仍是黄、绿、红三种颜色，黄珠 3 个，绿珠 1 个， 红珠 1 个。用它们穿成 5 个珠子的手串，有几种穿法？
仍用上面的程序，计算结果是 5/2 个。手工计算是2 个。咋办？ 是否最后那个公式应该改为取整？
为什么会出现这样的情况呢？ 因为常新德论文的定理 6 中说，各种颜色的珠子数目，至多只能有两个奇数。现在是黄珠 3 个，绿珠 1 个， 红珠 1 个，三个都是奇数，所以就出了点问题。或者说这个定理 6 尚不够完善吧？
Clear["Global`*"];
m = 3; n = 3; n = 1; n = 1; Subscript = \!\(
\*UnderoverscriptBox[\(\\), \(i = 1\), \(m\)]\(n\)\);
Q = Sum *(Subscript/d)!/\!\(
\*UnderoverscriptBox[\(\\), \(i = 1\), \(m\)]\(\((
\*FractionBox[\(n\), \(d\)])\)!\)\), {d,
Divisors, n, n]]}]/Subscript(*圆排列数*)
M = (\!\(
\*UnderoverscriptBox[\(\\), \(i = 1\), \(m\)]\(\
\*FractionBox[\(n\), \(2\)]\\)\))!/\!\(
\*UnderoverscriptBox[\(\\), \(i = 1\), \(m\)]\(\
\*FractionBox[\(n\), \(2\)]\!\)\)(*圆排列中的对称排列数*)
\ = (Q + M)/2 (*环排列数*)
程序运行结果是Q=4, M=1,Φ=(Q+M)/2=(4+1)/2=5/2。 当 \( 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 于 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 种。具体花色如下图：
换了一个游览器，原先是用 360 安全游览器，不知出了什么毛病，不能发图了。按照本站站长 gxqcn 的指导，换为 360 极速游览器，能发图了。谢谢 gxqcn 站长！
补充内容 (2021-7-9 09:22):
这一页是换了游览以后试试能不能发图。别无深意。 本帖最后由 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 种可能的花色，见下图。
程序调试成功后，可将颜色数目和各色珠子数量随意修改。目前程序尚未最终完成，但程序能给出正确的计算结果。程序如下：
Clear["Global`*"];
Array;
ss = {}; (* 所有的方案数列表 *)
a = Permutations[{"黄", "绿", "红", "红",
"红"}, {5}]; (* 5个有重复元素的全排列，a 是个列表*)
L = Length; (* 共有多少种线排列？ *)
(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
s = a[];(* 候选方案*)
ss = Append;
s1 = Reverse;(* 候选方案反排*)
Do] == s || a[] == s1, a[] = {}], {i, 2,
L}]; (* s 左移，s1右移之前，先筛一次 *)
Do;
s1 = RotateRight; (* s 左移一位，并存到 s 中; s1右移一位，并存到 s1 中*)
Do] == s || a[] == s1, a[] = {}], {i, 2, L}];
, {i, 1,
4}]; (* s每左移一位、s1每右移一位，与其余的比较，若有一个是相同的，将那个其余清空。共筛 4 次 *)
a = DeleteCases; (* 去掉 a 中的所有空集 *)
a = Delete (* 去掉 a 中的候选方案 a[] 后的 a 列表 *)
L = Length (* 筛一轮后的 a 还有多少种线排列？ *)
If];
Print[" ########################################## "];
s = a[];(* 候选方案*)
ss = Append;
s1 = Reverse;(* 候选方案反排*)
Do] == s || a[] == s1, a[] = {}], {i, 2,
L}]; (* s 左移，s1右移之前，先筛一次 *)
Do;
s1 = RotateRight; (* s 左移一位，并存到 s 中; s1右移一位，并存到 s1 中*)
Do] == s || a[] == s1, a[] = {}], {i, 2, L}];
, {i, 1,
4}]; (* s每左移一位、s1每右移一位，与其余的比较，若有一个是相同的，将那个其余清空。共筛 4 次 *)
a = DeleteCases; (* 去掉 a 中的所有空集 *)
a = Delete (* 去掉 a 中的候选方案 a[] 后的 a 列表 *)
L = Length (* 筛一轮后的 a 还有多少种线排列？ *)
If];
Print[" ########################################## "];
上面这程序运行结果为：
上面程序尚存在毛病，因为有两段相邻程序是完全相同的，必须把它们放进一个 While 循环语句中去以控制循环次数才行。试改如下：
Clear["Global`*"];
Array;
ss = {}; (* 所有的方案数列表 *)
a = Permutations[{"黄", "绿", "红", "红",
"红"}, {5}]; (* 5个有重复元素的全排列，a 是个列表*)
L = Length; (* 共有多少种线排列？ *)
(* %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% *)
While[L > 0,
s = a[];(* 候选方案*)
ss = Append;
s1 = Reverse;(* 候选方案反排*)
Do] == s || a[] == s1, a[] = {}], {i, 2,
L}]; (* s 左移，s1右移之前，先筛一次 *)
Do; s1 = RotateRight; (* s 左移一位，并存到 s 中;
s1右移一位，并存到 s1 中*)
Do] == s || a[] == s1, a[] = {}], {i, 2, L}];
, {i, 1, 4}]; (* s每左移一位、s1每右移一位，与其余的比较，若有一个是相同的，将那个其余清空。共筛 4 次 *)
a = DeleteCases; (* 去掉 a 中的所有空集 *)
a = Delete (* 去掉 a 中的候选方案 a[] 后的 a 列表 *)
L = Length (* 筛一轮后的 a 还有多少种线排列？ *)
If];
Print[" ########################################## "];
]
上面这样改动以后程序不能运行。不知应当如何改才行？
补充内容 (2021-7-8 12:03):
程序中第 2 行的 Array; 无用，应该去掉。
补充内容 (2021-7-9 08:54):
上面加入 While 循环语句后程序出错，问题是 While 循环内的所有语句后必须用分号才行。改正后的程序见下页。 本帖最后由 TSC999 于 2021-7-7 23:42 编辑
上面程序的编程思路见程序中的注释，这里补充说明一下。
由黄、绿、红、红、红这 5 个有重复的元素排成一条线，共有 20 种情况。可从中任选一种例如 “黄 绿 红 红 红” 作为一种手串花色方案的样本。可将它想像为下面的手串：
黄
绿 红
红红
将其顺时针旋转一颗珠子，从最高点逆时针方向数就是 “绿 红 红 红 黄” 的线排列，从其余线排列中把这种排列划掉。再顺时针旋转一颗珠子，再与剩余线排列逐个比较，划掉相同者。如此旋转 4 次，比较 4 次，就能筛去一部分相同的圆排列。
把上述样本方案 “黄 绿 红 红 红” 反向排列成 “红 红 红 绿 黄”，与剩余线排列逐个比较一次，划掉相同者。然后再顺时针旋转 4 次并每次与剩余线排列比较，划掉相同者。如此筛选一轮，除去划掉的，就只剩下 10 个线排列了。
从这 10 个线排列中再随便抽取一个，进行又一轮同样的操作，如此进行下去，直到剩余的线排列全部消灭、一个不剩为止。此时那些抽取的样本的集合，就是花色组合数目了。
补充内容 (2021-7-9 09:26):
本页是对下页的编程思路作了一些说明。 本帖最后由 TSC999 于 2021-7-8 19:38 编辑
问题解决了！While循环中的每条语句结尾必须是分号。改后的程序如下：
Clear["Global`*"];
ss = {}; (* 所有的方案数列表 *)
a = Permutations[{"黄", "绿", "红", "红",
"红"}, {5}]; (* 5个有重复元素的全排列，a 是个列表*)
L = Length; (* 共有多少种线排列？ *)
k = 0;
While[L > 0,
s = a[];(* 候选方案*)
ss = Append;
s1 = Reverse;(* 候选方案反排*)
Do] == s || a[] == s1, a[] = {}], {i, 2, L}]; (*
s 左移，s1右移之前，先筛一次 *)
Do; s1 = RotateRight; (* s 左移一位，并存到 s 中;
s1右移一位，并存到 s1 中*)
Do] == s || a[] == s1, a[] = {}], {i, 2, L}];
, {i, 1, 4}]; (*
s每左移一位、s1每右移一位，与其余的比较，若有一个是相同的，将那个其余清空。共筛 4 次 *)
a = DeleteCases; (* 去掉 a 中的所有空集 *)
a = Delete; (* 去掉 a 中的候选方案 a[] 后的 a 列表 *)
Print;
L = Length; (* 筛一轮后的 a 还有多少种线排列？ *)
Print["L= ", L];
If];
k = k + 1;
Print["以上为第 ", k, " 轮筛选结果。"];
Print[""];
];
运行结果是：
下面是 4 种颜色、每种颜色的珠子个数分别为 1、1、1、3， 手串珠子个数为 1+1+1+3 = 6 的花色方案数计算程序：
Clear["Global`*"];
m = 4; n = 1; n = 1; n = 1;
n = 3; (* m=4;n=1;n=1;n=1;n=3; 环排列数 \=\
\21/2\=10 *)
Subscript = \!\(
\*UnderoverscriptBox[\(\\), \(i = 1\), \(m\)]\(n\)\);
ss = {}; (* 所有的方案数列表 *)
a = Permutations[{"黄", "绿", "蓝", "红", "红", "红"}, {Subscript[S,
n]}]; (* Subscript 个有重复元素的全排列，a 是个列表*)
L = Length; (* 共有多少种线排列？ *)
k = 0;
While[L > 0,
s = a[];(* 候选方案*)
ss = Append;
s1 = Reverse;(* 候选方案反排*)
Do] == s || a[] == s1, a[] = {}], {i, 2, L}]; (*
s 左移，s1右移之前，先筛一次 *)
Do; s1 = RotateRight; (* s 左移一位，并存到 s 中;
s1右移一位，并存到 s1 中*)
Do] == s || a[] == s1, a[] = {}], {i, 2, L}];
, {i, 1, Subscript - 1}]; (*
s每左移一位、s1每右移一位，与其余的比较，若有一个是相同的，将那个其余清空。共筛 Subscript 次 *)
a = DeleteCases; (* 去掉 a 中的所有空集 *)
a = Delete; (* 去掉 a 中的候选方案 a[] 后的 a 列表 *)
L = Length; (* 筛一轮后的 a 还有多少种线排列？ *)
k = k + 1;
If];
];
程序运行结果为：
用常新德的公式计算结果是个分数21/2，如果取整等于 10，与程序计算结果相同。
页:
[1]
2