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
Code
Code
In[]:=
transform[obj_,transformation_]:=WolframModelEvolutionObject[Join[obj〚1〛,<|SetReplace`PackageScope`$atomListsTakeList[Permute[Catenate[obj["AllExpressions"]],transformation],Length/@obj["AllExpressions"]]|>]]
In[]:=
toRulePattern[rules_List]:=Alternatives@@toRulePattern/@rules
In[]:=
toRulePattern[rule_Rule]:=Map[Pattern[Evaluate[Symbol["v"<>ToString[#]]],Blank[]]&,rule,{3}]
In[]:=
eventQ[rules_][inEdges_outEdges_]:=MatchQ[inEdgesoutEdges,toRulePattern[rules]]
In[]:=
eventQ[rules_,allExpressions_][event_]:=eventQ[rules][Map[allExpressions〚#〛&,event〚2〛,{2}]]
In[]:=
evolutionQ[obj_]:=And@@eventQ[obj["Rules"],obj["AllExpressions"]]/@obj["AllEventsList"]
One step
One step
In[]:=
symmetries=Position[ParallelMapMonitored[evolutionQ[transform[WolframModel[{{1,2}}{{1,3},{3,2}},{{1,1}},1],PermutationCycles[#]]]&,Permutations[{1,2,3,4,5,6}]],True]〚All,1〛
Out[]=
In[]:=
nonTrivialSymmetries=With[{permutations=Permutations[{1,2,3,4,5,6}]},DeleteDuplicates[symmetries,transform[WolframModel[{{1,2}}{{1,3},{3,2}},{{1,1}},1],PermutationCycles[permutations〚#1〛]]===transform[WolframModel[{{1,2}}{{1,3},{3,2}},{{1,1}},1],PermutationCycles[permutations〚#2〛]]&]]
Out[]=
{1,32,181}
In[]:=
transform[WolframModel[{{1,2}}{{1,3},{3,2}},{{1,1}},1],PermutationCycles[Permutations[{1,2,3,4,5,6}]〚1〛]]["StatesPlotsList"]
Out[]=
This is an interesting case, where events are still valid (and the causal graph is the same), but the structure of the graph is different.
Not sure if we should keep this as symmetry (and if we should, permutations are not enough), but if we don’t, we can disable it easily enough by disallowing deidentification of vertices.
In[]:=
transform[WolframModel[{{1,2}}{{1,3},{3,2}},{{1,1}},1],PermutationCycles[Permutations[{1,2,3,4,5,6}]〚32〛]]["StatesPlotsList"]
Out[]=
In[]:=
transform[WolframModel[{{1,2}}{{1,3},{3,2}},{{1,1}},1],PermutationCycles[Permutations[{1,2,3,4,5,6}]〚181〛]]["StatesPlotsList"]
Out[]=
Two steps
Two steps
In[]:=
WolframModel[{{1}}{{1,2},{2}},{{1}},2]["StatesPlotsList"]
Out[]=
In[]:=
symmetries=Position[ParallelMapMonitored[evolutionQ[transform[WolframModel[{{1}}{{1,2},{2}},{{1}},2],PermutationCycles[#]]]&,Permutations[Range[7]]],True]〚All,1〛
Out[]=
{1,2,7,8,25,26,31,32,49,50,55,56,721,722,727,728,745,746,751,752,769,770,775,776,4265,4266,4271,4272,4289,4290,4295,4296,4313,4314,4319,4320,4985,4986,4991,4992,5009,5010,5015,5016,5033,5034,5039,5040}
In[]:=
nonTrivialSymmetries=With[{permutations=Permutations[Range[7]]},DeleteDuplicates[symmetries,transform[WolframModel[{{1}}{{1,2},{2}},{{1}},2],PermutationCycles[permutations〚#1〛]]===transform[WolframModel[{{1}}{{1,2},{2}},{{1}},2],PermutationCycles[permutations〚#2〛]]&]]
Out[]=
{1,4265}
In[]:=
transform[WolframModel[{{1}}{{1,2},{2}},{{1}},2],PermutationCycles[Permutations[Range[7]]〚1〛]]["StatesPlotsList",VertexLabelsAutomatic]
Out[]=
In[]:=
transform[WolframModel[{{1}}{{1,2},{2}},{{1}},2],PermutationCycles[Permutations[Range[7]]〚4265〛]]["StatesPlotsList",VertexLabelsAutomatic]
Out[]=