26
$\begingroup$

Now I can draw some grid:

enter image description here

But what I want(I'm sorry for the weird line. I have no image processing software in my mac...):

enter image description here

Please notice:

f(1, 1) = f(2, 1) = f(3, 1) = 1
f(1, 1) = f(1, 2) = f(1, 3) = 1 
f(2, 2) = f(1, 2) + f(2, 1) = 2 
f(3, 3) = f(3, 2) + f(2, 3) = 2*(f(2, 2) + f(1, 2)) = 2*3 = 6

So there is 6 paths from (1,1) to (n,n) by two possible moves: (+1,0), (0, +1).

My question is, how to draw all paths into the grid with different color or different label?

I know the number of paths may be very large when n grows and I just want to make a nice illustration about that problem. So you can assume n <= 5.

$\endgroup$
  • 1
    $\begingroup$ So you want to enumerate all possible Manhattan paths between two lattice points, then… $\endgroup$ – J. M. will be back soon Apr 12 '16 at 1:27
  • $\begingroup$ @J.M. You are right. I just want to make a nice illustration about that problem, so I won't draw a very large one...(You may assume n <= 5..) $\endgroup$ – Sayakiss Apr 12 '16 at 1:29
  • $\begingroup$ It might actually be more convenient to start at $(0,0)$ instead, but of course a translation will take care of it if you really want $(1,1)$ as the origin. $\endgroup$ – J. M. will be back soon Apr 12 '16 at 1:35
  • $\begingroup$ @J.M. Both start at (0, 0) and (1, 1) is OK, since the output(the illustration) remains the same. $\endgroup$ – Sayakiss Apr 12 '16 at 1:38
25
$\begingroup$

Stealing half of evanb's answer we could do:

With[{n = 3}, Graphics[{
   LightGray, Disk[#, 0.5] & /@ Flatten[Table[{i, j}, {i, 0, n}, {j, 0, n}], 1],
   Thick, Module[{m, paths = Sort@Permutations[Join @@ ({{0, 1}, {1, 0}} & /@ Range[n])]},
    m = Length@paths; 
    Table[{Hue[(i - 1)/(m - 1)], Line@FoldList[Plus, 
        1/(2 Sqrt[2]) {-1 + (2 (-1 + i))/(-1 + m), 
          1 - (2 (-1 + i))/(-1 + m)}, paths[[i]]]}, {i, m}]
    ]}]]

1

$\endgroup$
  • $\begingroup$ That looks good.. $\endgroup$ – Sayakiss Apr 12 '16 at 3:25
  • 1
    $\begingroup$ With a few simplifications: With[{n = 3}, Graphics[{LightGray, Array[Disk[{##}, 1/2] &, {n + 1, n + 1}, {0, 0}], Thick, With[{m = Binomial[2 n, n]}, MapIndexed[{ColorData[97] @@ #2, Line[FoldList[Plus, Rescale[Join[#2, m - #2 + 1], {1, m}, {-1, 1}]/(2 Sqrt[2]), #1]]} &, Sort[Permutations[Join @@ Table[IdentityMatrix[2], {n}]]]]]}]] $\endgroup$ – J. M. will be back soon Apr 12 '16 at 16:56
  • $\begingroup$ @J.M. Thanks, it was a bit of an ugly rush job (which seems to have blown up overnight). If anyone is feeling really sassy, they could sort out the crossovers on the top right. $\endgroup$ – wxffles Apr 12 '16 at 20:38
4
$\begingroup$

This can be solved using Permutations[], Accumulate[] and the graphics commands.

Letting, for simplicity,

rep = {{1, 0} -> x, {0, 1} -> y};

The list of all paths is given simply by all different step sequences

stepsequs[n_] := Permutations[Join[Array[x &, n], Array[y &, n]]]

Example

stepsequs[3]

(* Output suppressed *)

The number of paths is obviously given by

nPaths[n_] := Binomial[2 n, n]

checking some values: ok

Table[{nPaths[n], Binomial[2 n, n]}, {n, 1, 5}]

(* Out[179]= {{2, 2}, {6, 6}, {20, 20}, {70, 70}, {252, 252}} *)

The graphical representation can be done in a primitive form like this

First, we add the start Point, and we do this with a random shift (in order to be able to distinguish different paths, which works only to a certain degree, I admit)

r := RandomReal[]/10

sequ[n_] := Join[{{r, r}}, #] & /@ stepsequs[n] /. {x -> {1, 0}, y -> {0, 1}}

The lines to be drawn are generated from the step sequence using Accumulate[]

Putting things together we arrive at

With[{n = 3}, Show[Graphics[Line[Accumulate /@ sequ[n]]]]]

enter image description here

Remark: my graphis abilities are very limited. Others have provided nice pictures already.

$\endgroup$
3
$\begingroup$

So, paths can be found by traversing a grid graph. But also, they can be stacked in a 3D graphic.

paths[rows_, cols_] := FindPath[
  GridGraph[{rows, cols}], 1, rows*cols,
  ManhattanDistance[{1, 1}, {rows, cols}] + 1, All]

This has the advantage of rotating the stack and looking at it from different view points.

draw3D[rows_, cols_, options___] :=
 Module[{lines, hues},
  lines = Module[{z = 0},
    paths[rows, cols] /. path : {__Integer} :> (z += 1; Line[
        {Quotient[#, rows, 1], Mod[#, rows, 1], z} & /@ path])];
  hues = ColorData["Rainbow"] /@ Rescale[Range@Length@lines];
  Graphics3D[{Thick, JoinForm["Round"], Transpose[{hues, lines}]},
   options,
   ImageSize -> Small,
   BoxRatios -> {cols, rows, Min[cols, rows]},
   Boxed -> False]]

draw3D[4, 3, SphericalRegion -> True]

enter image description here

$\endgroup$
20
$\begingroup$

You can use the Graph capabilities to solve this problem. First, note that every path from $(1,1)$ to $(n,n)$ has $2n-2$ moves, so it is just a matter of using FindPath with GridGraph

n = 3;
g = GridGraph[{n, n}, VertexLabels -> "Name"]
FindPath[g, 1, n n, {2 n - 2}, All] /. 
 Thread[Range[n n] -> GraphEmbedding[g]]

enter image description here

You can visualize all the paths with PathGraph,

With[{n = 4},
 g = GridGraph[{n, n}];
 HighlightGraph[g, PathGraph@#] & /@ 
  FindPath[g, 1, n n, {2 n - 2}, All]]

enter image description here

ListAnimate@%

enter image description here

Edit

Here is a method, less simple than above, but still distinctly different from kirma's answer, that answer's OP's request to draw all of the paths together in a manner in which they are all visible.

gridpaths[n_] := Module[{g, coords, paths},
  g = GridGraph[{n, n}, EdgeStyle -> Opacity[0]];

  coords[offs_] := Thread[Range@(n n) -> (offs + GraphEmbedding@g)];
  paths = FindPath[g, 1, n n, 2 n - 2, All];
  Show[
   PathGraph[#1,
      VertexCoordinates -> #1 /. coords[#3],
      EdgeStyle -> Directive[Thick, #2],
      VertexSize -> 0] & @@@ 
   Transpose[{paths,
      ColorData[97] /@ Ordering@paths,
      Subdivide[-.3, .3, Length@paths - 1]}]}],
   GridLines -> {#, #} &@Range[0.5, n + .5, 1],
   PlotRange -> {{.5, n + .5}, {.5, n + .5}}
   ]
  ]

It can be tested via

gridpaths /@ Range[2, 7]

enter image description here

$\endgroup$
  • $\begingroup$ With directed GridGraph you don't need to care about path length. $\endgroup$ – kirma Apr 12 '16 at 7:15
  • $\begingroup$ @kirma - Thanks, I'm new to Graphs. BTW, I wrote this before fully reading the question or all the answers, so I'm now aware that you already covered the FindPath solution, just leaving this since it's so short. And I'm now aware that yours is so much longer since you went through the trouble of reading and answering the actual question (showing all the paths in a nice fashion). $\endgroup$ – Jason B. Apr 12 '16 at 7:23
  • $\begingroup$ Your solution is shorter, though! :) $\endgroup$ – kirma Apr 12 '16 at 7:41
  • $\begingroup$ @JasonB neat! +1 :) $\endgroup$ – ubpdqn Apr 12 '16 at 9:13
18
$\begingroup$

You could try something like this:

Show[Graphics[{RandomColor[], Line[#]}] & /@ ( (* Make graphics of *)
FoldList[Plus, RandomReal[{0, 0.1}, 2] + {0, 0}, #] & /@ (* Trajectories built from *)
Permutations[ (* All possible orderings of *)
    Join @@ ({{0, 1}, {1, 0}} & /@ Range[5]) (* Five steps N and five steps E*)
   ]
)]

The RandomReal[{0,0.1},2] is a random near-the-origin starting location, just to offset the different lines from one another visually.

enter image description here

$\endgroup$
  • $\begingroup$ I would post a screen shot, but imgur is blocked at work. $\endgroup$ – evanb Apr 12 '16 at 1:50
  • $\begingroup$ It's correct but I think it's not good enough to illustrate... $\endgroup$ – Sayakiss Apr 12 '16 at 1:59
  • $\begingroup$ Well, if you don't do the outer-most Show, it will produce 252 images, from which you can pick and choose. $\endgroup$ – evanb Apr 12 '16 at 2:17
  • $\begingroup$ In fact, your way of producing permutations inspires me a lot.. Really thanks! $\endgroup$ – Sayakiss Apr 12 '16 at 2:20
  • $\begingroup$ @evanb Added the output for you, hope you don't mind. :) $\endgroup$ – Martin Ender Apr 12 '16 at 8:11
14
$\begingroup$

A solution just to show Solve can also be used directly on basis of the problem specification:

With[{max = 4},
  With[{coords = Table[{x[n], y[n]}, {n, 2 max - 1}]},
    coords /. Solve[
       (* the first and last points *)
       {x[1] == y[1] == 1,
        x[2 max - 1] == y[2 max - 1] == max, 
        (* intermediate constrained steps *)
        Sequence @@ Table[
          x[n + 1] == x[n] + 1 && y[n + 1] == y[n] || 
           x[n + 1] == x[n] && y[n + 1] == y[n] + 1,
          {n, 2 max - 2}]}, 
      Flatten@coords]] // 
  (* the rest is just formatting output *)
  Function[sols, 
     MapIndexed[#1 + 
        Table[{1/2, -1/2} + {-1, 1} First@#2/Length@sols, Length@#] &, 
      sols]] // ListLinePlot[#, AspectRatio -> Automatic] &]

enter image description here

Another solution finding all paths on a directed GridGraph, giving the same result:

With[{max = 4}, 
 With[{g = 
      VertexReplace[GridGraph[{max, max}, DirectedEdges -> True],
       (* convert vertex numbers to coordinates, 
          working around what seems like a pattern matching bug... *)
       Flatten@Table[
         FromDigits[{x, y} - {1, 1}, max] + 1 -> {x, y},
          {x, max}, {y, max}]]},
    (* find all paths in a directed grid graph *)
    FindPath[g, {1, 1}, {max, max}, \[Infinity], All]] //
   (* the rest is just formatting output *)
   Function[sols, 
    MapIndexed[#1 + 
       Table[{1/2, -1/2} + {-1, 1} First@#2/Length@sols, Length@#] &, 
     sols]] // ListLinePlot[#, AspectRatio -> Automatic] &]
$\endgroup$
  • $\begingroup$ Ah, I was going to post a GridGraph[] solution when I got home... oh well. +1! $\endgroup$ – J. M. will be back soon Apr 12 '16 at 6:23
12
$\begingroup$
g[n_] := Module[{tup = Tuples[{{1, 0}, {0, 1}}, 2 n]},
   Pick[tup, Total[#] == {n, n} & /@ tup]];
fun[n_] := 
 With[{r = Accumulate /@ (Join[{{1/2, 1/2}}, #] & /@ g[n])}, 
  Join @@ MapIndexed[ 
    Panel[#1, ToString[#2[[1]]] <> " of " <> ToString[Length@r]] &,
    Table[ListPlot[#[[1 ;; j]], Joined -> True, AxesOrigin -> {0, 0},
        PlotStyle -> {Red, Thick},
        PlotRange -> Table[{0, n + 1}, {2}], 
        GridLines -> {Range[0, n], Range[0, n]}, Frame -> True, 
        FrameTicks -> None, AspectRatio -> Automatic], {j, 1, 
        2 n + 1}] & /@ r, {2}]]

The animation is not efficient. Others will doubt have better ways. I only illustrate paths from {1,1} (lower left hand corner) to {4,4}.

dat = fun[3];

enter image description here

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