ApplyPerm[perm_,rule_]:=Map[#[[perm]]&,#,{2}]&@rule
In[]:=
{#,ApplyPerm[{3,2,1},#]}&[{{1,2,3},{3,4,5}}{{6,7,1},{6,3,8},{5,7,8}}]
In[]:=
{{{1,2,3},{3,4,5}}{{6,7,1},{6,3,8},{5,7,8}},{{3,2,1},{5,4,3}}{{1,7,6},{8,3,6},{8,7,5}}}
Out[]=
RulePlot[WolframModel[#],VertexLabelsAutomatic]&/@%
In[]:=
Out[]=
XYifyRule[{{1,2,3},{3,4,5}}{{6,7,1},{6,3,8},{5,7,8}}]
In[]:=
Thread
:Objects of unequal length in {1,2,3,4,5,6,7,8}{x,y,z,u,v,w,p,q,r,s} cannot be combined.
{{1,2,3},{3,4,5}}{{6,7,1},{6,3,8},{5,7,8}}
Out[]=
RandomWolframModelRule[{{2,3}}{{3,3}}]
In[]:=
{{1,2,3},{2,4,5}}{{5,6,4},{6,5,3},{7,8,5}}
Out[]=
ApplyPerm[{3,2,1},%]
In[]:=
{{3,2,1},{5,4,2}}{{4,6,5},{3,5,6},{5,8,7}}
Out[]=
FindCanonicalWolframModel[%]
In[]:=
{{1,2,3},{4,3,5}}{{4,1,6},{2,6,1},{1,7,8}}
Out[]=
RulePlot[WolframModel[{{1,2,3},{2,4,5}}{{5,6,4},{6,5,3},{7,8,5}}]]
In[]:=
Out[]=
RulePlot[WolframModel[#],VertexLabelsAutomatic,ImageSize300]&/@{#,FindCanonicalWolframModel[ApplyPerm[{3,2,1},#]]}&[{{1,2,3},{2,4,5}}{{5,6,4},{6,5,3},{7,8,5}}]
In[]:=
Out[]=
samp=ParallelTable[RandomWolframModelRule[{{2,3}}{{3,3}}],10000];
In[]:=
psamp=Function[perm,perm->Pick[samp,ParallelMapMonitored[(FindCanonicalWolframModel[Map[#[[perm]]&,#,{2}]]===#)&,samp]]]/@Rest[Permutations[Range[3]]]
In[]:=
Out[]=
First[#]Length[Last[#]]&/@%
In[]:=
{{1,3,2}7,{2,1,3}3,{2,3,1}0,{3,1,2}0,{3,2,1}10}
Out[]=
First[#]Length[Last[#]]&/@{{1,3,2}{{{1,2,3},{4,3,5}}{{6,3,1},{3,7,8},{9,4,3}},{{1,2,3},{4,3,5}}{{2,6,7},{5,6,7},{3,1,4}},{{1,2,3},{1,4,5}}{{1,6,7},{8,6,7},{9,3,4}},{{1,2,3},{4,3,5}}{{6,3,3},{5,2,7},{2,7,5}},{{1,2,3},{4,3,5}}{{6,1,4},{6,7,8},{9,2,5}},{{1,2,2},{1,3,3}}{{4,5,1},{6,1,7},{2,8,9}},{{1,2,3},{4,3,2}}{{1,5,5},{2,6,6},{3,7,7}}},{2,1,3}{{{1,1,2},{3,4,1}}{{2,2,5},{6,6,5},{4,3,2}},{{1,1,2},{2,2,3}}{{2,2,4},{2,5,6},{7,2,6}},{{1,2,3},{2,1,4}}{{1,5,6},{5,2,7},{8,9,4}},{{1,1,2},{3,4,2}}{{5,6,4},{6,7,3},{8,9,1}}},{2,3,1}{},{3,1,2}{},{3,2,1}{{{1,2,3},{4,2,5}}{{6,2,7},{6,8,9},{10,11,7}},{{1,2,1},{2,3,2}}{{3,4,3},{5,6,1},{1,7,8}},{{1,2,3},{3,4,5}}{{6,7,1},{7,8,9},{5,9,6}},{{1,2,3},{3,4,5}}{{3,6,3},{4,7,2},{8,7,9}},{{1,2,1},{2,3,2}}{{4,5,4},{5,2,5},{6,5,6}},{{1,2,3},{4,2,5}}{{2,6,2},{3,6,1},{3,7,1}},{{1,2,3},{3,4,5}}{{6,7,1},{6,3,8},{5,7,8}}}}
In[]:=
{{1,3,2}7,{2,1,3}4,{2,3,1}0,{3,1,2}0,{3,2,1}7}
Out[]=
samp=ParallelTable[RandomWolframModelRule[{{2,3}}{{2,3}}],10000];
In[]:=
psamp=Function[perm,perm->Pick[samp,ParallelMapMonitored[(FindCanonicalWolframModel[Map[#[[perm]]&,#,{2}]]===#)&,samp]]]/@Rest[Permutations[Range[3]]]
In[]:=
Out[]=
First[#]Length[Last[#]]&/@%
In[]:=
{{1,3,2}56,{2,1,3}45,{2,3,1}0,{3,1,2}0,{3,2,1}43}
Out[]=
allrules=Import["/Users/sw/Dropbox/Physics/Data/RuleEnumerations/22-32c.wxf"];
In[]:=
pall=Function[perm,perm->Pick[allrules,ParallelMapMonitored[(FindCanonicalWolframModel[Map[#[[perm]]&,#,{2}]]===#)&,allrules]]]/@Rest[Permutations[Range[2]]]
In[]:=
Out[]=
Length[Last[First[%]]]
In[]:=
92
Out[]=
Length[allrules]
In[]:=
4702
Out[]=
RulePlot[WolframModel[#],ImageSizeTiny]&/@Last[First[pall]]
In[]:=
Out[]=
allrules=Import["/Users/sw/Dropbox/Physics/Data/RuleEnumerations/12-22c.wxf"];
In[]:=
pall=Function[perm,perm->Pick[allrules,ParallelMapMonitored[(FindCanonicalWolframModel[Map[#[[perm]]&,#,{2}]]===#)&,allrules]]]/@Rest[Permutations[Range[2]]]
In[]:=
Out[]=
RulePlot[WolframModel[#],ImageSizeTiny]&/@Last[First[pall]]
In[]:=
Out[]=
Length[Last[First[pall]]]
In[]:=
11
Out[]=
Length[allrules]
In[]:=
73
Out[]=
RuleSignatureForm[{{2,2}}{{4,2}}]
In[]:=
2
2

4
2
Out[]=
RuleSignatureForm[{{2,3}}{{3,3}}]
In[]:=
2
3

3
3
Out[]=

Significance

R (Θ S) = Θ(R S)
#[[{3,2,1}]]&/@{{1,2,3},{2,3,5},{1,5,2}}
In[]:=
{{3,2,1},{5,3,2},{2,5,1}}
Out[]=
FindCanonicalHypergraph[%]
In[]:=
h0={{1,2,3},{2,3,4},{3,1,4}}
In[]:=
{{1,2,3},{2,3,4},{3,1,4}}
Out[]=
FindCanonicalHypergraph[{{1,2,3},{2,3,5},{1,5,2}}]
In[]:=
{{1,2,3},{1,3,4},{3,4,2}}
Out[]=
WolframModel[{{1,2,3},{3,4,5}}{{6,7,1},{6,3,8},{5,7,8}},h0,6,"StatesPlotsList"]
In[]:=
Out[]=
WolframModel[{{1,2,3},{3,4,5}}{{6,7,1},{6,3,8},{5,7,8}},{{1,2,3},{1,3,4},{3,4,2}},6,"StatesPlotsList"]
In[]:=
Out[]=
WolframModel[{{1,2,3},{2,4,5}}{{5,6,4},{6,5,3},{7,8,5}},{{1,2,3},{1,3,4},{3,4,2}},3,"StatesPlotsList"]
In[]:=
Out[]=
WolframModel[{{1,2,3},{2,4,5}}{{5,6,4},{6,5,3},{7,8,5}},h0,3,"StatesPlotsList"]
In[]:=
Out[]=
WolframModel[{{1,2,3},{3,4,5}}{{6,7,1},{6,3,8},{5,7,8}},#[[{3,2,1}]]&/@h0,8,"LayeredCausalGraph"]
In[]:=
Out[]=
GraphNeighborhoodVolumes@WolframModel[{{1,2,3},{3,4,5}}{{6,7,1},{6,3,8},{5,7,8}},#[[{3,2,1}]]&/@h0,8,"LayeredCausalGraph"]
In[]:=
1{1,4,7,10,11},2{1,4,7,10},3{1,4,8,9},4{1,4,7},5{1},6{1,4,5},7{1},8{1,3,4},9{1,3},10{1},11{1}
Out[]=
WolframModel[{{1,2,3},{3,4,5}}{{6,7,1},{6,3,8},{5,7,8}},h0,8,"LayeredCausalGraph"]
In[]:=
Out[]=
GraphNeighborhoodVolumes@WolframModel[{{1,2,3},{3,4,5}}{{6,7,1},{6,3,8},{5,7,8}},h0,8,"LayeredCausalGraph"]
In[]:=
Out[]=
WolframModel[{{1,2,3},{2,4,5}}{{5,6,4},{6,5,3},{7,8,5}},{{1,2,3},{1,3,4},{3,4,2}},3,"StatesPlotsList"]
In[]:=
Out[]=
WolframModel[{{1,2,3},{2,4,5}}{{5,6,4},{6,5,3},{7,8,5}},{{1,2,3},{1,3,4},{3,4,2}},7,"LayeredCausalGraph"]
In[]:=
Out[]=
WolframModel[{{1,2,3},{2,4,5}}{{5,6,4},{6,5,3},{7,8,5}},h0,7,"LayeredCausalGraph"]
In[]:=
Out[]=

Check “interesting” rules....