In[]:=
<<SetReplace`
In[]:=
SetAttributes[WolframModelRuleProduct,Flat]
In[]:=
WolframModelRuleProduct[rule1_Rule,rule2_Rule]:=Module[{unif=First/@HypergraphUnifications[First[rule1],First[rule2]]},FindCanonicalWolframModel[Flatten[Function[i,Map[i#&,Catenate[Last[MultiwaySystem[WolframModel[rule1],#,1,"AllStatesListUnmerged"]]&/@Last[MultiwaySystem[WolframModel[rule2],i,1,"AllStatesListUnmerged"]]]]]/@unif]]]
In[]:=
WolframModelRuleProduct[rule1_,rule2_List]:=FindCanonicalWolframModel@Catenate[WolframModelRuleProduct[rule1,#]&/@rule2]
In[]:=
WolframModelRuleProduct[rule1_List,rule2_]:=FindCanonicalWolframModel@Catenate[WolframModelRuleProduct[#,rule2]&/@rule1]
In[]:=
RulePlot@WolframModel@WolframModelRuleProduct[{{1,2},{2,3}}{{1,2},{2,3}},{{1,2},{2,3}}{{1,2},{2,3}}]
Out[]=
In[]:=
RulePlot@WolframModel@WolframModelRuleProduct[{{1,2},{2,3}}{{1,2},{2,3}},{{1,2},{2,3}}{{1,2},{2,3}},{{1,2},{2,3}}{{1,2},{2,3}}]
Out[]=
Rule with symmetry on both sides
In[]:=
RulePlot@WolframModel[{{1,2},{1,3},{1,4}}{{5,6},{6,5},{5,7},{6,7},{7,5},{7,6},{5,2},{6,3},{7,4}}]
Out[]=