5
$\begingroup$

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

nice graph

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

$\endgroup$

3 Answers 3

6
$\begingroup$
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]]

enter image description here

cbg44 = cbGraph[4, 4];

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

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

enter image description here

$\endgroup$
2
  • 1
    $\begingroup$ you can't imagine how much your code has taught me, huge thanks $\endgroup$
    – sankiago
    Mar 15, 2023 at 15:38
  • $\begingroup$ @sankiago, my pleasure. Welcome to mma.se, $\endgroup$
    – kglr
    Mar 15, 2023 at 15:59
4
$\begingroup$
  • 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]}]

enter image description here

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]

enter image description here

$\endgroup$
2
  • $\begingroup$ I haven't seen your edit, also huge thanks !! $\endgroup$
    – sankiago
    Mar 15, 2023 at 15:40
  • $\begingroup$ m = 5; n = 6; dd = 2; r = {1, 0}; u = {0, 1}; d = {1, 1}; sequences = Permutations@ Join[ConstantArray[r, n - dd], ConstantArray[u, m - dd], ConstantArray[d, dd]]; 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], 2, 1]}]}] $\endgroup$
    – cvgmt
    Mar 31, 2023 at 6:13
3
$\begingroup$
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}]]
$\endgroup$
1
  • $\begingroup$ thanks for the list animate command $\endgroup$
    – sankiago
    Mar 15, 2023 at 15:41

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.