Take the 2-minute tour ×
Mathematica Stack Exchange is a question and answer site for users of Mathematica. It's 100% free, no registration required.

I tried solving this using mma. I am aware of this command - Cellular automata. But i don't want to use that coz then there is no challenge. So below is how i did it and my question is can this be done with fewer lines of code (without resorting to CellularAutomaton). Also i wanted to generalize it to any initial condition.

I am representing the grid shown in the puzzle as a (n $\times$ m) matrix such that all the live cells are represented by 1 and the dead ones by 0. Also in this particular case we have $n = 26$ and $m = 27$. Then i manually made a list of the initial condition given in the question. Here each pair represents the $(ij)^{th}$ element having live cells.

  • [as a side note - can this process be automated - i mean finding this list from that image given for the intial grid by some image processing]
list = {{2, 6}, {2, 13}, {3, 23}, {3, 25}, {4, 3}, {4, 10},
       {4, 9}, {4, 18}, {5, 18}, {5, 2}, {8, 11}, {8, 12},
        {10, 10}, {10, 12}, {11, 11}, {12, 18}, {13, 2}, {14, 2}, {13, 
         23}, {14, 8}, {14, 23}, {16, 24}, {17, 25}, {18, 24},
          {18, 18}, {18, 17}, {19, 12}, {20, 12}, {20, 3}, {20, 4}, {22, 
        24}, {23, 23}, {22, 17}, {23, 18}};

The matrix $A_{n \times m}$ now contains the elements 1 and 0 corresponding to the live and dead cells receptively.
$f^{ij}_{0}$ contains the $(ij)^{th}$ element of $A_{n \times m}$

  A[n_, m_] := SparseArray[# -> 1 & /@ list, {n, m}, 0]

 Table[f[0][i, j] = A[26, 27][[i, j]], {i, 1, 26}, {j, 1, 27}];

The recursive function which gives the next generation is:-

f[k_][i_, j_] := f[k][i, j] = Module[{n = 26, m = 27, neg},

  findNeighbours[i, j] := Module[{},
     f[k - 1][#[[1]], #[[2]]] & /@ {{i - 1, j - 1}, {i - 1, 
       j}, {i - 1, j + 1}, {i, j - 1}, {i, j + 1}, {i + 1, 
         j - 1}, {i + 1, j}, {i + 1, j + 1}}];

   neg = Cases[findNeighbours[i, j], _Integer];

    (* Apply the rules to the ij th element*)
    Which[f[k - 1][i, j] == 1,
          Which[Count[neg, 1] < 2, 
          val = 0, (Count[neg, 1] === 2 || Count[neg, 1] === 3), val = 1, 
           Count[neg, 1] > 3, val = 0],
            f[k - 1][i, j] == 0,
            Which[Count[neg, 1] === 3, val = 1, True, val = 0]]

       ]

Finally we can plot the results to see the answer which is 3 if the starting generation is called $1^{st}$ generation.

   genaration[0] = 
     ArrayPlot[
    Table[f[0][i, j] = A[26, 27][[i, j]], {i, 1, 26}, {j, 1, 27}], Mesh -> True];


   genaration[n_] := 
     ArrayPlot[Table[f[n][i, j], {i, 1, 26}, {j, 1, 27}], Mesh -> True]

  res = ListAnimate[genaration[#] & /@ Range[0, 3], 
         AnimationRate -> 0.5]

share|improve this question
    

2 Answers 2

up vote 9 down vote accepted

My "Game of Life" implementation:

a = RandomInteger[BernoulliDistribution[0.1], {200, 200}];

Dynamic[Image[a =
   1 - Unitize[(# - 3) (# - 12) (# - 13)] &@
    ListConvolve[{{1, 1, 1}, {1, 10, 1}, {1, 1, 1}}, a, {2, 2}, 0]
  ]]

enter image description here

To use the initial grid in the question you would just initialise a with:

a = SparseArray[list -> 1]

However my code continuously updates the grid (quite rapidly), so the grid evolves to the "all dead" state in a fraction of a second.

To actually answer the question "how many generations have any life in them" you could write the evolution step as a function and use FixedPointList to count the number of steps:

evolve[a_] := 1 - Unitize[(# - 3) (# - 12) (# - 13)] &@
  ListConvolve[{{1, 1, 1}, {1, 10, 1}, {1, 1, 1}}, a, {2, 2}, 0]

Length@FixedPointList[evolve, Normal[SparseArray[list -> 1]]] - 2
(* 3 *)

Note that FixedPointList will generate the complete list of grids, so for larger problems you would want to use a different approach to avoid eating all your computer's memory.

share|improve this answer
    
honestly i really don't understand this fully. care to put some comments. like how would i implement this for the initial grid as given in the puzzle. –  Hubble07 Feb 11 at 18:34

This is one way of implementing Conway's Game of Life:

step[matrix_] := Module[{m = matrix, neighbours},
  neighbours = ListConvolve[{{1, 1, 1}, {1, 0, 1}, {1, 1, 1}}, ArrayPad[m, 1]];
  m = ReplacePart[m, Position[neighbours, _?(# == 1 || # > 3 &)] -> 0];
  m = ReplacePart[m, Position[neighbours, 3] -> 1]
  ]

For example, this is the so called glider:

m = ArrayPad[{{0, 1, 0}, {0, 0, 1}, {1, 1, 1}}, {1, 10}];
ListAnimate[ArrayPlot[#, Mesh -> True] & /@ NestList[step, m, 30]]

glider

I've written about another cellular automata problem here and this includes a link to a post where image processing was used in Mathematica to get initial states for a cellular automata problem, so the answer to that question is that yes it is possible.

share|improve this answer
1  
really liked the way ListConvolve is used. such a powerful command. Thanks –  Hubble07 Feb 11 at 18:40

Your Answer

 
discard

By posting your answer, you agree to the privacy policy and terms of service.

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