组合数学程序包 by My_Desire

BeginPackage[ "My`"]

RTRow::usage = "Read Triangle by Row"

TpQ::usage = "全正性判断"

LSTP::usage = "三角全正性判断"

RiordanArray::usage = "RiordanArray[d_Function,h_Function,n_]"

ExpRiordanArray::usage = "expRiordanArray[d_Function,h_Function,L_]"

AZ::usage = "AZ sequence matrix."

RowRZ::usage = "row gf Rz"

RowRZQ::usage = "Q row gf Rz"

LHM::usage = "Lower Hessenberg Matrix"

AddOne::usage = "矩阵添加首行首元1"

AddRC::usage = "矩阵添加首行首列首元1"

RevLT::usage = "下三角矩阵的反排"

ADLT::usage = "AntiDiagLowerTriangle"

ADT::usage = "AntiDiagTotal"

EvenRowMat::usage = "取矩阵偶数行"

OddRowMat::usage = "取矩阵奇数行"

SMQ::usage = "判断序列是不是SM的"

PFQ::usage = "判断序列是不是PF的"

LCQ::usage = "判断序列是不是LC的"

LCXQ::usage = "判断序列是不是LCX的"

OEISA::usage = "获取序列的OEIS号"

OEISO::usage = "打开序列对应的OEIS网站"

OEISI::usage = "获取序列的OEIS号的信息"

MyLook::usage = "让我看看"

Begin[ "Private`"]

RTRow[R_]:=
Module[
{M,sl},M=R;
Flatten[Table[R[[i]][[1;;i]],{i,Length[R]}]]];

