WOLFRAM NOTEBOOK

In[]:=
NewEvolution[rule_,init_,t_]:=With[{r=ToNewRuleForm[rule]},NestList[SubsetReplace[#,r]&,init,t]]
In[]:=
ToNewRuleForm[rule:_Rule,ruleIndex_:1]:=Module[{leftSymbols,rightSymbols,symbols,newVertexNames,vertexPatterns,newLeft,leftVertices,rightVertices,rightOnlyVertices,left},{leftSymbols,rightSymbols}=Union[Cases[#,_?AtomQ,{0,1}],Cases[#,_,{2}]]&/@List@@rule;symbols=Union[leftSymbols,rightSymbols];newVertexNames=ToHeldExpression/@StringTemplate["v``"]/@Range@Length@symbols;vertexPatterns=Pattern[#,Blank[]]&/@newVertexNames;newLeft=(rule[[1]]/.Thread[symbolsvertexPatterns]);left=rule[[1]]/.Thread[symbolsnewVertexNames];{leftVertices,rightVertices}={leftSymbols,rightSymbols}/.Thread[symbolsnewVertexNames];rightOnlyVertices=Complement[rightVertices,leftVertices];With[{moduleVariables=rightOnlyVertices,moduleExpression=rule[[2]]/.Thread[symbolsnewVertexNames],moduleValues=With[{left=left},Hold[Hash[{ruleIndex,#,Sort@left}]]&/@Range[Length[rightOnlyVertices]]]},With[{moduleAssignments=Thread[Hold[Set][moduleVariables,moduleValues]]},If[moduleVariables=!={},newLeftSequence@@Module[moduleAssignments,moduleExpression],newLeftmoduleExpression]]]//.Hold[expr_]expr]ToNewRuleForm[rules:{___Rule}]:=MapThread[ToNewRuleForm[##]&,{rules,Range[Length[rules]]}]
In[]:=
ToNewRuleForm[{{x,y},{x,z}}->{{x,z},{x,w},{y,w},{z,w}}]
Out[]=
{{v2_,v3_},{v2_,v4_}}Sequence@@Module[{v1=Hash[{1,1,Sort[{{v2,v3},{v2,v4}}]}]},{{v2,v4},{v2,v1},{v3,v1},{v4,v1}}]

Minimal Case

In[]:=
Graph[Rule@@@#,GraphLayout"SpringElectricalEmbedding"]&/@NestList[SubsetReplace[#,p:{{x_,y_}}:>Sequence[{x,p},{y,p}]]&,{{,}},3]
Out[]=
In[]:=
HypergraphPlot[Map[Hash,#,{2}]]&/@NestList[SubsetReplace[#,p:{{x_,y_}}:>Sequence[{y,x},{y,p}]]&,{{{},}},7]
Out[]=
In[]:=
HypergraphPlot[Map[Hash,#,{2}]]&/@NestList[SubsetReplace[#,p:{{x_,y_}}:>Sequence[{y,x},{y,p}]]&,{{1,2}},7]
Out[]=
In[]:=
Map[Mod[Hash[#],1000]&,#,{2}]&/@NestList[SubsetReplace[#,p:{{x_,y_}}:>Sequence[{y,x},{y,p}]]&,{{1,2}},4]
Out[]=
In[]:=
HypergraphPlot/@WolframModel[{{x,y}}{{y,x},{y,z}},{{1,2}},5,"StatesList"]
Out[]=
In[]:=
Graph[Rule@@@#,GraphLayout"SpringElectricalEmbedding"]&/@NestList[SubsetReplace[#,p:{{x_,y_}}:>Sequence[{x,p},{p,p}]]&,{{,}},3]
Out[]=
In[]:=
Graph[Rule@@@#,GraphLayout"SpringElectricalEmbedding"]&/@NestList[SubsetReplace[#,p:{{x_,y_}}:>Sequence[{x,p},{p,y}]]&,{{,}},3]
Out[]=
In[]:=
Graph[Rule@@@#,GraphLayout"SpringElectricalEmbedding"]&/@NestList[SubsetReplace[#,p:{{x_,y_}}:>Sequence[{x,p},{p,y},{p,x}]]&,{{,}},7]
Out[]=
In[]:=
Graph[Rule@@@#,GraphLayout"SpringElectricalEmbedding"]&/@NestList[SubsetReplace[#,p:{{x_,y_}}:>Sequence[{x,p},{p,x}]]&,{{,}},4]
Out[]=
In[]:=
Graph[Rule@@@#,GraphLayout"SpringElectricalEmbedding"]&/@NestList[SubsetReplace[#,p:{{x_,y_}}:>Sequence[{x,p},{y,x},{p,x}]]&,{{,}},4]
Out[]=
Wolfram Cloud

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 »

You are using a browser not supported by the Wolfram Cloud. Supported browsers include recent versions of Chrome, Edge, Firefox and Safari.