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$
8
  • 3
    $\begingroup$ Save the states in a list and use FindTransientRepeat. See here: mathematica.stackexchange.com/questions/175338/… $\endgroup$
    – flinty
    Commented Aug 5, 2020 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
    Commented Aug 5, 2020 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$ Commented Aug 5, 2020 at 23:53
  • $\begingroup$ @Bill timings are added. But what "-10" means? $\endgroup$
    – lesobrod
    Commented Aug 6, 2020 at 10:38
  • $\begingroup$ @J. M., all post completely rewritten $\endgroup$
    – lesobrod
    Commented Aug 6, 2020 at 10:39

1 Answer 1

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}
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

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