3
$\begingroup$

I created this matrix:

latticeJ = ConstantArray[5, {20, 20}];

and I want to randomly replace 20 values of this matrix with the value of 10 under the condition that none of the 20 newly replaced values are adjacent to one another.

I tried things like:

ReplacePart[latticeJ, Flatten[RandomChoice[latticeJ[[]]]] -> 20]

but to no avail.

$\endgroup$
  • $\begingroup$ "with the value of 10" and -> 20 contradict. $\endgroup$ – Johu Sep 21 '18 at 0:22
  • $\begingroup$ To my knowalge there is no built in function, which would implement "none of the newly replaced values are adjacent to one another". You need to come up with the algrithm to do that I am afraid. $\endgroup$ – Johu Sep 21 '18 at 0:24
  • $\begingroup$ How difficult would it to be to implement this algorithm? How can I randomly replace 20 of the values in this matrix with a specific number? I can start there. $\endgroup$ – Clayton Sloan Sep 21 '18 at 0:30
  • 1
    $\begingroup$ Your "adjacency constraint" is actually equivalent to the Queens Problem, only that you don't have queens but kings (it depends if you are regarding a 4- or 8-neighbourhood). That means, that you can start placing 10s into your matrix, but when you hit a dead end and you cannot insert another 10, you need to backtrack. So it's not done (if you want to do it non-hacky) by simply replacing randomly. Assume you want to replace (20*20)/2 positions. There are only 2 solutions for a 4-neighborhood and searching randomly would be insane. $\endgroup$ – halirutan Sep 21 '18 at 0:50
  • $\begingroup$ As for your simplified question, try ReplacePart[latticeJ, RandomChoice[Tuples[Range[20], 2], 10] -> X] $\endgroup$ – halirutan Sep 21 '18 at 0:53
3
$\begingroup$

Perhaps:

