寻找图形中满足Cayley-Bacharach的退化三次曲线

hbghlyj

以这帖为例
代码地址
下载地址

hbghlyj

用法：在B中填写共线的点，在C中填写共锥线的点，在T中填写相切的直线与锥线的编号对。
局限性：只能处理二重点（写代码时未考虑三重点，因为会更麻烦，这个有待完善。只能处理锥线与直线相切，不能处理两个锥线相切（同样是因为会产生三重点）。不能处理由三条共点的直线组成的退化三次曲线（同样是因为会产生三重点）。不能处理同一组中的两条直线经过另一组中的锥线上的同一点且其中一条是切线（同样是因为会产生三重点）。

hbghlyj

[i=s] 本帖最后由 hbghlyj 于 2021-6-17 13:46 编辑 [/i]

Unprotect[C,E];Clear[i,j];
B={{b,c,p},{g,h,p},{i3,f,p},{i2,e,p},{m,n,p},{i2,c,n,i1,g},{i1,h,m,b,i3},{i2,i3,a},{e,c,h,d},{a,e,f},{b,d,g,f}};
C={{a,b,c,m,n},{i1,i2,i3,d,e,f}};
T={{9,1},{10,1},{11,1}};
B=Map[ToString,B,{2}];C=Map[ToString,C,{2}];D0=Join[Subsets[B,{3}],Tuples[{B,C}]];LB=Length[B];LC=Length[C];S3=Binomial[Length[B],3];LD=S3+LB LC;D1=(Tally/@(Flatten/@D0))/.{p_,n_}->If[n>1,Splice[{p}~Join~Table[{p,i},{i,2,n}]],p];c3=Subsets[Range[LB],{3}];
multipntset[i_,j_]=Which[j<=S3,Flatten[{Table[Intersection[B[[c3[[j,Mod[v+1,3,1]]]]],B[[c3[[j,Mod[v-1,3,1]]]]],B[[c3[[i,w]]]]],{v,3},{w,3}],Table[Intersection[B[[c3[[i,Mod[v+1,3,1]]]]],B[[c3[[i,Mod[v-1,3,1]]]]],B[[c3[[j,w]]]]],{v,3},{w,3}]}],i<=S3,Flatten[{Table[If[MemberQ[T,{t,Mod[j-S3,LC,1]}],Splice[Intersection[B[[t]],C[[Mod[j-S3,LC,1]]]]],Nothing],{t,c3[[i]]}],Table[Intersection[B[[c3[[i,Mod[v+1,3,1]]]]],B[[c3[[i,Mod[v-1,3,1]]]]],#]&/@{C[[Mod[i-S3,LC,1]]],B[[Ceiling[(j-S3)/LC]]]},{v,3}]}],True,{If[MemberQ[T,{Ceiling[(i-S3)/LC],Mod[j-S3,LC,1]}],Splice[Intersection[B[[Ceiling[(i-S3)/LC]]],C[[Mod[j-S3,LC,1]]]]],Nothing],If[MemberQ[T,{Ceiling[(j-S3)/LC],Mod[i-S3,LC,1]}],Splice[Intersection[B[[Ceiling[(j-S3)/LC]]],C[[Mod[i-S3,LC,1]]]]],Nothing]}];
For[i=1;E={},i<=LD-2,i++,Di=D1[[i]];Di0=D0[[i]];For[j=i+1,j<=LD-1,j++,Dj=D1[[j]];Dj0=D0[[j]];intersec=Intersection[Di,Dj];mij=multipntset[i,j];If[DisjointQ[Di0,Dj0]&&Length[intersec]+Length[mij]>=9,For[k=j+1,k<=LD,k++,Dk=D1[[k]];Dk0=D0[[k]];If[DisjointQ[Di0,Dk0]&&DisjointQ[Dj0,Dk0]&&Length[Intersection[Dk,intersec]]+Length[Intersection[multipntset[i,j],multipntset[j,k]]]>=9,AppendTo[E,{Di0,Dj0,Dk0}]]]]]]
E



输出
{{{{b,c,p},{i2,c,n,i1,g},{i1,h,m,b,i3}},{{m,n,p},{e,c,h,d},{b,d,g,f}},{{g,h,p},{a,b,c,m,n}}},{{{i3,f,p},{i2,c,n,i1,g},{e,c,h,d}},{{i2,e,p},{i1,h,m,b,i3},{b,d,g,f}},{{g,h,p},{i1,i2,i3,d,e,f}}}}