9
$\begingroup$

I want to construct a random square matrix in the following manner:

enter image description here

a) Three states [0 | 1 | 2] are repeated [2 | 4 | 6 | 8 | 10] times in each row

b) All numbers of current row must be different from the numbers directly above them

I have written:

Make one row

mrow := Module[{x},
  Take[
   Flatten @ Table[x = RandomInteger[{0, 2}];
     Table[x, {RandomChoice[{2, 4, 6, 8}]}], {5}],
   10]]

Prepare matrix with indexed variable row. Determine by subtraction whether next row is different. If not While - loop until a different row is found.

For[n = 2; row[1] = mrow, n <= 10, n++,
 row[n] = mrow;
 While[MemberQ[row[n - 1] - row[n], 0], row[n] = mrow]];

Output matrix

Map[row[#] &, Range[10]] // MatrixPlot

enter image description here

Unfortunately, for the first time, I had to use For and While with MMA programming.

Do you see any functional way to get the desired result?

$\endgroup$
  • $\begingroup$ BTW, there are 5 3^5 2^20 possible configurations. Not all of them are equally probable, though $\endgroup$ – Dr. belisarius Sep 23 '14 at 19:16
11
$\begingroup$

Here's an approach without If or For. First a helper function:

(* Thanks to Belisarius for the mrow& suggestion *)
 g[x_] := NestWhile[mrow&, x, MemberQ[x - #, 0] &] 

Then:

NestList[g, mrow, 9] // MatrixPlot

Where mrow is as you've defined it in the question.

Mathematica graphics

$\endgroup$
  • $\begingroup$ +1. You don't need f[] ... g[x_] := NestWhile[mrow &, x, MemberQ[x - #, 0] &] $\endgroup$ – Dr. belisarius Sep 23 '14 at 19:19
  • $\begingroup$ @Belisarius, Thanks, I knew my brain was failing me :). I'll update. $\endgroup$ – RunnyKine Sep 23 '14 at 19:23
  • $\begingroup$ BTW I find this solution really nice $\endgroup$ – Dr. belisarius Sep 23 '14 at 19:27
  • $\begingroup$ @Belisarius. Thanks. I almost gave up on it. $\endgroup$ – RunnyKine Sep 23 '14 at 19:42
  • $\begingroup$ First time that I see a non-pure function (mrow) ending with a &. Some day I'll understand. Let me upvote in-between :) $\endgroup$ – eldo Sep 23 '14 at 21:11
4
$\begingroup$

Nice question. I'd try to do something with recursion instead, like

Clear[f];

f[n_] := f[n] = newRow[f[n - 1]]
f[0] = ConstantArray[10, 10];

newRow[previousRow_] := With[{row = mrow},
  If[MemberQ[previousRow - row, 0], newRow[previousRow], row]
  ]
Array[f, 10] // MatrixPlot
$\endgroup$
  • 1
    $\begingroup$ Your elegant solution functions perfectly. Many thanks :) $\endgroup$ – eldo Sep 23 '14 at 16:58
2
$\begingroup$
 row := Take[
         NestWhile[Join[#, ConstantArray[RandomInteger[{0, 2}],
             RandomChoice[{2, 4, 6, 8}]]]  &, {} , Length@# < 10 &], 10]

 Nest[Module[{b}, (While[Times @@ (#[[-1]] - (b = row)) == 0];
       Append[#, b])] & , {row} , 9] // MatrixPlot
$\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.