“WolframModelRuleProduct”

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]:=Catenate[WolframModelRuleProduct[rule1,#]&/@rule2]
In[]:=
WolframModelRuleProduct[rule1_List,rule2_]:=Catenate[WolframModelRuleProduct[#,rule2]&/@rule1]
In[]:=
WolframModelRuleProduct[{{1,2},{1,3}}{{1,2},{1,4},{2,4},{3,4}},{{1,2},{1,3}}{{1,2},{1,4},{2,4},{3,4}}]
In[]:=
Out[]=
RulePlot[WolframModel[#]]&/@%
In[]:=
Out[]=
WolframModel[%361,Automatic,6,"StatesPlotsList"]
In[]:=
Out[]=
WolframModelRuleProduct[{{x,y}}{{x,y},{y,z}},{{x,y}}{{x,y},{y,z}}]
In[]:=
{{{1,2}}{{1,2},{2,3},{3,4}},{{1,2}}{{2,3},{2,4},{1,2}}}
Out[]=
WolframModelRuleProduct[{{x,y}}{{x,y},{y,z}},{{x,y}}{{x,y},{y,z}},{{x,y}}{{x,y},{y,z}}]
In[]:=
Out[]=
RulePlot[WolframModel[#]]&/@%
In[]:=
Out[]=
MultiwaySystem[WolframModel[%],{{0,0}},2,"StatesGraph",VertexSize1]
In[]:=
Out[]=

Find Group [[[ FIRST VERSION ]]]]

permuteRuleX[lhs_rhs_]:=(Last[#]->((lhs/.Thread[#])rhs))&/@(Function[u,(u#)&/@Permutations[u]]@Union[Flatten[lhs]])
In[]:=
gencases[rule_]:=Map[((First/@#)->FindCanonicalWolframModel[Last/@#])&,Tuples[permuteRuleX/@rule]](*maybewrong*)
selectcases[rule_]:=Cases[gencases[rule],(x_rule)x](*maybewrong*)
FindWolframModelGroup[rule:{__Rule}]:=PermutationGroup[PermutationCycles/@#]&/@selectcases[rule]
In[]:=
selectcasesX[lhs_rhs_]:=Cases[permuteRuleX[lhsrhs],(x_(lhsrhs))x]
In[]:=
FindWolframModelGroup[{}]:={}
In[]:=
FindWolframModelGroup[{{{1,2}}{{1,2},{2,3},{3,4}},{{1,2}}{{2,3},{2,4},{1,2}}}]
In[]:=
{PermutationGroup[{Cycles[{}],Cycles[{}]}]}
Out[]=
FindWolframModelGroup[{{{1,2}}{{1,2},{2,1}}}]
In[]:=
{PermutationGroup[{Cycles[{}]}],PermutationGroup[{Cycles[{{1,2}}]}]}
Out[]=
selectcases[{{{1,2}}{{1,2},{2,1}}}]
In[]:=
{{{1,2}},{{2,1}}}
Out[]=
selectcasesX[{{1,2},{2,3}}{{1,2},{2,3},{3,1}}]
In[]:=
{{1,2,3}}
Out[]=
Clear[selectcasesX]
In[]:=
selectcasesX[{{{1,2},{2,3}}{{1,2},{2,3},{3,1}},{{1,2}}{{1,2},{2,1}}}]
In[]:=
{{{1,2,3}},{{1,2}}}
Out[]=
permuteRuleX[{{1,2},{2,3}}{{1,2},{2,3},{3,1}}]
In[]:=
Out[]=
gencases[{{{1,2},{2,3}}{{1,2},{2,3},{3,1}},{{1,2}}{{1,2},{2,1}}}]
In[]:=
Out[]=
gencases[{{{1,2},{2,3}}{{1,2},{2,3},{3,1}}}]
In[]:=
Out[]=
ParallelMapMonitored[#FindWolframModelGroup[{#}]&,EnumerateWolframModelRules[{{1,2}}{{2,2}}]]
In[]:=
Out[]=
FindWolframModelGroup[{{1,2}}{{1,2},{2,1}}]
In[]:=
{}
Out[]=
WolframModelRuleProduct[({{1,2}}{{1,3},{2,3}}),({{1,2}}{{1,3},{2,3}})]
In[]:=
{{{1,2}}{{1,3},{3,4},{2,4}},{{1,2}}{{2,3},{3,4},{1,4}}}
Out[]=
FindWolframModelGroup[%]
In[]:=
{PermutationGroup[{Cycles[{}],Cycles[{}]}],PermutationGroup[{Cycles[{{1,2}}],Cycles[{{1,2}}]}]}
Out[]=
CayleyGraph/@%
In[]:=
Out[]=
PermutationGroup[GroupElements[PermutationGroup[{Cycles[{{1,2}}],Cycles[{{1,2}}]}]]]
In[]:=
PermutationGroup[{Cycles[{}],Cycles[{{1,2}}]}]
Out[]=
CayleyGraph[%]
In[]:=
Out[]=
Map[TimeConstrained[WolframModelRuleProduct[#,#],10]&,EnumerateWolframModelRules[{{1,2}}{{2,2}}]]
In[]:=
Out[]=
EnumerateWolframModelRules[{{1,2}}{{2,2}}][[4]]
In[]:=
{{1,1}}{{1,2},{1,2}}
Out[]=
WolframModelRuleProduct[{{1,1}}{{1,2},{1,2}},{{1,1}}{{1,2},{1,2}}]
In[]:=
{}
»
{}
Out[]=
FindCanonicalWolframModel[{}]
In[]:=
First
:{} has zero length and no first element.
FunctionRepository`$ff1144a79ee74ccbbce506e6ce52e7b9`DelDup[First[{}]]
Out[]=
ParallelMapMonitored[Echo@#TimeConstrained[FindWolframModelGroup[WolframModelRuleProduct[#,#]],10]&,EnumerateWolframModelRules[{{1,2}}{{2,2}}]]
In[]:=
Out[]=
allrules=EnumerateWolframModelRules[{{1,3}}{{2,3}}];
In[]:=
Length[allrules]
In[]:=
9373
Out[]=
RandomSample[allrules,10]
In[]:=
Out[]=
FindWolframModelGroup[{#}]&/@%165
In[]:=
Out[]=
ParallelMapMonitored[TimeConstrained[FindWolframModelGroup[{#}],5]&,EnumerateWolframModelRules[{{1,3}}{{2,3}}]]
In[]:=
Out[]=
Counts[%]
In[]:=
{PermutationGroup[{Cycles[{}]}]}8185,{PermutationGroup[{Cycles[{}]}],PermutationGroup[{Cycles[{{1,2}}]}]}470,{PermutationGroup[{Cycles[{}]}],PermutationGroup[{Cycles[{{2,3}}]}]}359,{PermutationGroup[{Cycles[{}]}],PermutationGroup[{Cycles[{{1,3}}]}]}359
Out[]=
ParallelMapMonitored[TimeConstrained[FindWolframModelGroup[{#}],5]&,EnumerateWolframModelRules[{{2,2}}{{3,2}}]]
In[]:=
Out[]=
Counts[%]
In[]:=
Out[]=
allrules=EnumerateWolframModelRules[{{2,2}}{{3,2}}];
In[]:=
Association[(#->Extract[allrules,FirstPosition[%170,#]])&/@Keys[%171]]
In[]:=
Out[]=
RulePlot[WolframModel[#]]&/@%
In[]:=
Out[]=
ParallelMapMonitored[TimeConstrained[selectcases[{#}],5]&,EnumerateWolframModelRules[{{2,2}}{{3,2}}]]
In[]:=
Out[]=
Counts[%]
In[]:=
Out[]=
ParallelMapMonitored[TimeConstrained[selectcasesX[#],5]&,EnumerateWolframModelRules[{{2,2}}{{3,2}}]]
In[]:=
Out[]=
Counts[%]
In[]:=
{{1}}84,{{1,2}}1480,{{1,2,3}}3138
Out[]=

Second Version

permuteRuleX[lhs_rhs_]:=(Last[#]FindCanonicalWolframModel[(lhs/.Thread[#])rhs])&/@(Function[u,(u#)&/@Permutations[u]]@Union[Flatten[lhs]])
In[]:=
selectcasesX[lhs_rhs_]:=Cases[permuteRuleX[lhsrhs],(x_(lhsrhs))x]
In[]:=
FindWolframModelPermutations[rule:{__Rule}]:=selectcasesX[#]&/@rule
In[]:=
FindWolframModelGroup[rule:{__Rule}]:=PermutationGroup[PermutationCycles/@selectcasesX[#]]&/@rule
In[]:=
FindWolframModelGroup[{}]:={}
In[]:=
FindWolframModelGroup[{{{1,2}}{{1,2},{2,3},{3,4}},{{1,2}}{{2,3},{2,4},{1,2}}}]
In[]:=
{PermutationGroup[{Cycles[{}]}],PermutationGroup[{Cycles[{}]}]}
Out[]=
FindWolframModelGroup[{{{1,2}}{{1,2},{2,1}}}]
In[]:=
{PermutationGroup[{Cycles[{}],Cycles[{{1,2}}]}]}
Out[]=
allrules=EnumerateWolframModelRules[{{2,2}}{{3,2}}];
In[]:=
ParallelMapMonitored[TimeConstrained[FindWolframModelGroup[{#}],5]&,allrules]
In[]:=
Out[]=
Counts[%]
In[]:=
Out[]=
{#[[1,1]],Length[#],Take[Last/@#,UpTo[4]]}&/@GatherBy[ParallelMapMonitored[TimeConstrained[FindWolframModelGroup[{#}],5]#&,allrules],First]
In[]:=
Out[]=
GroupMultiplicationTable[PermutationGroup[{Cycles[{}],Cycles[{{2,3}}],Cycles[{{1,3,2}}],Cycles[{{1,3}}]}]]//ArrayPlot
In[]:=
Out[]=
WolframModelRuleProduct[#,#]&[{{1,2},{1,3}}{{2,2},{1,3},{3,1}}]
In[]:=
{{{1,2},{1,3},{1,4}}{{2,2},{2,1},{1,3},{3,1},{4,4}},{{1,2},{1,3},{1,4}}{{2,2},{3,3},{4,1},{4,1},{1,4}}}
Out[]=
FindWolframModelGroup[%]
In[]:=
Out[]=
GroupMultiplicationTable/@%
In[]:=
Out[]=
FindWolframModelGroup[WolframModelRuleProduct[#,#]&[#]]&/@{{{1,2},{1,3}}{{2,2},{1,2},{3,2}},{{1,2},{1,3}}{{2,2},{1,3},{3,1}},{{1,2},{1,3}}{{2,2},{2,1},{2,3}},{{1,2},{1,3}}{{2,2},{2,2},{2,2}}}
In[]:=
Out[]=
Map[MatrixPlot[GroupMultiplicationTable[#]]&,%,{2}]
In[]:=
Out[]=

Big run

{#[[1,1]],Length[#],Take[Last/@#,UpTo[4]]}&/@GatherBy[ParallelMapMonitored[TimeConstrained[FindWolframModelPermutations[{#}],5]#&,allrules],First]
In[]:=
Out[]=
First/@%
In[]:=
Out[]=
allrules=Import["/Users/sw/Dropbox/Physics/Data/RuleEnumerations/22-32c.wxf"];
In[]:=
Counts[Length[Union[Flatten[First[#]]]]&/@allrules]
In[]:=
184,21480,33138
Out[]=
all3=Select[allrules,Length[Union[Flatten[First[#]]]]3&];
In[]:=
Grid[{ArrayPlot[{permbox3@First[#[[1,1]]]},ImageSize80,MeshTrue,MeshStyleDotted],Length[#],Row[RulePlot[WolframModel[#],ImageSize80]&/@Take[Last/@#,UpTo[3]],Spacer[2]]}&/@SortBy[GatherBy[ParallelMapMonitored[TimeConstrained[FindWolframModelPermutations[{#}],5]#&,all3],First],Total[First[#]]&],FrameAll,Alignment{{Left,Right,Center}}]
In[]:=
Out[]=
permbox3[perms_]:=With[{p=Permutations[Range[3]]},Table[If[MemberQ[perms,p[[i]]],1,0],{i,6}]]
In[]:=
permbox3[{{1,2,3},{3,2,1}}]
In[]:=
{1,0,0,0,0,1}
Out[]=
{{{{1,2,3},{1,3,2}}},808,{,,,}}
Length[%]
In[]:=
13
Out[]=
Length[Subsets[Permutations[Range[3]]]]
In[]:=
64
Out[]=
RuleSignatureForm[{{2,2}}{{3,2}}]
In[]:=
2
2

3
2
Out[]=
PermutationGroup[{{1,2,3},{2,1,3},{3,1,2},{3,2,1}}]
In[]:=
PermutationGroup[{{1,2,3},{2,1,3},{3,1,2},{3,2,1}}]
Out[]=
GroupElements[%]
In[]:=
{Cycles[{}],Cycles[{{2,3}}],Cycles[{{1,2}}],Cycles[{{1,2,3}}],Cycles[{{1,3,2}}],Cycles[{{1,3}}]}
Out[]=
PermutationList[#,3]&/@%
In[]:=
{{1,2,3},{1,3,2},{2,1,3},{2,3,1},{3,1,2},{3,2,1}}
Out[]=

Attempted huge run...

allrules=Import["/Users/sw/Dropbox/Physics/Data/RuleEnumerations/23-33c.wxf"];
In[]:=
{#[[1,1]],Length[#],Take[Last/@#,UpTo[10]]}&/@GatherBy[ParallelMapMonitored[TimeConstrained[FindWolframModelPermutations[{#}],5]#&,allrules],First]
In[]:=
Now
NotebookSave[]