同じものを含む円順列と数珠順列

同じものを含む円順列は,｛a,a,b,b,c｝のようにある文字について１個しかない時は,その文字（この例ではc)(Subscript[を固定して考え , 4])(Subscript[C, 2])=6通りと求まるが，
{a,a,b,b,c,c}の様にどの文字についても2個以上の場合は　固定法が使えません．このような場合の円順列や数珠順列についてMathematicaを使って計算します．
なお「数え上げ」は1万通りを超えると時間がかかり，フリーズすることも有ります．（PCに依ります.)「場合の数」の場合は1万通りを越えても瞬時に求まります．
また「或る軸に関し対称な円順列」を略して「対称な円順列」と書いています．同じものを含む円順列の解説は例えばMouseOver ． じゅず順列に関しては私の書いた解説が (HyperlinkTemplate["ここ(mixedmoss)", https://mixedmoss.com/miscellaneous/juzuPermutations/juzuPermutations.pdf, https://mixedmoss.com/miscellaneous/juzuPermutations/juzuPermutations.pdf, HyperlinkActionRecycled, HyperlinkActive, , ]) にあります．　2023年7月 21日       by　生越　茂樹

§1.円順列(数え上げ)

Manipulate[
start1=MapThread[Table,{{a,b,c,d},{$n1,$n2,$n3,$n4}}]//Flatten;
If[start1≠{},
$enlist=circlePermutations[start1];
If[chyoji=="List",
$enlist//Append["\n"<>"円順列の個数 ="<>ToString[Length[$enlist]]],
show/@$enlist[[All,1]]
],
"円順列を求めます．上はa~dの個数です．\n合計で2個以上になる様に入力して下さい.\nなお「Graphics」にすると，出力が大きすぎる可能性があります．"],
{{$n1,0,a},0,7,1},{{$n2,0,b},0,7,1},{{$n3,0,c},0,7,1},{{$n4,0,d},0,7,1},{{chyoji,"List","出力"},{"List","Graphics "}},ControlType->Setter,
TrackedSymbols:>{$n1,$n2,$n3,$n4,chyoji},

Initialization:>(
ClearAll["Global`*"];
circlePermutations[x_List]:=Module[{left,n,list,grp},
left=Permutations[x];
n=Length[x];
list={};
While[left≠{},
grp=Union[Table[RotateLeft[First[left],k],{k,0,n-1}]];
left=Complement[left,grp];
AppendTo[list,grp];
];
{First[#],Length[#]}&/@list
];

juzuPermutations[x_List]:=Module[{left,n,jlist,grp,grp1,grp2},
left=Permutations[x];
n=Length[x];
jlist={};
While[left≠{},
grp1=Union[Table[RotateLeft[First[left],k],{k,0,n-1}]];
grp2=Union[Table[RotateLeft[Reverse[First[left]],k],{k,0,n-1}]];
grp=Union[grp1,grp2];
left=Complement[left,grp];
AppendTo[jlist,grp]
];
{First[#],Length[#]}&/@jlist
];

binomial[list_List]:=(Plus@@list)!/Times@@Factorial[list];
yakusu[n_]:=Select[Range[n],Divisible[n,#]&];

(*circleNOC0は引数が{2,3,1}のような数のリスト．circleNOCは引数が{a,a,b,b,b,c}のようなリスト.*)
circleNOC0[kosuu_]:=Module[{gcd,cd,factors,chofuku,unit,case,sets,cycles,cases,encases},
gcd=GCD@@kosuu;
cd=yakusu[gcd];
factors=Drop[Drop[yakusu[#],-1]&/@cd,1];(*cdの各要素の約数を書き下したもの*)
chofuku=Map[Position[cd,#][[1,1]]&,factors,{2}];(*cd={1,2,3,6},fukumu[{{1},{1,2},{3,6]]→{{1},{1,2},{3,4}}*)
unit=kosuu/gcd;(*{1,2,3}なら最小単位は{a,b,b,c,c,c}*)
sets=Times[unit,#]&/@cd;(*各周期は以下の順列{a,b,c},{a,a,b,b,c,c}...{a,...a,b,...b,c,...c}*)
cycles=Total/@sets;(*sets内の各要素の周期.　ここまで準備*)
(*ここから繰り返し*)
cases={binomial[sets[[1]]]};(*周期が最小の場合の順列の数*)
encases={cases[[1]]/cycles[[1]]};(*周期が最小の場合の円順列の数*)
For[i=2,i≤Length[sets],i++,
case=(binomial[sets[[i]]]-Total[Part[cases,chofuku[[i-1]]]]);
AppendTo[cases,case];
AppendTo[encases,case/cycles[[i]]];
];
MapThread[{#1,#2}&,{encases,cycles}]];

circleNOC[list_List]:=circleNOC0[Tally[list][[All,2]]];

juzuNOC[list_List]:=Module[{num,halfSide,numOfOdds,sym},
num=Tally[list][[All,2]];
halfSide=Floor[num/2];
numOfOdds=Total[Mod[num,2]];
sym=If[numOfOdds≥3,0,If[numOfOdds<=2,binomial[halfSide]]];
(Total[circleNOC0[num][[All,1]]]-sym)/2+sym
];

sym[list_List]:=Module[{c,j,pos},
c=circlePermutations[list];
j=juzuPermutations[list];
pos=Position[c,#]&/@j//Flatten;
Part[c,pos][[All,1]]];

symNOC[list_List]:=Module[{num,halfSide,numOfOdds},
num=Tally[list][[All,2]];
halfSide=Floor[num/2];
numOfOdds=Total[Mod[num,2]];
If[numOfOdds≥3,0,If[numOfOdds<=2,binomial[halfSide]]]
];


isType1[x_List]:=Module[{n,set},
n=Length[x];
If[EvenQ[n],
set=Table[RotateRight[x,k],{k,0,n/2-1}];
AnyTrue[Reverse[#]===#&/@set,TrueQ],
False]
];

isType2[x_List]:=Module[{n,set},
n=Length[x];
set=If[EvenQ[n],
Table[RotateLeft[x,k],{k,0,n/2-1}],
Table[RotateLeft[x,k],{k,0,n-1}]];
AnyTrue[Reverse[Drop[#,1]]===Drop[#,1]&/@set,TrueQ]
];

howmanyAxes1[x_List]:=Module[{n,set},
n=Length[x];
If[EvenQ[n],
set=Table[RotateRight[x,k],{k,0,n/2-1}];
Count[Reverse[#]===#&/@set,True],
0]
];

howmanyAxes2[x_List]:=Module[{n,set},
n=Length[x];
set=If[EvenQ[n],
Table[RotateLeft[x,k],{k,0,n/2-1}],
Table[RotateLeft[x,k],{k,0,n-1}]];
Count[Reverse[Drop[#,1]]===Drop[#,1]&/@set,True]
];

howmanyAxes[x_List]=howmanyAxes1[x]+howmanyAxes2[x];


findAxes1[x_List]:=Module[{n,set,pos,left,r},
n=Length[x];
If[EvenQ[n],
set=Table[RotateLeft[x,k],{k,0,n/2-1}];
pos=Position[Reverse[#]===#&/@set,True]//Flatten;
pos=pos-1;
r=1+1.2Sin[Pi/n];
left=r{Cos[-2(#-1/2) Pi/n-Pi/2],Sin[-2(#-1/2) Pi/n-Pi/2]}&/@pos;
MapThread[Line[{#1,#2}]&,{left,-left}],
{}]
];
findAxes2[x_List]:=Module[{n,left,set,pos,r},
n=Length[x];
set=If[EvenQ[n],
Table[RotateLeft[x,k],{k,0,n/2-1}],
Table[RotateLeft[x,k],{k,0,n-1}]];
pos=Position[Reverse[Drop[#,1]]===Drop[#,1]&/@set,True]//Flatten;
pos=pos-1;
r=1+1.2Sin[Pi/n];
left=r{Cos[-2# Pi/n-Pi/2],Sin[-2# Pi/n-Pi/2]}&/@pos;
MapThread[Line[{#1,#2}]&,{left,-left}]
];
findAxes[x_List]:=Union[findAxes1[x],findAxes2[x]];


$circlePoints[n_]:=Table[{Cos[-2k Pi/n-Pi/2],Sin[-2k Pi/n-Pi/2]},{k,0,n-1}];

show[x_List,size_:Large]:=Module[{n},
  n=Length[x];
  Graphics[MapThread[{Circle[#1,Sin[Pi/n]],Text[Style[ToString[#2],Bold,size],#1]}&,{$circlePoints[n],x}]]];

showAxes[x_List,size_:Large]:=Module[{n},
  n=Length[x];
  Graphics[MapThread[{Circle[#1,Sin[Pi/n]],Text[Style[ToString[#2],Bold,size],#1]}&,{$circlePoints[n],x}]
~Join~findAxes[x]
]];
)(*end of Initialize*)
]

§2.円順列(場合の数)

Manipulate[
start2=MapThread[Table,{{a,b,c,d},{n1,n2,n3,n4}}]//Flatten;
If[start2≠{},
$ccases=circleNOC[start2];
"円順列の総数は"<> ToString[Total[$ccases[[All,1]]]]<>". 周期別には"<> ToString[$ccases],
"円順列の「個数」を求めます．上はa~dの個数です．\n合計で2個以上になる様に入力して下さい"(*引数が空集合の時*)],
{{n1,0,a},0,7,1},{{n2,0,b},0,7,1},{{n3,0,c},0,7,1},{{n4,0,d},0,7,1},ControlType->Setter,
TrackedSymbols:>{n1,n2,n3,n4}
]

§3.数珠順列(数え上げ)

Manipulate[
start3=MapThread[Table,{{a,b,c,d},{j1,j2,j3,j4}}]//Flatten;
If[start3≠{},
$juzulist=juzuPermutations[start3];
If[jhyoji=="List",
$juzulist//Append["\n"<>"数珠順列の個数 ="<>ToString[Length[$juzulist]]],
show/@$juzulist[[All,1]]],
"数珠順列を求めます．上はa~dの個数です．\n合計で2個以上になる様に入力して下さい.\nなお「Graphics」にすると，出力が大きすぎる可能性があります．"],
{{j1,0,a},0,7,1},{{j2,0,b},0,7,1},{{j3,0,c},0,7,1},{{j4,0,d},0,7,1},{{jhyoji,"List","出力"},{"List","Graphics "}},ControlType->
Setter,
TrackedSymbols:>{j1,j2,j3,j4,jhyoji}]

§4.数珠順列(場合の数)

Manipulate[
start4=MapThread[Table,{{a,b,c,d},{$j1,$j2,$j3,$j4}}]//Flatten;
If[start4≠{},
$jcases=juzuNOC[start4];
"数珠順列の「個数」は"<>ToString[$jcases]<>"です",
"数珠順列の「個数」を求めます．上はa~dの個数です．\n合計で2個以上になる様に入力して下さい"
],
{{$j1,0,a},0,7,1},{{$j2,0,b},0,7,1},{{$j3,0,c},0,7,1},{{$j4,0,d},0,7,1},ControlType->Setter,
TrackedSymbols:>{$j1,$j2,$j3,$j4}]

§5.対称な円順列(数え上げ)

Manipulate[
start5=MapThread[Table,{{a,b,c,d},{s1,s2,s3,s4}}]//Flatten;
If[start5≠{},
$sym=sym[start5];
If[hyoji=="List",
"ある軸に関し対称な円順列は次の"<>ToString[Length[$sym]]<>"通りです\n"<>ToString[$sym],
showAxes/@$sym],
"ある軸に関し対称な円順列を数え上げます．上はa~dの個数です．\n合計で2個以上になる様に入力して下さい.\nなお「Graphics」にすると，出力が大きすぎる可能性があります．"],
{{s1,0,a},0,7,1},{{s2,0,b},0,7,1},{{s3,0,c},0,7,1},{{s4,0,d},0,7,1},{{hyoji,"List","出力"},{"List","Graphics "}},ControlType->
Setter,
TrackedSymbols:>{s1,s2,s3,s4,hyoji}]

§6.対称な円順列(場合の数)

Manipulate[
start5=MapThread[Table,{{a,b,c,d},{s1,s2,s3,s4}}]//Flatten;
If[start5≠{},
$symcases=symNOC[start5];
"ある軸に関し対称な円順列の「個数」は"<>ToString[$symcases]<>"です",
"ある軸に関し対称な円順列の「個数」を求めます．上はa~dの個数です．\n合計で2個以上になる様に入力して下さい"],
{{s1,0,a},0,7,1},{{s2,0,b},0,7,1},{{s3,0,c},0,7,1},{{s4,0,d},0,7,1},ControlType->Setter,
TrackedSymbols:>{s1,s2,s3,s4}]

§7.プログラムについて

プログラムは以下の3種類に分かれています.

円順列，数珠順列のプログラム : circlePermutations, juzuPermutations, circleNOC, juzuNOC, 
或る軸に関して対称な円順列のプログラム: sym, symNOC, isType1/2,  howmanyAxes1/2, howmanyAxes
円順列の表示のプログラム: show, showAxes

例えば，circlePermutations[{a,a,b,b,c}] や juzuPermutations[{a,a,b,b,c}] で，a2個,b2個,c1個の円順列や数珠順列が得られる．

出力は円順列/数珠順列の代表と重複度（順列に対する重複度）．それぞれの場合の数もプリント．

重複度は周期と言い換えても良い

全ての円順列/数珠順列を書き出すので，場合の数が1万を超えると計算に時間がかかる

circleNOC[{a,a,b,b,c}]やjuzuNOC[{a,a,b,b,c}]  で，a2個,b2個,c1個の円順列や数珠順列の「場合の数」が得られる．(NOC=NumberOfCases)

場合の数が1万を超えていても計算は瞬間にできる．

sym[{a, a, b, b, c}] で，a2個,b2個,c1個 の円順列のうち，或る軸に関して対称な円順列を数え上げる．symNOCは場合の数．

isType1[list],isType2[list]で，list で表される円順列が TypIeI，TypeII の対称性を持つかチェックする．

TypeIの軸は玉の間を通る．TypeIIの軸は玉を通る．

howmanyAxes1/2 は　それぞれ　Type1, Type2 のタイプの対称軸の本数を, howmanyAxesはその合計を求める．

show[list] は，１つの順列を6時の位置から時計回りに表示する. 対称軸も表示するときは showAxes を使う.

2つ以上の順列の表示はMapあるいは/@を使用

文字a,b,c...のサイズはshow[list,Medium]のように変更可能.

DefaultのサイズはLarge．他にTiny,Small あるいは数字による指定も可能

プログラムは，§1のManipulateの Initialization の中に入っています．(セルを開けて下さい)

プログラムに間違いがあれば　MouseOver　を頂けると幸いです．

例. a4個, b4個の円順列と数珠順列，或る軸に関して対称な円順列

(*）以下の例については　私の解説PDF（リンク先は前書き参照)も御覧ください.

円順列

circ=circlePermutations[{a,a,a,a,b,b,b,b}]

circCases=circleNOC[{a,a,a,a,b,b,b,b}]

Total[circCases[[All,1]]](*= Length[circ]*)

show/@circ[[All,1]]

数珠順列

juzu=juzuPermutations[{a,a,a,a,b,b,b,b}]

juzuCases=juzuNOC[{a,a,a,a,b,b,b,b}](*= Length[juzu]*)

show/@juzu[[All,1]]

或る軸に関して対称な円順列.

symmetric=sym[{a,a,a,a,b,b,b,b}]
symCases=symNOC[{a,a,a,a,b,b,b,b}]
type1=Select[symmetric,isType1]
type2=Select[symmetric,isType2]
showAxes/@type1
showAxes/@type2

上の円順列の対称軸の本数は以下の様になります．

howmanyAxes/@type1

howmanyAxes/@type2