Random walk with fixed initial and final coordinates and the length

Question

Looking at the problem of a random walk in 2D or 3D, I would like to generate several trajectories that start all in some starting point, say, (0,0) in 2D and (0,0,0) in 3D and end up all in a specified point, say (20,20) in 2D or (20,20,0) in 3D and have the same number of steps, say, 100. All steps are of the same length, say, 1. The solution may be on a lattice, or lattice-free. The initial and final coordinates are not constrained. What is important is that the overall walk length is larger than the end-to-end distance. Any ideas for a realization?

Edit

Thanks to the comment of shrx below I came to such a version of the solution:

proc = BrownianBridgeProcess[];
Show[{
  Graphics3D[
   Table[{Hue[i/16], 
     Tube@Line[
       MapThread[
        Append[#1, #2[[2]]] &, {RandomFunction[proc, {0, 1, 0.1}, 3][
          "Path"], 
         RandomFunction[proc, {0, 1, 0.1}, 3]["Path"]}]]}, {i, 1, 
     10}]],
  Graphics3D[{Arrowheads[0.06], Red, 
    Arrow[Tube[{{0, 0, 0}, {1, 0, 0}}, 0.02]]}],
  Graphics3D[
   Text[Style["\!\(\*OverscriptBox[\(R\), \(\[RightVector]\)]\)", 24, 
     Red, Bold, Italic], {0.5, 0, 0.15}]]
  }]

looking as follows:

where the end-to-end vector is shown in red for clearness. I cannot, however, figure out how to change the length. That is, my end-to-end vector is {{0,0,0},{0,1,0}} . It seems that I should simply replace 1, say, by 10, to have the end-to-end vector {{0,0,0},{0,10,0}} in the RandomFunction expression

RandomFunction[proc, {0, 1, 0.1}, 3]["Path"]

This does not work, however, for reasons I do not see.

Answer 1

EDIT: Refactored code. Old code can be found in the end of the answer.

Initial settings. We take 20 lattice-free unit steps starting from {10, 0, 0}. Four such paths are calculated.

steps = 20;
start = {10, 0, 0};
paths = 4;

We do this in three dimensions, and whenever we perform random sampling, we strive for 10000 samples.

dims = 3;
samples = 10000;

An uniformly distributed unit-length lattice-free random walk step in dim dimensions can be computed using this trick. This function computes the resulting position after steps.

ClearAll[randomWalk]; 
randomWalk[steps_, dim_] := 
 Total[Normalize /@ 
   RandomVariate[NormalDistribution[0, 1], {steps, dim}]]

The core idea of this answer is to use probability distributions which represent likelihood of reaching origin in certain amount of unit-length random walk steps. These distributions are estimated from sample walks, for which in this fully symmetric case the distance covered is the only interesting parameter.

This function is used to compute parameter estimators for PERTDistribution, which is really a nicely reparameterized variant of BetaDistribution. It is left as an exercise to the reader to observe that distributions of distances from origin after N steps can be approximated with beta distribution.

