Recall to run FindCanonicalWolframModel
In[]:=
GrowStandardOrder[order_,s_]:=Module[{max},max=Min[Max[order]+1,s];Append[order,#]&/@Range[max]]
Lists rules of form a_3 -> b_3 with s integers
WolframModelRules3[{a_,b_},s_]:=Module[{t=(a+b)*3,alllists,allrules},alllists=Partition[#,3]&/@Flatten[Table[GrowStandardOrder[Flatten[{u,v}],s],{u,Flatten[GrowStandardOrder[{1,#},s]&/@Range[2],1]},{v,Tuples[Range[s],{t-4}]}],2];allrules=#[[;;a]]#[[a+1;;]]&/@alllists;Union[FindCanonicalWolframModel[allrules]]]
Lists rules of form a_2 -> b_2 with s integers
In[]:=
WolframModelRules2[{a_,b_},s_]:=Module[{t=(a+b)*2,alllists,allrules},alllists=Partition[#,2]&/@Flatten[Table[GrowStandardOrder[Flatten[{u,v}],s],{u,GrowStandardOrder[{1},2]},{v,Tuples[Range[s],{t-3}]}],2];allrules=#[[;;a]]#[[a+1;;]]&/@alllists;Union[FindCanonicalWolframModel[allrules]]]
Compare
Compare
In[]:=
Union[FindCanonicalWolframModel[RuleShapeToCases[{2,1},3]]]//Length
Out[]=
70
In[]:=
WolframModelRules2[{2,1},3]//Length
Out[]=
86
In[]:=
Complement[WolframModelRules2[{2,1},3],Union[FindCanonicalWolframModel[RuleShapeToCases[{2,1},3]]]]
Out[]=
In[]:=
Union[FindCanonicalWolframModel[RuleShapeToCases[{2,3},2]]]//Length
Out[]=
100
WolframModelRules2[{2,3},2]//Length
Out[]=
86
In[]:=
Complement[WolframModelRules2[{2,3},2],Union[FindCanonicalWolframModel[RuleShapeToCases[{2,3},2]]]]
Out[]=
Updated SW function
Updated SW function
This gives all possible “shapes” for σ edges:
In[]:=
allshapes[σ_]:=DeleteDuplicates[Sort/@(Partition[#,2]&/@Flatten[Permutations/@IntegerPartitions[σ,{0,σ,2}],1])]
Given a shape, we have to actually “spray symbols” in all possible ways:
rcases[lr:{_,_},arity_Integer,s_Integer]:=Apply[Rule,(Partition[#,arity]&/@TakeList[#,arity*lr])&/@Tuples[Range[s],arity*Total[lr]],{1}]
Find the minimal representative based on relabeling symbols and permuting edges:
In[]:=
mincase[rule_,s_Integer]:=First[Sort[Map[Sort,(rule/.#)&/@(Thread[Range[s]#]&/@Permutations[Range[s]]),{2}]]]
For a given rule shape, find all minimal cases:
RuleShapeToCases[lr:{_,_},arity_Integer,s_Integer]:=Union[mincase[#,s]&/@rcases[lr,arity,s]]
Generalized RuleEnumeration
Generalized RuleEnumeration
Old
Old
rcasesGeneralOld[rulesignature_Rule,s_Integer]:=Module[{lhs=Apply[List,rulesignature][[1]],rhs=Apply[List,rulesignature][[2]],lcases,listcases,rcasesGeneral},lcases=TakeList[#,{Total[#[[1]]*#[[2]]&/@lhs],Total[#[[1]]*#[[2]]&/@rhs]}]&/@Tuples[Range[s],Total[#[[1]]*#[[2]]&/@Flatten[{lhs,rhs},1]]];listcases={TakeList[#[[1]],#[[1]]*#[[2]]&/@lhs],TakeList[#[[2]],#[[1]]*#[[2]]&/@rhs]}&/@lcases;Flatten[MapThread[Partition,{#[[1]],lhs[[All,2]]}],1]->Flatten[MapThread[Partition,{#[[2]],rhs[[All,2]]}],1]&/@listcases]
New
New
In[]:=
rcasesGeneral[rulesignature_Rule,s_Integer]:=Module[{lhs=Apply[List,rulesignature][[1]],rhs=Apply[List,rulesignature][[2]]},Apply[Rule,TakeList[#,{Total[Flatten[lhs[[All,1]]]],Total[Flatten[rhs[[All,1]]]]}]&/@(TakeList[#,Flatten[Table[#[[2]],#[[1]]]&/@Flatten[{lhs,rhs},1]]]&/@Tuples[Range[s],Total[#[[1]]*#[[2]]&/@Flatten[{lhs,rhs},1]]]),{1}]]
In[]:=
RuleShapeToCases[rulesignature_Rule,s_Integer]:=Union[mincase[#,s]&/@rcasesGeneral[rulesignature,s]]
In[]:=
RuleShapeToCases[{{2,3},{2,2}}->{{3,2}},2]//AbsoluteTiming
Out[]=
In[]:=
RuleShapeToCases[{{4,3}}->{{3,2}},2]//AbsoluteTiming
Out[]=
In[]:=
RuleShapeToCases[{{1,3}}{{2,3}},4]//AbsoluteTiming
Out[]=