目录
http://reference.wolfram.com/language/Combinatorica/tutorial/Combinatorica.html
Mathematica的Combinatorica`是官方提供的用于处理组合数学问题的一个程序包。涉及到的主题包括但不限于:分拆,图论等等。
分拆可以看我的这篇文章
在线的Combinatorica`程序包文档可以看这个
在线的Combinatorica/guide/PartitionsAndCompositions可以看这个
这里使用Mathematica 12.0进行演示
Needs[ "Combinatorica`"]
如果报Warning了不管它,可以继续使用
之后可以?Combinatorica`*
查看包里的内容及用法
下面混用程序包里的函数和mma12.0自带的函数进行演示
全部方案
Partitions[5](*全部方案*)
IntegerPartitions[5](*全部方案,和上面的几乎一样*)
和数被限制
Partitions[5, 3](*和数最大是3,逆字典序陈列出来*)
IntegerPartitions[10, All, {2, 3, 4}](*和数只能是2,3,4*)
和数数目被限制
IntegerPartitions[5, 3](*最多3部分*)
IntegerPartitions[5, {3}](*刚好3部分*)
IntegerPartitions[5, {2, 4}](*最少2部分,最多4部分*)
Flatten[Table[IntegerPartitions[10, {k}] , {k, {2, 4}}], 1] (*和数个数只能是2,4*)
由一种Partition方案绘制FerrersDiagram
FerrersDiagram[Partitions[10] [[18]]] (*参数换成 {5, 2, 1, 1, 1} 也行*)
FerrersDiagram的转置
FerrersDiagram@TransposePartition[Partitions[10][[18]]]
Ferrers图按照规则填上合适的数就成为了YoungTableau(这里的Tableau是转置过的,不知道怎么转过来)
TableForm[Tableaux[{3, 1}], TableAlignments -> {Right, Top}]
全部方案
IntegerCompositions[n_] :=
Flatten[Table[
ConstantArray[1, k] + # & /@ Compositions[n - k, k], {k, 1, n}],
1] (*全部方案,基于对和数可为0的Composition改造得到*)
IntegerCompositions[n_] :=
Flatten[Table[Permutations[Partitions[n][[k]]], {k, 1, len}],
1] /. {len -> Length@Partitions[n]}
(*全部方案,由Partition的排列生成*)
和数受限制
len = Length@Partitions[5, 3];
Flatten[ Table[Permutations[Partitions[5, 3][[k]]], {k, 1, len}] , 1]
(*和数最大是3*)
len = Length@IntegerPartitions[10, All, {2, 3, 4}];
Flatten[Table[
Permutations[IntegerPartitions[10, All, {2, 3, 4}][[k]]], {k, 1,
len}], 1]
(*和数只能是2,3,4*)
和数数目受限制
IntegerCompositions[n_, k_] :=
ConstantArray[1, 3] + # & /@ Compositions[n - k, k](*正好3部分,和数都是正整数*)
NumberOfCompositions[10, 3](*正好3部分的方案数目*)
Length@Compositions[10, 3](*正好3部分的方案数目,和上面几乎一样*)
Flatten[Table[Compositions[10, k], {k, 1, 5}], 1] (*最多5部分的全部方案,这个我没找到现成的函数*)
Flatten[Table[Compositions[10, k], {k, {2, 3, 5}}], 1] (*和数个数只能是2,3,5的全部方案,这个我没找到现成的函数*)
和数数目受限制而且和数大小受限制
(*n的k个和数且和数在[1,r]的Compostition的方案个数*)
nCompokSummandsEachRange1r[n_, k_, r_] :=
Module[{sum = 0}, If[r <= 0 || k <= 0, 0,
Sum[(-1)^j*Binomial[k, j]*Binomial[n - r*j - 1, k - 1], {j, 0,
Min[k, Floor[(n - k)/r]]}]
]
]
准确的说,是partitions of a set of n distinguishable elements
中文的话?集合分拆?
虽然但是,我真的很想写这个,
会涉及到第二类斯特林数,Bell数
(*set partition*)
SetPartitions[{a, b, c}] (*无限制*)
RGFToSetPartition[#] & /@ RGFs[5] (*基于RGF生成,和上面给出的结果一致,顺序可能不同*)
SetPartitionListViaRGF[5] (*和上面的完全一样,又封装了一遍*)
KSetPartitions[3, 2] (*表示{1,2,3}集合分拆,限定为2部分*)
KSetPartitions[{a,b,c}, 2] (*限定为2部分*)
数学一点的话,当然要谈到RGF和SetPartitions的bijection
图片来自这篇论文 https://arxiv.org/pdf/1605.04807.pdf
或者你看东田纳西州立大学的这个slide
映射关系如下,这是一个bijection
(*RGF相关*)
RGFs[5] (*给出所有长度为5的RGF序列*),
SetPartitionToRGF[#] & /@ SetPartitions[5] (*基于sp生成,和上面给出的结果一致,顺序可能不同*)
RandomRGF[5] (*相当于从上面的结果里随机选一个*)
RGFToSetPartition[{1, 2, 1, 2, 1}, {a, b, c, d, e}] (*RGF到SetPartition的映射*)
RGFToSetPartition[{1, 2, 1, 2, 1}] (*第二个参数缺省的话会进行联想[n]*)
RGFToSetPartition[{1, 2, 1, 2, 1},{a,b}] (*非法输入不会计算结果*)
(*有rank的函数基本上不用看了,你会写[[]]的话*)
RankSetPartition[#] & /@ SetPartitions[4] (*这个结果是Range[0, 14]*)
sp也可以理解成一个SYT吗?
SYT的定义看这里
给自己挖坑,有空会来填的
无符号拉赫数(也是无符号第三类斯特林数)计算的是将含有\(n\)个元素的集合拆分为\(k\)个非空线性有序子集的方法数目。
SetPartitions[3]
Table[Map[Permutations, %6[[i]]] // Tuples, {i, 1, Length@%6}] // MatrixForm
(*或者这么写?*)
SetPartitionsToSequences[n_]:=Table[Map[Permutations, SetPartitions[n][[i]]] // Tuples, {i, 1, BellB[n]}] // MatrixForm
这个我也不知道该分到哪一类去,,,和SetPartition和Permutation都有点关系
无符号第一类斯特林数计算的是将含有\(n\)个元素的集合拆分为\(k\)个非空圆排列的方法数目。
ToCycles[#] & /@ Permutations[5] // MatrixForm (*基于Permutation圆分解生成全部方案*)
Select[ToCycles[#] & /@ Permutations[5], Length[#] == 2 &] (*S1(5,2)的全部方案*)
这个坑开了就写不完的啊,我拒绝记录
ShowGraph /@ % (*当你生成了List<Graph>的东西,想要可视化*)
可以看我的排列研究系列文章
这个感觉也写不完
ToCycles[{2, 1, 3}] (*对一个排列做圆分解*)
FromCycles@% (*由圆分解得到一个排列*)
ToInversionVector[{5, 2, 3, 4, 1}]
## 结果是{4, 1, 1, 1},表明有1左侧有4个数比1大,4左侧有有1个数比4大...
InversePermutation[{2, 3, 1, 4}] (*对Permutation做Inverse(圆分解后每个圆反转)*)
Involutions[5] (*Involution是说inverse(圆分解后每个圆反转)和自己相同的那些Permutation*)
upd 2021-03-30 完成初稿
upd 2021-04-03 以后求Composition或者Partition的全部解还是FrobeniusSolve 吧,人生苦短
note 2021-04-08 发现Combinatorica包的Compositions[n, k]函数会把和数为0的情况给了出来,于是选择了其他方法来实现无限制的Compostions
note 2021-06-26 发现有些东西比如生成组合,生成排列,生成笛卡尔积经常用到,我放在最后了
note 2021-11-08
吐个槽,mma重复造轮子是出了名的
另一个有意思的点是,你可以试着输入NumberOf,看会联想出来哪些东西
upd 2021-11-08 想写的东西过多,甚至题目改成了 Mathematica的Combinatorica`程序包使用笔记
FoldList[Plus, 0, {a, b, c, d}] (*前缀和*)
Total[MapIndexed[#1 x^First[#2] &, {a, b, c, d, e}]] (*系数列表转多项式*)
MapIndexed[Labeled, {x^2, x + y, y^2, y^3}] (*相当于zipWithIndex*)
z^3/(1 - z^2) // Apart (*Apart把一个有理表达式改写成具有最小分母的项的和. *)
z^3/(1 - z^2) // Apart // Together (*Together将各项合并公分母,并消去结果中的因子.Together和Apart互为逆运算*)
(*Horner多项式形式*)
Fold[x #1 + #2 &, 0, {a, b, c, d, e}] (*创建一个嵌套的Horner多项式形式*)
HornerForm[Reverse[{a, b, c, d, e}].x^Range[0, 4], x]
Fold[1/(#2 + #1) &, x, Reverse[{a, b, c, d}]] (*形成连分式*)
(*数码列表转10进制数*)
StringJoin[ToString@# & /@ {1, 2, 3, 4}] // ToExpression
Fold[10 #1 + #2 &, 0, {4, 5, 1, 6, 7, 8}]
Fold[#2 - #1 &, 0, Reverse[{a, b, c, d, e}]] (*形成一个交错总和*)
Fold[#2[#1] &, x, {a, b, c, d}] (*对x做a映射后,结果做b映射,结果做c映射,结果做d映射*)
PermutationProduct[I] (*你们要的恒等函数*)
Map[#^2 &, {1, 2, 3}] (*Map操作几乎必会好吧*)
{0, 1, 2, 3} // Map[#^2 + 1 &, #] &
func[x_] := If[ListQ[x], x, "a" <> ToString[x] <> "b"];Map[func[#] &, {{1, fa}, {1, fa, "cd"}, 1, "fs"}]
(*Map操作几乎必会好吧*)
Table[RotateLeft[{2, 3, 4, 5}, -n], {n, 0, 3}] (*生成一个List的Rotate变换后的序列*)
Subsets[{1, 2, 2}] (*生成幂集*)
Permutations[{a, b, c, d}, {2}](*生成排列*)
Select[Permutations[{a, b, c, d}], Signature[#] == 1 &] (*生成逆序对数为偶的所有排列,4!/2=12个*)
Flatten[Outer[List, {a, b}, {x, y, z}, {1, 2, 3}], 2](*生成全部笛卡尔积*)
Tuples[{{a, b}, {1, 2, 3, 4}, {x}}] (*生成全部笛卡尔积*)
Tuples[{0, 1}, 3] (*生成全部的01三元组*)
Subsets[{a, a, b, b}, {2}](*生成大小为2的全部子集,共6个*)
Subsets[{a, a, b, b}, {2}] // Union (*生成本质不同(规则是放在置换群下是否相同)的子集,共3个。i.e.可重复元素的组合*)
Boole[Outer[Greater, {1, 2, 3, 4, 5}, {1, 2, 3, 4, 5}]] // MatrixForm (*生成5\times 5的下三角矩阵*)
MatrixForm[m = Array[Subscript[a, ##] &, {3, 3}]] (*优雅地写一个形式3*3矩阵*)
jordanMatrix[\[Lambda]_, n_] := DiagonalMatrix[Table[\[Lambda], {n}]] + DiagonalMatrix[Table[1, {n - 1}], 1](*优雅地写一个Jordan矩阵*)
Join @@ Table[#*n & /@ ConstantArray[1, 4], {n, 1, 13}](*生成52张牌的deck,无花色*)
Flatten[Outer[List, {"spade", "heart", "diamond", "club"}, Range[1, 10]], 1] (*生成40张牌的deck,有花色*)
Select[Subsets[Range[1, 10], {3}], Mod[Total[#], 10] == 0 &] (*1~10里选3张牌和的个位是0的本质不同的全部组合方案*)
Sort[{{a, 2}, {c, 1}, {d, 3}}, #1[[2]] < #2[[2]] &] (*比较每个元素的第二部分,以进行排序*)
ReverseSort[{{a, 2}, {c, 1}, {d, 3}}, #1[[2]] < #2[[2]] &] (*逆向排序的一种思路是直接改函数名为ReverseSort*)
Cases[{{3, 2, 1}, {1, 2, 5}, {3, 1, 2}}, {OrderlessPatternSequence[1, 2, 3]}] (*选出在置换群意义下和123相同的list*)
(*-----生成所有无牛牌型-----*)
(*生成40张牌的deck,无花色*)
set = Join @@
Table[#*n & /@ ConstantArray[1, 4], {n, 1, 10}]
(*所有5张牌的牌型*)
subset = Subsets[set, {5}]
(*3张牌和的个位是0的本质不同的全部组合方案*)
cow = Select[Subsets[set, {3}], Mod[Total[#], 10] == 0 &] //
Union
(*有牛牌型的Pattern*)
invalidPattern = {Alternatives @@
Apply[PatternSequence[___, #1, ___, #2, ___, #3, ___] &, cow, {1}]}
(*从全部方案中去除掉有牛的方案,剩下的就是无牛的*)
DeleteCases[subset, invalidPattern]
手机扫一扫
移动阅读更方便
你可能感兴趣的文章