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
Minimal code for WolframModel
Minimal code for WolframModel
RulesToPatterns
RulesToPatterns
Makes rules that delete rule inputs from the list, and Sows outputs. That means each edge will only be used once.
In[]:=
RulesToPatterns[lhs_rhs_]:=With[{vars=Union[Flatten[{lhs,rhs}]]},Module[{symbs=Symbol/@StringTemplate["v``"]/@vars},{OrderlessPatternSequence@@Append[#1,rest___]}(Sow@Module[#3,#2];{rest})&[lhs/.Thread[vars(Pattern[#,_]&/@symbs)],rhs/.Thread[varssymbs],Complement[Flatten[rhs],Flatten[lhs]]/.Thread[varssymbs]]]]
In[]:=
RulesToPatterns[{{0,1},{0,2},{0,3}}{{4,5},{5,4},{4,6},{6,4},{5,6},{6,5},{4,1},{5,2},{6,3},{1,6},{3,4}}]
Out[]=
{OrderlessPatternSequence[{v0_,v1_},{v0_,v2_},{v0_,v3_},rest___]}(Sow[Module[{v4,v5,v6},{{v4,v5},{v5,v4},{v4,v6},{v6,v4},{v5,v6},{v6,v5},{v4,v1},{v5,v2},{v6,v3},{v1,v6},{v3,v4}}]];{rest})
WolframModel
WolframModel
Repeatedly uses the rules Reaping output edges at each step, and joining them to edges that remained untouched.
In[]:=
WolframModel[rules_List,init_,n_]:=Nest[Join[First@#,Flatten[Last@#,2]]&@Reap@ReplaceRepeated[#,RulesToPatterns/@rules]&,init,n]
In[]:=
Graph[Rule@@@WolframModel[{{{0,1},{0,2},{0,3}}{{4,5},{5,4},{4,6},{6,4},{5,6},{6,5},{4,1},{5,2},{6,3},{1,6},{3,4}}},{{0,0},{0,0},{0,0}},4]]
Out[]=
Tests
Tests
In[]:=
$sameSetQ[x_,y_]:=Module[{xAtoms,yAtoms},{xAtoms,yAtoms}=DeleteDuplicates[Flatten[#]]&/@{x,y};If[Length[xAtoms]≠Length[yAtoms],Return[False]];(x/.Thread[xAtomsyAtoms])===y]
In[]:=
$systemsToTest={{{{0,1}},{{{0,1}}{{0,2},{2,1}}},100,6},{{{1}},{{{1}}{{1}}},100,100},{{{1}},{{{1}}{{2}}},100,100},{{{1}},{{{1}}{{2},{1,2}}},100,6},{{{1}},{{{1}}{{1},{2},{1,1}}},100,6},{{{1}},{{{1}}{{1},{2},{1,2}}},100,6},{{{1}},{{{1}}{{1},{2},{1,3}}},100,6},{{{1}},{{{1}}{{2},{2},{1,2}}},100,6},{{{1}},{{{1}}{{2},{3},{1,2}}},100,6},{{{1}},{{{1}}{{2},{3},{1,2,4}}},100,6},{{{1}},{{{1}}{{2},{2},{2},{1,2}}},100,4},{{{1},{1},{1}},{{{1}}{{2},{1,2}}},100,34},{{{1,1}},{{{1,2}}{{1,3},{2,3}}},100,6},{{{0,1},{0,2},{0,3}},{{{0,1},{0,2},{0,3}}{{4,5},{5,6},{6,4},{4,6},{6,5},{5,4},{4,1},{5,2},{6,3}}},30,3},{{{0,0},{0,0},{0,0}},{{{0,1},{0,2},{0,3}}{{4,5},{5,6},{6,4},{4,6},{6,5},{5,4},{4,1},{5,2},{6,3}}},30,3},{{{0,1},{0,2},{0,3}},{{{0,1},{0,2},{0,3}}{{4,5},{5,6},{6,4},{4,6},{6,5},{5,4},{4,1},{5,2},{6,3},{1,6},{3,4}}},30,3},{{{0,0},{0,0},{0,0}},{{{0,1},{0,2},{0,3}}{{4,5},{5,6},{6,4},{4,6},{6,5},{5,4},{4,1},{5,2},{6,3},{1,6},{3,4}}},30,3}};
These tests fail because the replacement order is different
In[]:=
VerificationTest[WolframModel[#2,#1,#4],SetReplaceAll[#1,FromAnonymousRules[#2],#4],SameTest$sameSetQ]&@@@$systemsToTest
Out[]=
In[]:=
graphsForMatching={{{1,2},{2,3},{3,4},{4,5}},{{1,2},{2,3},{3,4},{4,1}},{{1,2},{2,3},{3,4},{1,5}},{{2,3},{3,1},{4,2},{4,5}},{{1,5},{2,1},{2,3},{2,4},{2,5},{3,1},{4,2},{4,5}}};
In[]:=
Table[VerificationTest[WolframModel[{graph{}},graph,1],{}],{graph,graphsForMatching}]
Out[]=
In[]:=
VerificationTest[WolframModel[{{{2,3,4},{1,2}}{}},{{1,2},{2,3,4}},1],{}]
Out[]=
In[]:=
VerificationTest[WolframModel[{{{2,3,4},{1,2}}{}},{{1,2},{2,2,3}},1],{}]
Out[]=
In[]:=
VerificationTest[WolframModel[{{{2,3,4},{1,2}}{}},{{1,2},{2,1,3}},1],{}]
Out[]=
In[]:=
VerificationTest[WolframModel[{{{2,3,4},{1,2}}{}},{{1,2},{1,1,3}},1],{{1,2},{1,1,3}}]
Out[]=
In[]:=
VerificationTest[WolframModel[{{{1,2},{2,3}}{{1,3}}},{{1,2},{2,1}},1],{{1,1}}]
Out[]=
In[]:=
graphFromHyperedges[edges_]:=Graph[UndirectedEdge@@@Flatten[Partition[#,2,1]&/@edges,1]];
In[]:=
randomConnectedGraphs[edgeCount_,edgeLength_,graphCount_]:=(#[[All,1]]&@Select[#[[2]]&]@ParallelMap[{#,ConnectedGraphQ@graphFromHyperedges@#}&,BlockRandom[Table[With[{k=edgeCount},Table[RandomInteger[edgeLengthk],k,edgeLength]],graphCount],RandomSeedingToString[{"randomConnectedGraphs",edgeCount,edgeLength,graphCount}]]])
In[]:=
(*Herewegeneraterandomgraphsandtryreplacingthemtonothing*)randomSameGraphMatchTest[edgeCount_,edgeLength_,graphCount_]:=Module[{tests},tests=randomConnectedGraphs[edgeCount,edgeLength,graphCount];Union[ParallelMap[WolframModel[{#[[2]]{}},#[[1]],1]&,BlockRandom[{#,RandomSample[#]}&/@tests,RandomSeedingToString[{"randomSameGraphMatchTest",edgeCount,edgeLength,graphCount}]]]]==={{}}]
In[]:=
VerificationTest[randomSameGraphMatchTest[6,2,5000],True]
Out[]=
In[]:=
VerificationTest[randomSameGraphMatchTest[6,3,500],True]
Out[]=
In[]:=
VerificationTest[randomSameGraphMatchTest[6,10,100],True]
Out[]=