Plot diagonal lattice path

Question

I'd like to plot lattice paths like RUURUD where R is a step to the right, U is a step above and D is a diagonal step. But I have 2 problems

1) The way i'm trying to plot a path (which seems horrible to me) is using Graph[Line[{p1,p2,...pn}]] function. I'm trying to convert the path to points in this way:

LetraMap := <|"R" -> {1,0}, "U" -> {0,1}, "D" ->{1,1} |>;
LetraACoordenada[palabra_,1] := If[KeyExistsQ[LetraMap, StringTake[palabra, 1]],LetraMap[StringTake [palabra,1]],{0,0}]
LetraACoordenada[palabra_, n_] := LetraACoordenada[palabra,n-1] + LetraMap[ StringTake @@{palabra,n} ]

But when I try to define it returns:

SetDelayed: The value for the key palabra_ does not exist

I also tried:

PalabraDiagonalACoordenada = Function[{palabraDiagonal},
coordenadas = {{0,0}}; 
 Do[
     AppendTo[coordenadas,coordenadas[[i]] + LetraACoordenada @ StringTake @@ {palabraDiagonal, i}];
 ,{i,StringLength @ palabraDiagonal}
 ];
 Print["xd"];
 Return[coordenadas];
]

But when I execute

PalabraDiagonalACoordenadas["URUURUD"]

it simply does not returns nothing (I awaited for a long time haha) not even the xd

I dont know what's the error with this functions or if is it a easier/mathematical (like pythonic hahah) way to do this.

2) I'd also like to make a beautiful graph like

and nice animation like

I've tried with https://mathematica.stackexchange.com/a/112411/91847 solution (GridGrpah) but it doesn't connect diagonal lines (it actually make sense because diagonal vertices does not exists).

thanks in advance

Answer 1

ClearAll[cbGraph]
cbGraph[r_, c_, o : OptionsPattern[]] := 
 Module[{v = Tuples[Range /@ {r, c}]}, 
  RelationGraph[ChessboardDistance[##] == 1 && (And @@ Thread[# <= #2]) &,
   v, o, VertexCoordinates -> v]]

Examples:

Row[{cbGraph[4, 4, ImageSize -> Medium], 
  cbGraph[7, 4, ImageSize -> Medium], 
  cbGraph[7, 7, ImageSize -> Medium]}, Spacer[10]]

cbg44 = cbGraph[4, 4];

allpaths = BlockMap[Apply@DirectedEdge, #, 2, 1] & /@ 
   FindPath[cbg44, {1, 1}, {4, 4}, Infinity, All];

HighlightGraph[cbg44, #] & /@ allpaths // Multicolumn[#, 7] &

Answer 2

• A starting point.

r = {1, 0}; u = {0, 1}; d = {1, 1};
m = 5; n = 6;
grid = Show[GridGraph[{m + 1, n + 1}]][[1]];
sequence = {r, u, r, u, d, u, d, r, r};
Graphics[{grid, Red, 
  Arrow@Partition[FoldList[Plus, {1, 1}, sequence], 2, 1]}]

Edit

• dd is the number of diagonal, where0<=d<=Min[m,n]. At first we select dd elements from the m - dd + n - dd + dd set, then we select m-dd elements in the rest, and there are remain n-dd elements. So the number of such paths is

Binomial[m - dd + n - dd + dd, dd]*Binomial[m - dd + n - dd, m - dd]

and the number of all of the paths is

Table[Binomial[m - dd + n - dd + dd, dd]*
   Binomial[m - dd + n - dd, m - dd], {dd, 0, Min[m, n]}] // Total

Clear["Global`*"];
(*dd is the number of diagonal*)
m = 5; n = 6; dd = 2;
subset[set_, dd_] := 
  Thread[{Subsets[set, {dd}], 
    Complement[set, #] & /@ Subsets[set, {dd}]}];
set = Range[m - dd + n - dd + dd];
partition = 
  Flatten[subset[#, m - dd] & /@ subset[set, dd][[;; , 2]], {2, 1}];
sequences = 
  ReplacePart[
     ConstantArray[d, m - dd + n - dd + dd], {List /@ First[#] -> u, 
      List /@ Last[#] -> r}] & /@ partition;
rules = {r -> {1, 0}, u -> {0, 1}, d -> {1, 1}};
sequence = RandomChoice[sequences];
Graphics[{Show[GridGraph[{m + 1, n + 1}]][[1]], AbsoluteThickness[3], 
  Thread[{sequence /. {r -> Green, u -> Blue, d -> Red}, 
    Arrow /@ 
     Partition[FoldList[Plus, {1, 1}, sequence /. rules], 2, 1]}]}]

Length[sequences] == 
 Binomial[m - dd + n - dd + dd, dd]*Binomial[m - dd + n - dd, m - dd]

True

ListAnimate[
 Table[Graphics[{Show[GridGraph[{m + 1, n + 1}]][[1]], 
    AbsoluteThickness[3], 
    Thread[{sequence /. {r -> Green, u -> Blue, d -> Red}, 
      Arrow /@ 
       Partition[FoldList[Plus, {1, 1}, sequence /. rules], 2, 
        1]}]}], {sequence, RandomChoice[sequences, 20]}], 
 AnimationRate -> 1]

Answer 3

g = EdgeAdd[
   GridGraph[{4, 4}], 
  {1 \[UndirectedEdge] 6, 2 \[UndirectedEdge] 7, 
   3 \[UndirectedEdge] 8, 5 \[UndirectedEdge] 10, 
   6 \[UndirectedEdge] 11, 7 \[UndirectedEdge] 12, 
   9 \[UndirectedEdge] 14, 10 \[UndirectedEdge] 15, 
   11 \[UndirectedEdge] 16}];

ListAnimate[
 HighlightGraph[g, #] & /@ 
  Map[#[[1]] -> #[[2]] &, (Partition[#, 2, 1] & /@ 
     FindPath[g, 1, 16, {3, 6}, All]), {2}]]