Hi all. I am eager to show you a project I have been working on in my free time. The project is contained in the notebook to follow. If you come across any instances of a blurry Image, or an unevaluated animateGraph, please just rerun the code from your end; I struggled with initialising some of the content.
(EDIT: I recommend downloading the notebook from the attachment at the bottom, or accessing the notebook through the Wolfram Cloud link . The animateGraph really helps to understand the process)
I also welcome any comments, critique, or suggestions :)

Initialisation

In[]:=

j[i_Integer,k_Integer]:=Mod[i,k,1];​​sj[i_Integer,s_List]:=s[[j[i,Length@s]]];​​​​ai[0,n_Integer,s_List,p_Integer:0]:=p~Mod~n;​​ai[i_Integer,n_Integer,s_List,p_Integer:0]:=(ai[i-1,n,s,p]+sj[i,s])~Mod~n;​​​​t[n_Integer,s_List]:=(n*Length[s])/GCD[n,Total[s]];​​​​aiList[n_Integer,s_List,p_Integer:0]:=Table[ai[i,n,s,p],{i,0,t[n,s]}];​​path[vertices_List,directed_Symbol:Rule]:=directed@@@Partition[vertices,2,1];​​​​vertCoords[n_]:=Table[{Cos[(2πi)/n],Sin[(2πi)/n]},{i,n}];​​esf[el_,___]:={Black,Arrowheads[0.02],Arrow[el,0.05]};​​​​Options[graph]={"Union"False};​​animateGraph[n_Integer,s_List,p_Integer:0]:=​​DynamicModule[{​​pathList=path[aiList[n,s,p]],​​verts=Range[n]-1,​​coords=vertCoords[n]},​​Animate[​​Graph[​​verts,​​pathList[[;;i]],​​VertexLabelsAutomatic,​​VertexCoordinatescoords,​​EdgeShapeFunctionesf],​​{i,0,Length@pathList,1},​​AnimationRunningFalse,​​AnimationRepetitions1,​​AnimationRate1.5],SaveDefinitions->True];

Background

Out[]=

Hi all. I am eager to show you what I created using Mathematica. I do want to state, however, I am just an amateur mathematician, this was just for fun.

Intuition

I was in a lecture one day, and noticed a drawing on the back of the chair in front of me. It looked something like this:

I started doodling it myself, trying different numbers of vertices, and different amounts to “step”.
If the original has

n=5

points, and

step=2

(Because it wraps around every

nd

2

vertex), we can call it

C(5,{2})

. The reason for the list will become clear later.

Here is

C(5,{1})

:

And

C(6,{2})

:

I soon realised the same could be done with graphs:

In[]:=

Grid[Table[Labeled[graph[n,s],Style[Row[{"C(",n,",",s,")"}],20,Bold],Top],{n,5,7},{s,{{1},{2},{3}}}],FrameAll]

Out[]=

We can visualise the process of drawing these same graphs:

In[]:=

Grid[Table[Labeled[animateGraph[n,s],Style[Row[{"C(",n,",",s,")"}],25,Bold],Top],{n,5,7},{s,{{1},{2},{3}}}]]

Out[]=

C(5,{1}) i	C(5,{2}) i	C(5,{3}) i
C(6,{1}) i	C(6,{2}) i	C(6,{3}) i
C(7,{1}) i	C(7,{2}) i	C(7,{3}) i

Formulation

There is a simple formula describing which is the next vertex to move to, given the current vertex, and the step to take:

a

i+1

=(

a

i

+s)modn

Where

a

i

=Thecurrentvertex​​

a

i+1

=Thenextvertex​​s=Thestepsize​​n=Thenumberofvertices

We define

a

0

:=0

(the starting vertex).

Example

For

C(5,{1})

:

In[]:=