ClearAll[distributionEstimates]; 
distributionEstimates[steps_, dim_, samples_, estimates_] := 
 NonlinearModelFit[#, a Sqrt[x] + b, {a, b}, x]["Function"] & /@ 
  Transpose@
   ParallelTable[{{n, a}, {n, b}} /. 
     FindDistributionParameters[
      Table[Norm@randomWalk[n, dim], {samples}], 
      PERTDistribution[{0, n}, a, b], 
      MapThread[{#1, #2@n} &, {{a, b}, estimates}]], {n, 2, steps}]

This is slightly tricky, but the goal is to fit parameter estimation functions better and better and produce distribution parameter estimation functions which give robustness to EstimatedDistribution in the next step.

ClearAll[estimates];
estimates = 
  Last@NestWhile[
    Apply[{2 #1, 
       distributionEstimates[steps, dims, #1, #2]} &], {100, {Sqrt, 
      Sqrt}}, First@# < 2 samples &];

Here we compute an array of functions providing PDF of random walk covering certain distance. This information is used to drive the actual source-to-destination random walk later on. Distributions for walks of 0 and 1 steps are not computed, because they're both useless for our method, and also too much for EstimatedDistribution to handle.

ClearAll[stepWeightFunctions]; 
stepWeightFunctions[steps_, dim_, samples_, estimates_] := 
 ParallelTable[
  PDF@EstimatedDistribution[Table[Norm@randomWalk[n, dim], {samples}],
     PERTDistribution[{0, n}, a, b], 
    MapThread[{#1, #2@n} &, {{a, b}, estimates}]], {n, 2, steps}]

We compute weights for our case here. These functions could be reused later on.

ClearAll[weightFunctions];
weightFunctions = stepWeightFunctions[steps, dims, samples, estimates];

This is the core of our solution. It simply performs weighted RandomChoice walk form source. Weights are calculated on basis of distance of candidate step from the origin, and amount of steps left.

Two last steps are not computed this way, because last step is always origin, and second-last step lies on intersection of two predetermined spheres. This can't be accomplished with dumb random step candidates.

ClearAll[incompleteWalks];
incompleteWalks = 
  ParallelTable[
   Last /@ NestList[
     Apply[Function[{level, pt}, {level - 1, 
        pt + (RandomChoice[
             weightFunctions[[level - 1]]@Norm[pt + #] & /@ # -> #] &[
           Table[randomWalk[1, dims], {samples}]])}]], {steps - 1, 
      start}, steps - 2], {paths}];

Walks are completed by FindInstance which provides a step that satisfies above constraints. FindInstance isn't really random, but given all the other randomness in this routine, this might be good enough.

ClearAll[completeWalks];
completeWalks = 
 With[{v = Table[Unique[], {dims}]}, #~Join~{v, Table[0, {dims}]} /. 
     FindInstance[Norm[v] == 1 && Norm[v - Last@#] == 1, v, 
      Reals] &] /@ incompleteWalks;

Four resulting walks in 3D:

completeWalks // 
  MapIndexed[{Hue[(First@#2 - 1)/(paths + 1)], 
     Tube@#1} &] // Graphics3D

By setting initial dimension and starting point parameters one can also accomplish 2D random walk (and probably other dimensions too):

completeWalks // 
  MapIndexed[{Hue[(First@#2 - 1)/(paths + 1)], Line@#1} &] // Graphics

---

Old code:

This, rather messy contraption attempts to drive a random walk process from start point over paths to origin in fixed amount of unit-distance steps. I'm not really convinced; I think it's lazy and spends time near the starting point more than it should, and then hurries to destination when indicators become strong enough it is starting to run out of steps to reach origin. Probability distributions which drive RandomChoice are estimated from sample random walks.

With[
   {steps = 50, paths = 4, start = {20, 0, 0}},
   With[
     (* estimated probability functions for every amount of steps left *)
     {p =
       ParallelTable[
        Function[x, 
           Evaluate@
            PDF[EstimatedDistribution[#, 
              PERTDistribution[{0, n}, a, b],
              (* these are here just to speed up estimation *)
              {{a, 0.3407759964445141` + 0.7140058349745467` Sqrt[n]},
               {b, -5.88256361017025` + 5.436462403959963` Sqrt[n]}}],
            x]] &[
         Norm@Total@# & /@ 
          Map[Normalize, 
           RandomVariate[
            NormalDistribution[0, 1], {10000, n, 3}], {2}]],
         {n, 2, steps - 1}]},
     ParallelTable[
      Last /@ NestList[
        Apply[Function[{level, pt},
          {level - 1, 
           pt + (RandomChoice[
                p[[level - 1]]@Norm[pt + #] & /@ # -> #] &[
              Normalize /@ 
               RandomVariate[
                NormalDistribution[0, 1], {10000, 3}]])}]],
         {steps - 1, start}, steps - 2], {paths}]] //
    (* find a suitable second-to-last point *)
    Map[#~Join~{{x, y, z}, {0, 0, 0}} /. 
       FindInstance[
        Norm[{x, y, z}] == 1 && Norm[{x, y, z} - Last@#] == 1,
        {x, y, z}, Reals] &]] // 
  MapIndexed[{Hue[Mod[GoldenRatio #2, 1]], Tube@#1} &] // Graphics3D

Answer 2

Use GridGraph as follows:

g = GridGraph[{5, 6}, VertexLabels -> "Name"]

Then find all paths between two vertexes of a given length. For instance, all paths of length 5 between vertexes 7 and 24 are found this way:

myPathList = FindPath[g, 7, 24, {5}, All]

(* { {7, 12, 17, 22, 23, 24}, {7, 12, 17, 18, 23, 24}, {7, 12, 17, 18, 19, 24}, {7, 12, 13, 18, 23, 24}, {7, 12, 13, 18, 19, 24}, {7, 12, 13, 14, 19, 24}, {7, 8, 13, 18, 23, 24}, {7, 8, 13, 18, 19, 24}, {7, 8, 13, 14, 19, 24}, {7, 8, 9, 14, 19, 24} } *)

You will find that if you search for paths that are sufficiently long, then the path may go "past" the end point and then return to it. There turn out to be 10 such paths. Now display them:

Grid[
     Partition[Table[HighlightGraph[g, myPathList[[i]]],
     {i, Length[myPathList]}], 5]
     ]

This simple rendering just shows the vertexes highlighted. You can use GraphHighlightStyle to show the path more clearly.

The same approach generalizes to different length paths, and to paths in three dimensions, as you can explore on your own.

Here's just one of the found paths, highlighted:

HighlightGraph[g, {7 -> 12, 12 -> 17, 17 -> 22, 22 -> 23, 23 -> 24}]

You may need to create the highlighted path this way for proper display:

Table[
 Rule[myPathList[[1, i]], myPathList[[1, i + 1]]],
 {i, 1, Length[myPathList[[1]]] - 1} ]

(* {7 -> 12, 12 -> 17, 17 -> 22, 22 -> 23, 23 -> 24} *)

Here's a 3D example (where the coding is left to the user):