RiordanArray[d_Function,h_Function,n_]:=
Module[
{R,p,q,i},i=n;
p=Series[d[u],{u,0,i}];
q=Series[h[u],{u,0,i}];
R = CoefficientList[Array[p*q^# &, i + 1, 0], u, i + 1];
R// Transpose]

ExpRiordanArray[d_Function,h_Function,L_]:=
Module[
{R,Y,M,p,q,l},l=L;
M=Table[n!/k!,{n,0,l},{k,0,n}]//PadRight;
p=Series[d[x],{x,0,l}];
q=Series[h[x],{x,0,l}];
R=CoefficientList[Array[p*q^#&,l+1,0],x,l+1];
Y=Transpose[R]*M//Expand;Y//MatrixForm]

LHM[d_Function,h_Function,n_]:=
Module[
{p,q,i,sl},i=n;
p=Series[d[t],{t,0,i}];
q=Series[h[t],{t,0,i}];
sl={CoefficientList[p,t]};SetSharedVariable[sl];
Do[AppendTo[sl,Flatten[CoefficientList[q*t^j, t,n+1]]],{j,0,n-1}];
sl//PadRight//Transpose
]

AZ[R_]:=Inverse[Take[R,Length[R]-1,Length[R]-1]] . Take[R,{2,Length[R]},Length[R]-1]

RowRZ[R_,l_]:=Do[Print[DeleteCases[0][R[[i]]*Table[Array[#*Global`x^i&,1],{i,0,l}]//Flatten]//Total],{i,1,l+1}]

RowRZQ[R_,l_]:=Table[Flatten[NSolve[Total[DeleteCases[0][R[[i]]*Table[Array[#*Global`x^i&,1],{i,0,l}]//Flatten]]==0,Global`x]],{i,1,l+1}]//PadRight//MatrixForm

LSTP[R_]:=
Module[
{G,o},G=R;o=Length[G]-1;
sl={};SetSharedVariable[sl];
Do[Do[AppendTo[sl,Det[Transpose[Transpose[G][[1;;j]]][[i;;i+j-1]]]],{i,1,o+2-j}],{j,1,o+2}];
ReplaceAll[Boole[AllTrue[Flatten[sl], Positive]],{0->"\[Times]",1->"\[Checkmark]"}]]

TpQ[R_]:=
Module[
{M,sl},M=R;
sl={};SetSharedVariable[sl];
Do[AppendTo[sl,Select[Minors[M,i]//Flatten,#<0&]],{i,0,Length[M]}];
ReplaceAll[Boole[AllTrue[Flatten[sl], Positive]],{0->"\[Times]",1->"\[Checkmark]"}]]

AddRC[R_]:=
Module[
{M,T},M=R;
T=ResourceFunction["PrependColumn"][Transpose[ResourceFunction["PrependColumn"][M,
Table[0,{i,0,Length[M]-1}]]],Join[{1},Table[0,{i,0,Length[M]-1}]]]//Transpose;
ResourceFunction["DropColumn"][Transpose[ResourceFunction["DropColumn"][T,{Length[T]}]],
{Length[ResourceFunction["DropColumn"][T,{Length[T]}]]}]//Transpose]

AddOne[R_]:=
Module[
{M,T},M=R;
T=Join[{Join[{1},Table[0,{i,0,Length[M]-2}]]},M];
Transpose[ResourceFunction["DropColumn"][Transpose[T],{Length[T]}]]]

RevLT[R_]:=
Module[
{M},M=R;
Map[Reverse,MapIndexed[RotateLeft,M]]]

ADLT[R_]:=
Module[
{M,sl},M=R;
Table[M[[n-k]][[k+1]],{n,1,Length[M],2},{k,0,Floor[n/2]}]//PadRight]

ADT[R_]:=
Module[
{M,sl},M=R;
Transpose[Table[M[[n-k]][[k+1]],{n,1,Length[M],1},{k,0,Floor[n/2]}]//PadRight]//Total
]

EvenRowMat[R_]:=
Module[
{M},M=R;
Table[M[[n]][[k]],{n,1,Length[M],2},{k,1,Length[Transpose[M]]}]//PadRight]

OddRowMat[R_]:=
Module[
{M},M=R;
Table[M[[n]][[k]],{n,2,Length[M],2},{k,1,Length[Transpose[M]]}]//PadRight]

SMQ[a_]:=
Module[
{g},g=a;
Table[g[[i+j+1]],{i,0,Length[g]/2-1},{j,0,Length[g]/2-1}]//TpQ]

LCQ[a_]:=
Module[
{g},g=a;
ReplaceAll[Boole[Table[g[[i]]*g[[i+2]]-g[[i+1]]*g[[i+1]]<=0,{i,1,Length[g]-2}]],{0->"\[Times]",1->"\[Checkmark]"}]]

LCXQ[a_]:=
Module[
{g},g=a;
ReplaceAll[Boole[Table[g[[i]]*g[[i+2]]-g[[i+1]]*g[[i+1]]>=0,{i,1,Length[g]-2}]],{0->"\[Times]",1->"\[Checkmark]"}]]

PFQ[a_]:=
Module[
{g},g=a;
LowerTriangularize[ToeplitzMatrix[g]]//TpQ]

OEISA[a_]:=
Module[
{g},g=a;
searchString=StringJoin[Riffle[ToString/@g,"%2C+"]];
oeisLink="https://oeis.org/search?q="<>searchString<>"&language=english&go=Search";
pageContent=Import[oeisLink,"Source"];
sequenceNumberPattern="A[0-9]+";
matches=StringCases[pageContent,RegularExpression[sequenceNumberPattern]->"$0"];
firstMatch=First[matches]]

OEISO[a_]:=
Module[
{g},g=a;
searchString=StringJoin[Riffle[ToString/@g,"%2C+"]];
oeisLink="https://oeis.org/search?q="<>searchString<>"&language=english&go=Search";
oeisLink]

OEISI[a_]:=
Module[
{g},g=a;
htmlContent=URLFetch[g//OEISO];
pattern="<td valign=top align=left>[\\s\\S]*?<br>";
matches=StringCases[htmlContent,RegularExpression[pattern]->"$0"];
result=StringSplit[matches[[1]],"\n"][[2]];
result=StringTrim[result];
result]

MyLook[R_]:=
Module[
{M,L,m},M=R;L=Length[M];m=Transpose[M][[1]];
{Grid[{{"三角",M//RTRow//OEISA,M//RTRow//OEISI},{"第0列",m//OEISA,m//OEISI},{"行和",Total[Transpose[M]]//OEISA,Total[Transpose[M]]//OEISI},{"反对角线和",M//ADT//OEISA,M//ADT//OEISI},{"反排",RevLT[M]//RTRow//OEISA,RevLT[M]//RTRow//OEISI},{"无符号逆",M//Inverse//Abs//RTRow//OEISA,M//Inverse//Abs//RTRow//OEISI}},Alignment->Left,Frame->All],Grid[{{Null,Null,"left product","product"},{"原矩阵",M//MatrixForm,M . Inverse[AddRC[M]]//MatrixForm,M//AZ//MatrixForm},{Null,{{"TP",M//TpQ},{"LSTP",M//LSTP}},{"TP",M . Inverse[AddRC[M]]//TpQ},{"TP",M//AZ//TpQ}},{"无符号逆",M//Inverse//Abs//MatrixForm,Abs[Inverse[M]] . Inverse[AddRC[Abs[Inverse[M]]]]//MatrixForm,Abs[Inverse[M]]//AZ//MatrixForm},{Null,{{"TP",M//Inverse//Abs//TpQ},{"LSTP",M//Inverse//Abs//LSTP}},{"TP",Abs[Inverse[M]] . Inverse[AddRC[Abs[Inverse[M]]]]//TpQ},{"TP",Abs[Inverse[M]]//AZ//AZ//TpQ}},{"反排",RevLT[M]//MatrixForm,RevLT[M] . Inverse[AddRC[RevLT[M]]]//MatrixForm,RevLT[M]//AZ//MatrixForm},{Null,{{"TP",RevLT[M]//TpQ},{"LSTP",RevLT[M]//LSTP}},{"TP",RevLT[M] . Inverse[AddRC[RevLT[M]]]//TpQ},{"TP",RevLT[M]//AZ//TpQ}}},Frame->All],{{Grid[{{"序号"}~Join~Table[n,{n,0,L-1}],{"第0列"}~Join~m[[1;;L]],Flatten[{"对数凸判断"}~Join~{Flatten[{Null}~Join~{m//LCXQ}]}],{"SM判断"}~Join~Table[m[[n;;Length[m]]]//SMQ,{n,1,Length[m]-1}],Flatten[{"对数凹判断"}~Join~{Flatten[{Null}~Join~{m//LCQ}]}],{"PF判断"}~Join~Table[m[[n;;Length[m]]]//PFQ,{n,1,Length[m]-1}]},Frame->All],Grid[{{"序号"}~Join~Table[n,{n,0,L-1}],{"行和"}~Join~Total[Transpose[M]][[1;;L]],Flatten[{"对数凸判断"}~Join~{Flatten[{Null}~Join~{Total[Transpose[M]]//LCXQ}]}],{"SM判断"}~Join~Table[Total[Transpose[M]][[n;;Length[Total[Transpose[M]]]]]//SMQ,{n,1,Length[Total[Transpose[M]]]-1}],Flatten[{"对数凹判断"}~Join~{Flatten[{Null}~Join~{Total[Transpose[M]]//LCQ}]}],{"PF判断"}~Join~Table[Total[Transpose[M]][[n;;Length[Total[Transpose[M]]]]]//PFQ,{n,1,Length[Total[Transpose[M]]]-1}]},Frame->All],Grid[{{"序号"}~Join~Table[n,{n,0,L-1}],{"反对角线和"}~Join~ADT[M][[1;;L]],Flatten[{"对数凸判断"}~Join~{Flatten[{Null}~Join~{ADT[M]//LCXQ}]}],{"SM判断"}~Join~Table[ADT[M][[n;;Length[ADT[M]]]]//SMQ,{n,1,Length[ADT[M]]-1}],Flatten[{"对数凹判断"}~Join~{Flatten[{Null}~Join~{ADT[M]//LCQ}]}],{"PF判断"}~Join~Table[ADT[M][[n;;Length[ADT[M]]]]//PFQ,{n,1,Length[ADT[M]]-1}]},Frame->All]}}//Grid,RowRZQ[M,Length[M]-1]}//MatrixForm
]

End[]

EndPackage[]