0
$\begingroup$

Suppose we have cellular automaton on a network. For simplicity, we will use matrix notation.

ClearAll[adjMatrix, initStates, nodeStep, allStep];
(*Adjacency matrix*)
adjMatrix = {{0, 1, 1, 0}, {0, 1, 0, 0}, {1, 0, 1, 1}, {0, 0, 1, 0}};
(*Initial states of nodes*)
initStates ={0, 1, 1, 0};  

nodeStep[adjMatrix_, states_, node_] :=
  With[{inputs = Pick[states, adjMatrix[[All, node]], 1]},
    (*Any suitable function here*)
    BitXor @@ inputs
   ];

allStep[adjMatrix_, states_] := 
  nodeStep[adjMatrix, states, #] & /@ Range[Length@states];

Starting from some initial state, the function allStep is applied iteratively. It is known that sooner or later we will get a cycle.

For test example:
{0, 1, 1, 0} → {1, 1, 1, 1} → {1, 0, 1, 1} → {1, 1, 1, 1} → ...
(period 2)

But first, not necessarily straight from the initial state. Second, about the cycle length (period), it is only known that it is smaller than $2^{size}$

I have not been able to find a way to simultaneously detect the cycle and determine its length. For detection I use

data = NestWhileList[allStep[adjMatrix, #]&, initStates, Unequal, All];

and then we can find the length of the cycle.
Several ways have been suggested here.

  • FindRepeat. It fails with period 1
  • SequencePosition. I do not understand what should be M in my case: SequencePosition[data, Take[data, M]]?
  • FindTransientRepeat. It works, but much slower than brutal force method
  • First@Differences@Flatten@Position[data, Last@data]

Some timings:

data = ContinuedFraction[(Sqrt[12] + 2)/7, 100004];
Timing[Length@Last@FindTransientRepeat[data, 2]]
{0.499203, 6}
Timing[r = SequencePosition[data, Take[data, -10]]; 
 r[[-1, 1]] - r[[-2, 1]]]
{0.0156001, 6}
Timing[First@Differences@Flatten@Position[data, Last@data]]
{0.0468003, 6}
$\endgroup$
  • 3
    $\begingroup$ Save the states in a list and use FindTransientRepeat. See here: mathematica.stackexchange.com/questions/175338/… $\endgroup$ – flinty Aug 5 at 16:26
  • 2
    $\begingroup$ Alternatively, if you need to avoid storing lots of data, you can run one process 1 step at a time and a copy of this process 2 steps at a time. At each stage check if their states are equal - then you know there's a cycle. This is like the old Tortoise and Hare trick with linked lists: en.wikipedia.org/wiki/… $\endgroup$ – flinty Aug 5 at 16:30
  • $\begingroup$ I wrote up implementations of Floyd's and Brent's algorithms, but you don't seem to have provided a concrete example I could try them out on. $\endgroup$ – J. M.'s discontentment Aug 5 at 23:53
  • $\begingroup$ @Bill timings are added. But what "-10" means? $\endgroup$ – lesobrod Aug 6 at 10:38
  • $\begingroup$ @J. M., all post completely rewritten $\endgroup$ – lesobrod Aug 6 at 10:39
1
$\begingroup$

The best solution is Brent's algorithm.

brentCycleDetection[adjMatrix_, states_] :=
  Module[{power = 1, lam = 1, tortoise = states, 
    hare = allStep[adjMatrix, states]},
   While[tortoise != hare,
     If[ power == lam,
                 tortoise = hare;
                 power *= 2;
                 lam = 0];
    hare = allStep[adjMatrix, hare];
    lam += 1;
    ];
   lam
   ];

Here is typical example:

size = 13; adjMatrix = RandomInteger[1, {size, size}]; states = 
 RandomInteger[1, size];

Timing[brentCycleDetection[adjMatrix, states]]
{0.140401, 510}

Timing[myCycleDetection[adjMatrix, states]]
{1.54441, 510}
| improve this answer | |
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.