How to simulate a random walk to randomly generated particle to another particle fixed at the center of a grid?

So, here is my reformulations of C.E.'s code.

What has changed:

  • I use reservoirs rand and randpts of large random arrays; generating such arrays is much less expensive than generating every random number on its own.

  • I use RegionMember and Nearest for the collision tests.

Implementation

getCluster[startcluster_, nparticles_, L_] := Module[{
    getStartpoint, getDirection,
    directions, cluster, nf, box, inboxQ, nrand, rand, nrandpts, 
    randpts, iparticle, irand, irandpts, particle, inbox
    },
   
   getStartpoint[] := Block[{p},
     If[irandpts < nrandpts,
      irandpts++,
      irandpts = 1;
      randpts = RandomInteger[{-L, L}, {nrandpts, 2}];
      ];
     p = randpts[[irandpts]];
     While[
      Length[nf[p, {1, 0}]] > 0,
      If[irandpts < nrandpts,
       irandpts++,
       irandpts = 1;
       randpts = RandomInteger[{-L, L}, {nrandpts, 2}];
       ];
      p = randpts[[irandpts]];
      ];
     p
     ];
   
   getDirection[] := (
     If[irand < nrand,
      irand++,
      irand = 1;
      rand = RandomInteger[{1, 4}, nrand];
      ];
     directions[[rand[[irand]]]]
     );
   
   directions = Developer`ToPackedArray[{{0, 1}, {1, 0}, {0, -1}, {-1, 0}}];
   
   (* set up a sufficiently large array to store the cluster in order to avoid the costly Append.*)
   cluster = Join[startcluster, ConstantArray[{0, 0}, {nparticles}]];
   nf = Nearest[cluster -> Automatic];
   
   (* define the box and a collision checker *)
   
   box = Rectangle[{-L, -L}, {L, L}];
   inboxQ = RegionMember[box];
   
   (* counters for the reservoirs for random numbers and points *)
   
   irand = nrand = 1000000;
   irandpts = nrandpts = 10000;
   
   iparticle = Length[startcluster];

   (* share some progress info with the user *)       
   PrintTemporary[
    Dynamic[
     Grid@
      Transpose[{{"iparticle", "irand", "irandpts"}, {iparticle, 
         irand, irandpts}}]
     ]
    ];
   While[iparticle < Length[cluster],
    Check[particle = getStartpoint[];, Print["!"]];
    inbox = True;
    While[inbox,
     Check[particle += getDirection[];, Print["?"]];
     inbox = inboxQ[particle];
     If[inbox,
      If[Length[nf[particle, {1, 1}]] > 0,
       Check[cluster[[iparticle]] = particle;, Print["."]];
       nf = Nearest[cluster -> Automatic];
       iparticle++;
       inbox = False
       ]
      ]
     ]
    ];
   Association[
    "Cluster" -> cluster,
    "Box" -> box,
    "N" -> nparticles
    ]
   ];

And here a function to plot the particles with color according to their age:

showCluster[a_Association] := With[{L = a[["Box", 2, 2]]},
   ArrayPlot[
    Transpose@SparseArray[
      (a[["Cluster"]] + (L + 1)) -> 
       Rescale[Range[Length[a[["Cluster"]]]]],
      {2 L + 1, 2 L + 1},
      2.
      ],
    ColorFunction -> "DeepSeaColors",
    PlotRange -> {0, 1},
    ClippingStyle -> White,
    DataReversed -> {True, False}
    ]
   ];

Usage example

A test run with 2000 particles, a single condensation core at {0,0}, and a box of edgelength 101 = 2 * 50 + 1 (yes, this takes a bit):

data = getCluster[{{0, 0}}, 10000, 100]; // AbsoluteTiming // First

184.823

And here a plot of the result:

showCluster[data]

enter image description here

You can continue the simulation with

data2 = getCluster[data[["Cluster"]], 10000, 100]; // AbsoluteTiming // First
showCluster[data2]

28.3286

enter image description here

Surprisingly complex patterns!


This is like what you described, except that I also made sure that the particle didn't wander outside of the region $-100 \leq x, y \leq 100$ to ensure that convergence wouldn't take too long.

particles = {{0, 0}};
nf = Nearest[particles -> Automatic];
nextStep := RandomChoice[{{0, 1}, {1, 0}, {0, -1}, {-1, 0}}];
nParticles = 100;
l = 100;

inBounds[{x_, y_}, l_] := -l < x < l && -l < y < l

Do[
  particle = RandomInteger[{-l, l}, 2];
  While[
   Length[nf[particle, {1, 1}]] == 0,
   particle = RandomInteger[{-l + 1, l - 1}, 2];
   ];
  step = nextStep;
  While[
   Length[nf[particle, {1, 1}]] == 0,
   particle += step;
   step = nextStep;
   While[
    ! inBounds[particle + step, l],
    step = nextStep;
    ]
   ];
  AppendTo[particles, particle];
  nf = Nearest[particles -> Automatic],
  {nParticles}
  ];

Graphics[{
  Point[particles]
  }]

Mathematica graphics