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[]=