28
$\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$
5
  • 1
    $\begingroup$ So you want to enumerate all possible Manhattan paths between two lattice points, then… $\endgroup$ Apr 12, 2016 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, 2016 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$ Apr 12, 2016 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, 2016 at 1:38
  • $\begingroup$ The numbre of paths is the problem that started me into programming in my freshman college year. Proper Mathematica function for computing is Multinomial, which lends itself to more dimensions easily. For example, the number of paths along the edges of a n-dimensional hypercube is ({#1, Multinomial @@ ConstantArray[1, #1]} & ) /@ Range[0, 6] and yields {{0, 1}, {1, 1}, {2, 2}, {3, 6}, {4, 24}, {5, 120}, {6, 720}}. $\endgroup$
    – IAmANaïf
    Mar 13 at 20:16

7 Answers 7

26
$\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$
3
  • $\begingroup$ That looks good.. $\endgroup$
    – Sayakiss
    Apr 12, 2016 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$ Apr 12, 2016 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, 2016 at 20:38
23
$\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$
4
  • $\begingroup$ With directed GridGraph you don't need to care about path length. $\endgroup$
    – kirma
    Apr 12, 2016 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, 2016 at 7:23
  • $\begingroup$ Your solution is shorter, though! :) $\endgroup$
    – kirma
    Apr 12, 2016 at 7:41
  • $\begingroup$ @JasonB neat! +1 :) $\endgroup$
    – ubpdqn
    Apr 12, 2016 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$
6
  • $\begingroup$ I would post a screen shot, but imgur is blocked at work. $\endgroup$
    – evanb
    Apr 12, 2016 at 1:50
  • $\begingroup$ It's correct but I think it's not good enough to illustrate... $\endgroup$
    – Sayakiss
    Apr 12, 2016 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, 2016 at 2:17
  • $\begingroup$ In fact, your way of producing permutations inspires me a lot.. Really thanks! $\endgroup$
    – Sayakiss
    Apr 12, 2016 at 2:20
  • $\begingroup$ @evanb Added the output for you, hope you don't mind. :) $\endgroup$ Apr 12, 2016 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$
1
  • $\begingroup$ Ah, I was going to post a GridGraph[] solution when I got home... oh well. +1! $\endgroup$ Apr 12, 2016 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$
4
$\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$
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$

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.