2
$\begingroup$

I am creating a project in Wolfram that models oil slicking using Cellular Automata. In my project I have a function called vonNeumann Neighborhood that takes in a radius and a length of a size of a 2d square grid.

It's a simple algorithm that goes through the grid and checks if the sum of the x and y values are equal to the radius, less than the radius or neither(meaning it is greater than radius).

If it is equal to the radius, then it changes that cell to a certain shade of Gray. If the sum of the absolute values of x and y is greater than the radius, it should be filled in as 0(white).

But if the sum of the absolute values of x and y is less than radius, then it should do Nothing and move to the next cell. This is because if the sum of the absolute values of x and y are less than the radius, it should have already been coloured in. Therefore, as the iteration increases, the shade of gray of the cells that get coloured should get lighter(sort of like a real life oil spill but in an unrealistic situation).

For some reason when I use Nothing, it gives me the left half of the current and previous iteration of the oil spill and fills in everything else as white. Can someone explain to me why this is and how to fix it so that it shows the whole picture. (The resulting Array Plot is hard to explain with words so I suggest you use the code as below.)

I have used a Manipulate that uses an ArrayPlot to create the grid and goes through iterations from 0-9, so that you can visualise what it would look like.

vonNeumannNeighborhood[r_, m_] := 
Table[
    If[
      Abs[x] + Abs[y] == r, 
      GrayLevel[r/10], 
      If[
        Abs[x] + Abs[y] < r, Nothing, 0]
      ], 
    {x, -m, m}, {y, -m, m}
];

Manipulate[
 ArrayPlot[vonNeumannNeighborhood[n, 9], Mesh -> True, 
  PlotLabel -> r == n], {n, 0, 9, 1}]
$\endgroup$

5 Answers 5

4
$\begingroup$

Using Nothing doesn't skip an index, it replaces the list element with literally nothing, so the length of the list is changed. For example

vonNeumannNeighborhood[5, 9] // MatrixForm

enter image description here

Also, the vonNeumannNeighborhood function doesn't know any previous values.

One possible method is to store the matrix in a variable mat, and give this matrix as an argument to the function.

m = 9;

vonNeumannNeighborhood2[r_, oldmat_] :=
  Table[
   If[
    Abs[x] + Abs[y] == r, GrayLevel[r/10], 
    If[Abs[x] + Abs[y] > r, 0,
     mat[[x + m + 1, y + m + 1]]]], {x, -m, m}, {y, -m, m}];

mat = PadRight[{{}}, {2 m + 1, 2 m + 1}];
Manipulate[
 ArrayPlot[mat = vonNeumannNeighborhood2[n, mat], Mesh -> True, 
  PlotLabel -> "r=" <> ToString[n]], {n, 0, m, 1}]

enter image description here

$\endgroup$
2
  • $\begingroup$ Thank you so much, it works as I want it to. Could you clarify on what: mat[[x + m + 1, y + m + 1]] does? And, do you have a Wolfram Community account so I can mention you in the credits of my project? $\endgroup$
    – Kopiaobia
    Commented Oct 24, 2023 at 14:45
  • 1
    $\begingroup$ @Kopiaobia you're welcome. For each x,y in the Table, the If statement says: If Abs[x] + Abs[y] is r, greylevel, else if > r, 0, else use the value that was already there in the matrix. The matrix indices start at 1, not -9, so the x+m+1 converts x from the table index to the real matrix index. There are probably other/better ways to do it as well. I do not have a Wolfram Community account. $\endgroup$
    – MelaGo
    Commented Oct 24, 2023 at 17:26
2
$\begingroup$

It is because you are using Nothing. Is this what you wanted?

vonNeumannNeighborhood[r_,m_]:=
 Table[
    If[Abs[x]+Abs[y]==r,
       GrayLevel[r/10]
       ,
       If[Abs[x]+Abs[y]<r,
          GrayLevel[1]
           ,
          0
       ]
     ],
     {x,-m,m},{y,-m,m}
  ]

Now

ArrayPlot[vonNeumannNeighborhood[3, 3], Mesh -> True,  PlotLabel -> r == n]

gives

Mathematica graphics

Replacing GrayLevel[1] with Nothing like you had it gives instead

Mathematica graphics

To see why, it is because Nothing changes the length of each row. See this when using Nothing

vonNeumannNeighborhood[2,2]

Mathematica graphics

Compare to when using GrayLevel[1] instead of Nothing. Now each row length remains the same.

vonNeumannNeighborhood[2, 2]

Mathematica graphics

You see the effect now more clear.

$\endgroup$
2
$\begingroup$

Built-in functions such as Norm and CoordinateBoundsArraycan be used for this purpose. As an example:

Clear["Global`*"];
Manipulate[
 With[{pts = CoordinateBoundsArray[{{-r, r}, {-r, r}}]}, 
  Map[Norm[#, 1] &, 
     pts, {2}] /. {a_ /; a <= r :> GrayLevel[0.2], _?NumberQ -> 
      GrayLevel[1]} // ArrayPlot[#
     , DataRange -> {{-r, r}, {-r, r}}
     , Frame -> True
     , FrameTicks -> Automatic
     (*,FrameTicks\[Rule]{{Range[-r,r],Range[-r,r]},{Range[-r,r],
     Range[-r,r]}}*)
     , PlotLabel -> "r=" <> ToString@r
     , Mesh -> All
     , PlotRange -> All
     ] &
  ]
 , {{r, 3}, 0, 9, 1}
 , ContentSize -> {300, 300}
 ]

enter image description here

$\endgroup$
2
$\begingroup$

Using DiamondMatrix:

n = 9;

Generate a list of DiamondMatrix in range 0 to n. The default value of 1 is replaced with the iteration index in order to prepare for the different gray tones for each iteration.

dmx = DiamondMatrix[# , {2 n + 1, 2 n + 1}] /. 1 -> (# + 1) & /@ Range[0, n];

enter image description here

Function c is used for "aggregation" during the folding operation.
The function is basically calculating the minimum out of every 2 corresponding elements of the adjacent matrices, excepting the cases where one of the elements is 0. In that case it will return the 2/x where x is the non-zero element.

c[0, 0] := 0; c[0, x_] := 2/x; c[x_, 0] := 2/x; c[x_, y_] := Min[x, y]; 

The folding part is sequentially "adding up" the dmx matrices using the custom defined function c for aggregation.

res = FoldList[ MapThread[ MapThread[c, {#1, #2}] &,  {#1, #2}] &, dmx];

Manipulate[ArrayPlot[res[[i]], Mesh -> True], {i, 1, n, 1}]

(* Output *)

enter image description here

$\endgroup$
2
  • $\begingroup$ Could you explain what this code means because I'm having trouble understanding it. $\endgroup$
    – Kopiaobia
    Commented Oct 24, 2023 at 17:19
  • $\begingroup$ @Kopiaobia Please see the comments in code. I would kindly suggest you to check Wolfram Documentation for DiamondMatrix, FoldList, MapThread and so on... Fell free to ask if you have any other questions. $\endgroup$
    – vindobona
    Commented Oct 24, 2023 at 20:08
1
$\begingroup$

Maybe something like this:

vonNeumannNeighborhood2[r_, m_] :=
  Table[
    With[
      {distance = ManhattanDistance[{0, 0}, {x, y}]},
      If[distance >= r, 0, Rescale[distance, {0, r}, {1, 0}]]],
  {x, -m, m}, {y, -m, m}]
$\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.