You are using a browser not supported by the Wolfram Cloud
Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.
I understand and wish to continue anyway »
WOLFRAM NOTEBOOK
All colored graphs
All colored graphs
In[]:=
allorigs=First/@{{{{1,2,3},{4,5,6},{1,4},{4,1}}{{3,7,8},{6,9,10},{11,12,2},{13,14,5},{7,11},{8,10},{9,13},{10,8},{11,7},{12,14},{13,9},{14,12}},{{1,2,3},{4,5,6},{1,4},{2,5},{3,6},{4,1},{5,2},{6,3}},15},{{{1,2,3},{4,5,6},{1,4},{4,1}}{{2,7,8},{3,9,10},{5,11,12},{6,13,14},{7,10},{8,13},{9,12},{10,7},{11,14},{12,9},{13,8},{14,11}},{{1,2,3},{4,5,6},{1,4},{2,5},{3,6},{4,1},{5,2},{6,3}},15},{{{1,2,3},{4,5,6},{1,4},{4,1}}{{2,7,8},{3,9,10},{5,11,12},{6,13,14},{7,10},{8,13},{9,12},{10,7},{11,14},{12,9},{13,8},{14,11}},{{1,2,3},{4,5,6},{1,4},{2,5},{3,6},{4,1},{5,2},{6,3}},15},{{{1,2,3},{4,5,6},{1,4},{4,1}}{{2,7,8},{3,9,10},{5,11,12},{6,13,14},{7,11},{8,10},{9,13},{10,8},{11,7},{12,14},{13,9},{14,12}},{{1,2,3},{4,5,6},{1,4},{2,5},{3,6},{4,1},{5,2},{6,3}},15},{{{1,2,3},{4,5,6},{2,5},{5,2}}{{7,1,8},{9,3,10},{11,4,12},{13,6,14},{7,13},{8,10},{9,11},{10,8},{11,9},{12,14},{13,7},{14,12}},{{1,2,3},{4,5,6},{1,4},{2,5},{3,6},{4,1},{5,2},{6,3}},15},{{{1,2,3},{4,5,6},{1,4},{4,1}}{{2,7,8},{3,9,10},{5,11,12},{6,13,14},{7,10},{8,12},{9,13},{10,7},{11,14},{12,8},{13,9},{14,11}},{{1,2,3},{4,5,6},{1,4},{2,5},{3,6},{4,1},{5,2},{6,3}},15},{{{1,2,3},{4,5,6},{1,4},{4,1}}{{2,7,8},{3,9,10},{5,11,12},{6,13,14},{7,11},{8,14},{9,13},{10,12},{11,7},{12,10},{13,9},{14,8}},{{1,2,3},{4,5,6},{1,4},{2,5},{3,6},{4,1},{5,2},{6,3}},15},{{{1,2,3},{4,5,6},{1,4},{4,1}}{{3,7,8},{6,9,10},{11,12,2},{13,14,5},{7,14},{8,11},{9,12},{10,13},{11,8},{12,9},{13,10},{14,7}},{{1,2,3},{4,5,6},{1,4},{2,5},{3,6},{4,1},{5,2},{6,3}},15}}
Out[]=
In[]:=
allorigs/.{x_,y_}/;x>y{y,x}
Out[]=
In[]:=
Map[DeleteDuplicates,%107,{2}]
In[]:=
newrules={{{1,2,3},{4,5,6},{1,4}}{{3,7,8},{6,9,10},{11,12,2},{13,14,5},{7,11},{8,10},{9,13},{12,14}},{{1,2,3},{4,5,6},{1,4}}{{2,7,8},{3,9,10},{5,11,12},{6,13,14},{7,10},{8,13},{9,12},{11,14}},{{1,2,3},{4,5,6},{1,4}}{{2,7,8},{3,9,10},{5,11,12},{6,13,14},{7,10},{8,13},{9,12},{11,14}},{{1,2,3},{4,5,6},{1,4}}{{2,7,8},{3,9,10},{5,11,12},{6,13,14},{7,11},{8,10},{9,13},{12,14}},{{1,2,3},{4,5,6},{2,5}}{{7,1,8},{9,3,10},{11,4,12},{13,6,14},{7,13},{8,10},{9,11},{12,14}},{{1,2,3},{4,5,6},{1,4}}{{2,7,8},{3,9,10},{5,11,12},{6,13,14},{7,10},{8,12},{9,13},{11,14}},{{1,2,3},{4,5,6},{1,4}}{{2,7,8},{3,9,10},{5,11,12},{6,13,14},{7,11},{8,14},{9,13},{10,12}},{{1,2,3},{4,5,6},{1,4}}{{3,7,8},{6,9,10},{11,12,2},{13,14,5},{7,14},{8,11},{9,12},{10,13}}};
In[]:=
ParallelMapMonitored[(HypergraphPlot/@WolframModel[#,Join[Table[0,3,2],Table[0,2,3]],6,"StatesList"])&,newrules]
Out[]=
In[]:=
ParallelMapMonitored[(GraphPlot[HypergraphToGraph@WolframModel[#,Join[Table[0,3,2],Table[0,2,3]],7,"FinalState"]])&,Take[newrules,-4]]
Out[]=
In[]:=
ParallelMapMonitored[(GraphPlot3D[HypergraphToGraph@WolframModel[#,Join[Table[0,3,2],Table[0,2,3]],8,"FinalState"]])&,Take[newrules,-4]]
Out[]=
Consider case of 2 3-edges joined by a 2-edge, mapping to 3 3-edges
Consider case of 2 3-edges joined by a 2-edge, mapping to 3 3-edges