NestList[Mod[#+1,5]&,0,5]

Out[]=

{0,1,2,3,4,0}

In[]:=

animateGraph[5,{1}]

Out[]=

i

C(8,{3})

:

In[]:=

NestList[Mod[#+3,8]&,0,8]

Out[]=

{0,3,6,1,4,7,2,5,0}

In[]:=

animateGraph[8,{3}]

Out[]=

i

Step Sets

This works when we have the same step size at each iteration.
But we can also have changing step sizes:

We start by defining the Step Set, an ordered list of integers.

S={

s

1

,

s

2

,...,

s

k

}∈

k



Where

S=Stepset​​

s

j

=

th

j

elementofthestepset​​k=Lengthofthestepset

For

k=1

, we keep adding the single element of the set until we reach the starting vertex, as we have been doing:

e.g.

C(7,{3})

In[]:=

animateGraph[7,{3}]

Out[]=

i

For

k≥2

, however, we want to be able to cycle trough the elements of the set.
For example,

C(5,{1,2})

should first add 1, then add 2, then 1, then 2, ...

I define

j(i,k)

, which takes in the current iteration

i

, and the length of the step set

k

, and returns the position of the corresponding step to use from the step set.

In[]:=

j[i_Integer,k_Integer]:=Mod[i,k,1];

It behaves as we would like.

Out[]=

i	j(i,1)
1	1
2	1
3	1
4	1
5	1
6	1
7	1
8	1
9	1
10	1

i	j(i,3)
1	1
2	2
3	3
4	1
5	2
6	3
7	1
8	2
9	3
10	1

i	j(i,4)
1	1
2	2
3	3
4	4
5	1
6	2
7	3
8	4
9	1
10	2

And so,

s

j(i,k)

is the step to take on the

th

i

iteration:

In[]:=

sj[i_Integer,s_List]:=s[[j[i,Length@s]]];

Examples

For

S={4}

, we just keep adding 4.

In[]:=

Table[sj[i,{4}],{i,10}]

Out[]=

{4,4,4,4,4,4,4,4,4,4}

For

S={4,5,6}

, we first add 4, then 5, then 6, and then start from 4 again.

In[]:=

Table[sj[i,{4,5,6}],{i,10}]

Out[]=

{4,5,6,4,5,6,4,5,6,4}

Generalisation

In general then, we can now formulate the next vertex to step to for any step set:

a

i

=(

a

i-1

+

s

j(i,k)

)modn​​

a

0

=pmodn

Where

a

i

=Thecurrentvertex​​

a

i-1

=Thepreviousvertex​​

s

j(i,k)

=Thestepsizetouseoniterationi​​k=Lengthofthestepset​​n=Thenumberofvertices​​p=Thegivenstartingpoint

In[]:=

ai[0,n_Integer,s_List,p_Integer:0]:=p~Mod~n;

In[]:=

ai[i_Integer,n_Integer,s_List,p_Integer:0]:=(ai[i-1,n,s,p]+sj[i,s])~Mod~n;

Examples

In[]:=

Table[ai[i,5,{1}],{i,0,5}]

Out[]=

{0,1,2,3,4,0}

In[]:=

Table[ai[i,5,{2}],{i,0,5}]

Out[]=

{0,2,4,1,3,0}

In[]:=

Table[ai[i,5,{1,2}],{i,0,5}]

Out[]=

{0,1,3,4,1,2}

In[]:=

animateGraph[5,{1,2}]

Out[]=

i

In[]:=

Table[ai[i,7,{2,3}],{i,0,14}]

Out[]=

{0,2,5,0,3,5,1,3,6,1,4,6,2,4,0}

In[]:=

animateGraph[7,{2,3}]

Out[]=

i

Steps till Completion

You may have noticed that the animations stop when the process no longer adds any new edges to the graph.

I initially defined the process to end when the current vertex was equal to the starting vertex

(

a

i

=

a

0

)

. But we see that this doesn’t “fill” the graph with all possible steps.

e.g.

C(6,{2,3})

would end after only 5 steps under this condition, since

In[]:=

ai[5,6,{2,3}]

Out[]=

0

But the full animation shows that there are still more edges to add.

In[]:=

animateGraph[6,{2,3}]

Out[]=

i

And so, the full condition I have been using to decide when the process is complete consists of two checks:

1

.

The current vertex is the same as the starting vertex
​

a

i

=

a

0

2

.

And, the next step index, is equal to the first step index
​

j(i+1,k)=j(1,k)=1

.

In[]:=

Table[j[1,k],{k,10}]

Out[]=

{1,1,1,1,1,1,1,1,1,1}

Or, in other words, when

imodk=0

.
The process can only end when

i

is a multiple of

k

In[]:=

compQ[i_Integer,n_Integer,s_List,p_Integer]:=(ai[i,n,s,p]p)&&(j[i+1,Length@s]1);

The condition is always met at

i=0

In[]:=

Table[{i,compQ[i,5,{1},0]},{i,0,10}]//Grid

Out[]=

0	True
1	False
2	False
3	False
4	False
5	True
6	False
7	False
8	False
9	False
10	True

Define

t:=min{i∈

+



:

a

i

=

a

o

∧imodk=0}

​
​

t

is the first value greater than 0 which falsifies the condition.

I call the following the brute force approach. Find the first

i>0

such that the condition is False.

In[]:=

tBrute[n_Integer,s_List,p_Integer:0]:=Module[{i},​​For[i=1,!compQ[i,n,s,p],i++];i];

In[]:=

tBrute[5,{1}]

Out[]=

5

In[]:=

tBrute[5,{2}]

Out[]=

5

In[]:=

tBrute[5,{1,2}]

Out[]=

10

In[]:=

tBrute[5,{1,2,3}]

Out[]=

15

Although I haven’t been able to prove it, the following formula seems to be equivalent:

t=

n·k

GCD(n,Total[s])

In[]:=

t[n_Integer,s_List]:=

n*Length[s]

GCD[n,Total[s]]

;

In[]:=

t[5,{1}]

Out[]=

5

In[]:=

t[5,{2}]

Out[]=

5

In[]:=

t[5,{1,2}]

Out[]=

10

In[]:=

t[5,{1,2,3}]

Out[]=

15

Informally testing for equivalence:

In[]:=

Table[t[n,s]==tBrute[n,s],​​{n,1,10},​​{s,RandomInteger[{-10,10},{10,10}]}]//Grid

Out[]=

True	True	True	True	True	True	True	True	True	True
True	True	True	True	True	True	True	True	True	True
True	True	True	True	True	True	True	True	True	True
True	True	True	True	True	True	True	True	True	True
True	True	True	True	True	True	True	True	True	True
True	True	True	True	True	True	True	True	True	True
True	True	True	True	True	True	True	True	True	True
True	True	True	True	True	True	True	True	True	True
True	True	True	True	True	True	True	True	True	True
True	True	True	True	True	True	True	True	True	True

If anyone knows how to prove this, I would really appreciate your input.

For now, we have a neat way of finding the number of steps it takes for these graphs to complete.

Proof: All Graphs Complete

It is possible to show that all graphs fulfill the criteria after a finite number of steps.

We want to show that for any

nandS

, there exists an

x

such that

a

x

=

a

o

∧xmodk=0

is true.

Consider the process playing out.

I use the fact that:

1

.

(a+b)modn=(amodn+bmodn)modn

2

.

(amodn)modn=amodn

Now:

a 1 =( a 0 + s 1 )modn​​ a 2 =[( a 0 + s 1 )modn+ s 2 ]modn =[(( a 0 + s 1 )modn)modn+ s 2 modn]modn(1.) =[( a 0 + s 1 )modn+ s 2 modn]modn(2.) =( a 0 + s 1 + s 2 )modn​​ a 3 =[( a 0 + s 1 + s 2 )modn+ s 3 ]modn =( a 0 + s 1 + s 2 + s 3 )modn(Bythesamereasoning) ⋮ a k =( a 0 + s 1 +…+ s k )modn

I define

S

:=

k

∑

j=1

s

j

as shorthand for the sum of the elements of the step set.

a k = a 0 + S modn​​ a k+1 = a 0 + S + s 1 modn ⋮ a 2k = a 0 +2 S modn ⋮ a nk = a 0 +(nk) S modn = a 0 modn+(nk S )modnmodn(1.) =( a 0 modn+0)modnnk S isamultipleofn =( a 0 modn)modn = a 0 modn(2.) = a 0 ( a 0 ∈  n )

Therefore the first condition is met.

Since

(nk)modk=0

, the second condition is also met.

We have that all graphs will complete with

t≤nk



Constructing Graphs

The following function gives the ordered list of vertices

{

a

0

,...,

a

t

}

:

In[]:=

aiList[n_Integer,s_List,p_Integer:0]:=​​Table[ai[i,n,s,p],{i,0,t[n,s]}];

In[]:=

aiList[5,{1,2}]

Out[]=

{0,1,3,4,1,2,4,0,2,3,0}

A useful function for generating random graphs quickly:

In[]:=

randomnS[nMax_Integer:20,kMax_Integer:20]:=​​Module[​​{n=RandomInteger[{3,nMax}],​​k=RandomInteger[{1,kMax}],​​s},​​s=RandomInteger[{-n,n},k];​​Unevaluated[Sequence[n,s]]];

In[]:=

randomnS[]

Out[]=

Sequence[16,{-2,1,16,6,-3,-10,16,-15,-16,0,-13,-6,5,-11,11,-8,-15,8}]

In[]:=

randomnS[10,5]

Out[]=

Sequence[7,{0,-4,6,7}]

In[]:=

aiList[randomnS[]]

Out[]=

{0,4,8,9,0,0}

Create an EdgeList given an aiList:

In[]:=

path[vertices_List,directed_Symbol:Rule]:=directed@@@Partition[vertices,2,1];

In[]:=

path[aiList[5,{1,2}]]

Out[]=

{01,13,34,41,12,24,40,02,23,30}

In[]:=

path[aiList[5,{1,2}],UndirectedEdge]

Out[]=

{01,13,34,41,12,24,40,02,23,30}

In[]:=

path[aiList@randomnS[]]

Out[]=

{05,55,51,114,140,00,015,159,914,1414,1410,104,49,99,95,518,184,44,40,013,1318,1818,1814,148,813,1313,139,93,38,88,84,417,173,33,318,1812,1217,1717,1713,137,712,1212,128,82,27,77,73,316,162,22,217,1711,1116,1616,1612,126,611,1111,117,71,16,66,62,215,151,11,116,1610,1015,1515,1511,115,510,1010,106,60}

This function helps to keep the vertices in order when laying them out along the circumference of the circle. (CircularEmbedding doesn’t always preserve ordering of the vertices, in favour of a layout with fewer edge crossings instead).

In[]:=

vertCoords[n_]:=TableCos

2πi

n

,Sin

2πi

n

,{i,n};

Arrow Styles:

In[]:=

esf[el_,___]:={Black,Arrowheads[0.02],Arrow[el,0.05]};

Graph generating function:

In[]:=

Options[graph]={"Union"False};

In[]:=

graph[n_Integer,s_List,p_Integer:0,OptionsPattern[]]:=​​Graph[​​Range[n]-1,​​If[OptionValue["Union"],Union,(#&)]@path[aiList[n,s,p]],​​VertexLabelsAutomatic,​​VertexCoordinatesvertCoords[n],​​EdgeShapeFunctionesf,​​ImageSizeMedium];

In[]:=

graph[10,{3,2,3,4,5}]

Out[]=

In[]:=

Table[graph[randomnS[],"Union"True],6]

Out[]=

Create a more aesthetic graph:

In[]:=

Options[artGraph]={"Union"False};

In[]:=

artGraph[n_Integer,s_List,p_Integer:0,OptionsPattern[]]:=​​Graph[​​Range[n]-1,​​If[OptionValue["Union"],Union,(#&)]@​​path[aiList[n,s,p],UndirectedEdge],​​VertexCoordinatesvertCoords[n],​​VertexStyleBlack,​​BaseStyleEdgeForm[None],​​VertexSize0.001,​​EdgeStyleBlack,​​ImageSizeMedium]

In[]:=

artGraph@randomnS[]

Out[]=

In[]:=

Image@GraphicsGrid[Partition[Table[artGraph[randomnS[]],12],3,4],ImageSizeFull]

Out[]=

Animate

In[]:=

animateGraph[randomnS[]]

Out[]=

i

Completed Graph

I define the completed graph (NOT CompleteGraph), to be the graph of the union of the edge lists of the graphs obtained by starting at all possible points

p

.

This method makes for a blurry completedGraph:

In[]:=

completedGraphShow[n_Integer,s_List]:=Show[​​Table[graph[n,s,p],{p,0,n-1}]