Wolfram Research

Function Repository Resource:

NestWhileGraph (1.0.0) current version: 1.0.1 »

Source Notebook

Iteratively construct graphs up to a termination condition

Contributed by: Bradley Klee  |  Brad Klee

ResourceFunction["NestWhileGraph"][f,expr,test]

generates a directed graph whose nodes are obtained by applying f repeatedly, starting from expr, and continuing until applying test to the result no longer yields True.

ResourceFunction["NestWhileGraph"][f,expr,test,m]

supplies a list of the most recent m results to test at each step.

ResourceFunction["NestWhileGraph"][f,expr,test,All]

supplies a list of all results so far to test at each step.

ResourceFunction["NestWhileGraph"][f,expr,test,m,max]

applies f at most max times.

Details

ResourceFunction["NestWhileGraph"] accepts all the options of Graph.
When testing on more than one successive graph, results are time ordered with older results occurring earlier in the list.
ResourceFunction["NestWhileGraph"] accepts all the options of Graph.
Setting DirectedEdges False returns an undirected graph.
Typically iterator f should be a list-valued function whose elements are also valid inputs to f.
Then the most general form for a typical output allows internal cycles.
If iteration returns to a previously visited value, it does not use that value as an input at the next step.
Thus, output graphs should not have duplicate edges.

Examples

Basic Examples (3) 

Construct a graph by applying f while VertexCount is less than 5:

In[1]:=
ResourceFunction["NestWhileGraph"][f, x, VertexCount[#] < 5 &, VertexLabels -> Automatic]
Out[1]=

Apply a similar termination condition only to growth-front subgraph:

In[2]:=
ResourceFunction["NestWhileGraph"][{f[#], g[#]} &, 0, Function[{g1, g2},
     VertexCount@VertexDelete[g2, VertexList[g1]]
     ] @@ # <= 8 &, 2]
Out[2]=

Terminate the growth of a graph according to properties of its vertex set:

In[3]:=
ResourceFunction["NestWhileGraph"][{# + 1, 2 # + 1} &, 0,
 Function[{g0}, Length[Select[VertexList[g0],
       VertexInDegree[g0, #] == 2 &]]][#] < 8 &, 1]
Out[3]=

Explore a grid graph through multiway spacetime evolution until every vertex has been visited:

In[4]:=
Function[{dim}, Graph3D[#, GraphLayout -> "SpringElectricalEmbedding"] &@
   With[{moves = Association[# -> VertexOutComponent[
           GridGraph[{dim, dim}], #, {1}] & /@ Range[dim^2]]},
    ResourceFunction["NestWhileGraph"][
     Thread[{moves[#[[1]]], #[[2]] + 1}] &, {{1, 0}},
     UnsameQ[Union[First /@ Flatten[VertexList /@ #, 1]],
       Range[dim^2]] &, All  ]]][5]
Out[4]=

Generate a torus graph:

In[5]:=
Function[{n, m}, ResourceFunction["NestWhileGraph"][{
     Mod[Plus[#, {1, 0}], {n, m}],
     Mod[Plus[#, {0, 1}], {n, m}]} &,
   {{0, 0}}, UnsameQ @@ # &, 2]][12, 6]
Out[5]=

Generate a few different Cayley graphs for the Octahedral group:

In[6]:=
Grid[{Function[{cyca, cycb}, Graph3D[ResourceFunction["NestWhileGraph"][{
          PermutationProduct[Cycles[{cyca}], #],
          PermutationProduct[Cycles[{cycb}], #]} &, Cycles[{{}}],
        UnsameQ @@ # &, 2], ImageSize -> 180]][#1, #2] & @@@ {
    {{1, 2, 3, 4}, {3, 4}}, {{1, 2, 3}, {3, 4}}, {{1, 2, 3, 4}, {2, 3,
       4}}}},
 Frame -> All, FrameStyle -> LightGray, Spacings -> {2, 2}]
Out[6]=

Scope (1) 

When setting DirectedEdges to False, outputs become undirected graphs:

In[7]:=
Grid[{Function[{cyca, cycb}, Graph3D[ResourceFunction["NestWhileGraph"][{
          PermutationProduct[Cycles[{cyca}], #],
          PermutationProduct[Cycles[{cycb}], #]} &, Cycles[{{}}],
        UnsameQ @@ # &, 2, DirectedEdges -> False], ImageSize -> 180]
      ][#1, #2] & @@@ {{{1, 2, 3, 4}, {3, 4}}, {{1, 2, 3}, {3, 4}},
    {{1, 2, 3, 4}, {2, 3, 4}}}},
 Frame -> All, FrameStyle -> LightGray, Spacings -> {2, 2}]
Out[7]=

Options (1) 

Termination can also be accomplished by introducing a cutoff for recursion depth:

In[8]:=
ResourceFunction["NestWhileGraph"][f, x, True &, 1, 4, VertexLabels -> Automatic]
Out[8]=

Neat Examples (2) 

Construct the game graph of a loopy game:

In[9]:=
With[{IterateGameState = Function[{board, player},
    With[{loc = Position[board, player][[1, 1]]},
     Union[Switch[{Total[#[[1]]], #},
         {_, {{__, 1}, -1}}, 1,
         {_, {{-1, __}, 1}}, -1,
         {0, {_, _}}, #,
         {1, {_, _}}, ReplacePart[#, {1, -1} -> -1],
         {-1, {_, _}}, ReplacePart[#, {1, 1} -> 1]
         ] & /@ Complement[{ReplacePart[board, If[0 < (loc + player #) < 7,
             {loc -> 0, (loc + player #) -> player}, {}]],
           -player} & /@ {1, 2},
        {{board, -player}}]]]]},
 gameGraph = SimpleGraph@
   ResourceFunction["NestWhileGraph"][IterateGameState @@ # &,
    {{{1, 0, 0, 0, 0, -1}, 1}}, UnsameQ @@ # &, 2,
    GraphLayout -> "LayeredDigraphEmbedding"]]
Out[9]=

Find loops in the game graph:

In[10]:=
Grid[Partition[With[{cycles = FindCycle[gameGraph, Infinity, All]},
   HighlightGraph[gameGraph, PathGraph[#], ImageSize -> {40, Automatic}] & /@ cycles], 11],
 Frame -> All, FrameStyle -> LightGray, Spacings -> {1, 1}]
Out[10]=

Generate a graph with structure related to prime numbers:

In[11]:=
primeg = ResourceFunction["NestWhileGraph"][Function[{val},
   Append[val + # & /@ FactorInteger[val][[All, 1]], val + 1]]
  , 1, UnsameQ[Length@Intersection[
      Prime /@ Range[15], VertexList[#]], 15] &]
Out[11]=

Notice false positives on the growth front:

In[12]:=
TableForm[#[Sort@Select[
      Sort@VertexList[primeg],
      VertexInDegree[primeg, #] == 1 &],
    Prime /@ Range[25]
    ] & /@ {Intersection, Complement}]
Out[12]=

Version History

  • 1.0.1 – 05 July 2022
  • 1.0.0 – 10 June 2022

Related Resources

License Information