df = ChessboardDistance;
minDistance = 1;
n = 20;
parts = {RandomInteger[{1, 20}, 2]};
While[Length[parts] < n, ri = RandomInteger[{1, 20}, 2]; 
 If[Min[df[ri, #] & /@ parts] > minDistance, AppendTo[parts, ri]]]

latticeJ2 = MapAt[10 &, latticeJ, parts];
(* or latticeJ2 = ReplacePart[latticeJ, parts -> 10]; *)
latticeJ2 // MatrixForm

enter image description here

Counts[Flatten@latticeJ2]

<|5 -> 380, 10 -> 20|>

With n = 75, latticeJ2 becomes:

enter image description here

Counts[Flatten@latticeJ2]

<|10 -> 75, 5 -> 325|>

Needless to say, the task is impossible for large enough n.

$\endgroup$
  • $\begingroup$ Thank you, @kglr. This is fantastic! $\endgroup$ – Clayton Sloan Sep 21 '18 at 5:12
  • $\begingroup$ @kglr Do you use your i=1 statement anywhere? $\endgroup$ – That Gravity Guy Sep 21 '18 at 5:22
  • $\begingroup$ Thank you @ThatGravityGuy; it is leftover from previous edits. $\endgroup$ – kglr Sep 21 '18 at 12:57
3
$\begingroup$

Loop method

Block[
    {reps = DeleteDuplicates@RandomInteger[{1, 20}, {19, 2}]},
    While[
        Length[reps] < 20,
        AppendTo[reps, RandomInteger[{1, 20}, 2]];
        reps = Cases[
            {#, Nearest[Complement[reps, {#}], #, {All, 1}, DistanceFunction -> ChessboardDistance]} & /@ reps,
            {pt_, {}} :> pt
            ]
    ];
    reps
];
Length@%
ReplacePart[ConstantArray[5, {20, 20}], %% -> 10]//MatrixForm

20

enter image description here

Where the ChessboardDistance does not allow for diagonally adjacent elements, and if you just get rid of the DistanceFunction option, then it uses the Euclidean metric, which does allow diagonal adjacency because then the elements are $\sqrt{2}$ away from each other.

Recursive method

RandMat2[reps_List] := If[
    Length@reps < 20,
    RandMat2@With[
        {rando = Append[reps, RandomInteger[{1, 20}, 2]]},
        Cases[
            {#, Nearest[Complement[rando, {#}], #, {All, 1}]} & /@ rando,
            {pt_, {}} :> pt
        ]
    ],
    reps
]
ReplacePart[ConstantArray[5, {20, 20}], RandMat2[RandomInteger[{1, 20}, {19, 2}]] -> 10] // MatrixForm

General recursive method

Well, mostly general. This method is only valid using ChessboardDistance, since that is what allows for the restriction 0 < n <= If[EvenQ@Dim, Dim^2/4, (Dim + 1)^2/4], which tells us the maximum number of choices we could have for any dimension, from the Kings Problem.

RandMat[Dim_Integer, n_Integer, rad_?NumericQ, reps_: {}] /; 0 < n <= If[EvenQ@Dim, Dim^2/4, (Dim + 1)^2/4] := If[
Length@reps < n,
RandMat[Dim, n, rad, #] &@With[
    {rando = DeleteCases[Union[reps, {RandomInteger[{1, Dim}, 2]}], {}]},
    Cases[
        {#, Nearest[rando, #, {All, rad}, DistanceFunction -> ChessboardDistance]} & /@ rando,
        {x_, {x_}} :> x
    ]
],
reps
]

MatrixForm@ReplacePart[ConstantArray[0, {2, 2}], RandMat[2, 1, 1] -> 1]
MatrixForm@ReplacePart[ConstantArray[0, {3, 3}], RandMat[3, 2, 1] -> 1]
MatrixForm@ReplacePart[ConstantArray[0, {5, 5}], RandMat[5, 4, 2] -> 1]

enter image description here

$\endgroup$
3
$\begingroup$

This can be done in ways already indicated. I want to point out that, if there is a need to scale to larger matrices and/or more alterations, there are a couple of approaches that might be more efficient. I will show one such since it is easier to code. The idea is that after each new random position is selected, we mark its neighbors as "off limits" so that we get a quick predicate for determining when to discard a selection.

I only show how to select positions, since the subsequent alteration step is immediate. For simplicity I assume that the matrix is square, but extending to general rectangular is not difficult.

There is one catch. We might get into a situation where there are no viable positions remaining. I do not actually check for this, instead using an arbitrary cap on the number of attempts as n^2, where n is the requested number of positions (I am not assuming it is necessarily equal to the dimension).

As second efficiency is to fill in a preallocated array with newly selected positions. One could instead use Reap/Sow. AppendTo scales quite poorly and should be avoided if size requirements grow.

randomPosns[dim_, n_] := Module[
  {picked, tot, posns, count = 0, pos, nbhood, j = 0},
  tot = dim^2;
  posns = ConstantArray[{0, 0}, n];
  nbhood = Map[IntegerDigits[#, 3, 2] - 1 &, Range[0, 8]];
  While[count < n && j < n^2,
   j++;
   pos = RandomInteger[{1, dim}, 2];
   If[picked[pos], Continue[]];
   count++;
   posns[[count]] = pos;
   Scan[(picked[#] = True) &, Map[pos + # &, nbhood]];
   ];
  {j, count, posns}
  ]

Here we use dimensions from n=64 up to 2^10, doubling size at each step, and selecting n*CubeRoot[n] positions. I show timings, then a list of the form {number attempts, number positions obtained}. The former, for this count, is never much larger than the latter so there are not too many attempts that fail due to collision with a prior selection or neighbor thereof.

result = 
  Table[Timing[randomPosns[n, Floor[CubeRoot[n]*n]]], {n, 
    2^Range[6, 10]}];
result[[All, 1]]
result[[All, 2, 1 ;; 2]]

(* Out[27]= {0.03125, 0.09375, 0.265625, 0.671875, 1.71875}

Out[28]= {{369, 256}, {794, 645}, {1835, 1625}, {4402, 4096}, {10850, 
  10321}} *)

In cases where the number required might approach the limit of what can be selected subject to the neighbor restrictions, there is a faster method based on a standard approach to uniform shuffling. It takes a bit more code though. (A further advantage is it does not require down values, hence can coded using Compile should absolute speed be a need.)

$\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.