4
$\begingroup$

I am new to Mathematica, and am having trouble implementing confining boundary conditions for a random walk simulation confining the walker to a pre-defined region (periodic boundary conditions would be interesting as well). Right now the walker does not cross the boundary and instead makes an alternative step. I am not sure how to add an extra case where, should a step be directed outside the boundary (say the right wall) the walker would have four choices up, down, left or just remain at its current position (skip a step).

Clear[randomWalk]
randomWalk[steps_Integer, start_, region_] /; start ∈ region :=
  DynamicModule[
       {stepTypes, stepList, alternativeStep, stepChoice, 
        positions, edgePositions, pointPrimitives, text},
    stepTypes = Flatten[Permutations[#, {2}] & /@ {{0, 1}, {0, -1}}, 1];
    stepList = RandomChoice[stepTypes, steps];
    alternativeStep[currentPosition_, nextStep_] :=
      RandomChoice[Select[Complement[stepTypes, {nextStep}], (currentPosition + # ∈ region &)]];
    stepChoice[currentPosition_, nextStep_, nearEdgePosition_] :=
      If[currentPosition + nextStep ∈ region, 
        currentPosition + nextStep, 
        (Sow[nearEdgePosition];
         currentPosition + alternativeStep[currentPosition, nextStep])];
      {positions, edgePositions} = 
         FoldList[
           stepChoice[#1, Sequence @@ #2] &, 
           start, 
           MapIndexed[List, stepList]] // Reap;
      pointPrimitives[n_Integer] := 
        {If[MemberQ[Flatten @ edgePositions, n], Red, Black], 
         Point[positions[[n]]]};
      text[n_Integer] := 
        Text[
          Style[Row @ {n, ": ", positions[[n]]}, 
          If[MemberQ[Flatten @ edgePositions, n], Red, Black], Bold, 15], 
          {Right, Top}, {1., 1.}];
       Manipulate[
         Graphics[{
           Gray, region, AbsolutePointSize[5], 
           White, Line[positions], 
           pointPrimitives[i], 
           text[i]}, 
           Frame -> True, 
           ImagePadding -> 25], 
         {i, 1, Length[positions], 1}]]

randomWalk[500, {12, 12}, Rectangle[{0, 0}, {25, 25}]]
$\endgroup$
1

2 Answers 2

3
$\begingroup$

Here are solutions to both boundary protocols. They are built on the same basic framework -- mainly the function that generates the moves for the walker is what differs between the two. There is a little adjustment in the way the lines and walker point is drawn because of discontinuities in the path generated by the wrap-arround protocol,

Path clips at the boundary

ClippingRandomWalk[
    steps_Integer,
    start : {_Integer, _Integer},
    rect : Rectangle[{xmin_, ymin_}, {xmax_, ymax_}]] /; start ∈ rect := 
  DynamicModule[{walk, next, positions},
    next[{x_, y_}] :=
      Module[{dx, dy},
        {dx, dy} = RandomChoice[{{-1, 0}, {1, 0}, {0, 1}, {0, -1}}];
        {Clip[x + dx, {xmin, xmax}], Clip[y + dy, {ymin, ymax}]}];
    walk[n_] := NestList[next, start, n];
    positions = walk[steps];
    Manipulate[
      Column[{
        Style[
          Row @ {"step: ", i, Spacer[20], "position: ", positions[[i + 1]]},
          "SB", 12],
        Graphics[{
          Gray, Scale[rect, 1.02],
          White, Thick, Line[positions],
          Red, PointSize[Large], Point[positions[[i + 1]]]},
          PlotRange -> {{xmin, xmax}, {ymin, ymax}},
          Frame -> True,
          PlotRangePadding -> Scaled[.025],
          ImageSize -> 400]}],
      Style["Clipping Random Walk", 12, "SB"],
      {{i, 0, Style["step", "SB", 11]}, 0, steps, 1, 
        Appearance -> "Open", ImageSize -> Large}]]

 SeedRandom[4];
 ClippingRandomWalk[100, {1, 0}, Rectangle[{-5, -4}, {5, 4}]]

clipwalk

Path wraps to opposite side at the boundary

WrappingRandomWalk[
    steps_Integer,
    start : {_Integer, _Integer},
    rect : Rectangle[{xmin_, ymin_}, {xmax_, ymax_}]] /; start ∈ rect := 
  DynamicModule[{next, walk, pts, lines},
    next[{x_, y_}] := next[{{x, y}, {x, y}}];
    next[{{_, _}, pt : {x_, y_}}] :=
      Module[{nx, ny},
        {nx, ny} = pt + RandomChoice[{{-1, 0}, {1, 0}, {0, 1}, {0, -1}}];
        Which[
          nx < xmin, {{xmax, y}, {xmax - 1, y}},
          nx > xmax, {{xmin, y}, {xmin + 1, y}},
          ny < ymin, {{x, ymax}, {x, ymax - 1}},
          ny > ymax, {{x, ymin}, {x, ymin + 1}},
          True, {pt, {nx, ny}}]];
    walk[n_] := NestList[next, start, n] // Rest; 
    With[{w = walk[steps]},
      pts = Prepend[w[[All, 2]], start];
      lines = Line /@ w];
    Manipulate[
      Column[{
        Style[
          Row @ {"step: ", i, Spacer[20], "position: ", pts[[i + 1]]}, 
          "SB", 12],
        Graphics[{
          Gray, Scale[rect, 1.02],
          White, Thick, lines,
          Red, PointSize[Large], Point[pts[[i + 1]]]},
          PlotRange -> {{xmin, xmax}, {ymin, ymax}},
          Frame -> True,
          PlotRangePadding -> Scaled[.025],
          ImageSize -> 400]}],
      Style["Wrapping Random Walk", 12, "SB"],
      {{i, 0, Style["step", "SB", 11]}, 0, steps, 1, 
        Appearance -> "Open", ImageSize -> Large}]]

SeedRandom[4];
WrappingRandomWalk[100, {1, 0}, Rectangle[{-5, -4}, {5, 4}]]

wrapwalk

$\endgroup$
0
7
$\begingroup$

You could use Region functionality (for simpler regions), e.g.

rw[pt_, s_, n_, reg_] := 
 Module[{ch = {{0, 0}, {1, 0}, {-1, 0}, {0, 1}, {0, -1}}, np, st},
  st = RandomChoice[ch, n];
  FoldList[If[RegionMember[reg, #1 + s #2], #1 + s #2, #1] &, pt, st]
  ]
an[p_, step_, num_, regn_] := 
 With[{pnts = rw[p, step, num, regn]}, 
  ListAnimate[
   Graphics[{White, EdgeForm[Blue], regn, Black, Line[pnts[[1 ;; #]]],
        Red, PointSize[0.03], Point[pnts[[#]]]}] & /@ Range[2, num]]]

In the above the walker sticks (if proposed step goes outside region) till a direction (up, down,left, right) within region arises. Periodicity at boundary could be deal with withMod with offset.

Manipulate[
 an[{0, 1}, step, number, 
  region], {step, {0.05, 0.1, 0.2, 0.4}}, {number, {10, 100, 200, 
   500}}, {{region, 
   Disk[{1/2, 1/2}, 
    2]}, # -> 
     Graphics[#] & /@ {Polygon[{{-1, -1}, {1, -1}, {3, 3/2}, {2, 
       2}, {1, 1}, {-1, 2}, {0, 0}}], Disk[{1/2, 1/2}, 2], 
    Rectangle[{-1, -1}, {1, 2}]}}]

enter image description here

You could also use DiscreteMarkovProcess. In the following it is a random walk on a square grid with allowed moves includes not moving with each acceptable move equiprobable, e.g. upper left corner moves: +{0,0},+{1,0},+{0,1}->1/3.

func[num_, n_] := 
 If[Mod[num, n] == 0, {Quotient[num, n], n }, 
  QuotientRemainder[num, n] + {1, 0}]
f[lst_, n_] := Cases[lst, {_?(1 <= # <= n &), _?(1 <= # <= n &)}]

arr[n_] := 
 Module[{r = Range[n^2], 
   m = {{0, 0}, {1, 0}, {0, 1}, {-1, 0}, {0, -1}}, pos, mv, w, u},
  pos = func[#, n] & /@ r;
  mv = Map[Function[x, Union[# + x & /@ m]], pos];
  w = f[#, n] & /@ mv;
  u = Map[n (#[[1]] - 1) + #[[2]] &, w, {2}];
  SparseArray[
   Join @@ MapIndexed[
     Map[Function[x, {#2[[1]], x} -> 1/Length[#1]], #1] &, u], {n^2, 
    n^2}]
  ]

dm[n_, s_] := 
 Module[{mk = DiscreteMarkovProcess[1, arr[n]], rnd, p, sa, ap1, ap2},
  rnd = RandomFunction[mk, {0, s}];
  p = func[#, n] & /@ rnd["Values"];
  sa = SparseArray[p[[#]] -> 1, {n, n}] & /@ Range[s + 1];

  ap1 = MatrixPlot[#, Mesh -> All, 
      ColorRules -> {1 -> Black, 0 -> White}] & /@ sa; 
  ap2 = ListPlot[{-1/2, n + 1/2} + {1, -1} # & /@ 
       Reverse /@ (p[[1 ;; #]]), Joined -> True, 
      PlotStyle -> {Red, Thick}] & /@ Range[s + 1];
  Show @@@ Thread[{ap1, ap2}]]

Visualizing:

ListAnimate[dm[8, 200]]

enter image description here

I hope this is helpful or motivates. These are just "top of head" and neither pretty nor efficient but may prompt experts or other useful ideas.

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