Drawing Delannoy paths

Question

I want to take the code for a Wolfram Demonstration for a Delannoy number and make a function that can return a list of Delannoy plots. The code is available from the download link. The demonstration is available on the Wolfram Demonstrations Project and is optimized for desktops. How can I make a function DelannoyNumberPlot that reproduces the graphic on Wikipedia?

A good first step is to use RandomChoice but you would have to discard sets of paths that don't reach the corner. There is the constraint of reaching the corner (usually in two dimensions) with north, east, or northeast movements.

There is plenty of material on the enumeration of Delannoy numbers, but I don't think there is much material out there on the construction of sets of Delannoy numbers. I also would maybe like to make a function RandomDelannoyPlot that would randomly select a Delannoy graph plot.

When there are too many Delannoy plots to list all of them, you could use RandomDelannoyPlot[n] to get a sample. I would like to just generate as many random plots as the user asks for, instead of taking a random sample of all the Delannoy plots for a given input. For example, RandomPermutation could be used.

Answer 1

randomDGraph

ClearAll[randomDGraph]

randomDGraph[{r_, c_}] := GridGraph[{r, c}, 
   Epilog -> {Thick, Red, Line @ 
      NestWhileList[MapThread[Clip]@
       {# + RandomChoice[{{0, 1}, {1, 0}, {1, 1}}], {{1, c}, {1,  r}}} &, 
       {1, 1}, (# =!= {c, r} &)]}]

randomDGraph[{r_, c_}, n_Integer] := Table[randomDGraph[{r, c}], n]

Examples:

SeedRandom[1];

randomDGraph[{4, 4}, 10] // Row

randomDGraph[{5, 4}, 10] // Row

"How can I make a function DelannoyNumberPlot that reproduces the graphic on Wikipedia?"

ClearAll[upRightKingGraph]

upRightKingGraph = 
  Module[{vc = Tuples[Range @ {#2, #}]}, 
    RelationGraph[
     ChessboardDistance[##] == 1 && Apply[And]@Thread[# <= #2] &, vc, 
     VertexCoordinates -> vc, ##3, VertexLabels -> None]] &;

upRightKingGraph[3, 3, VertexLabels -> Automatic]

ClearAll[upRightPaths]


upRightPaths = FindPath[upRightKingGraph[##], {1, 1}, {#2,#}, Infinity, All] &;

Length @ upRightPaths[4, 4]

63

ClearAll[dPathsPlot]

dPathsPlot = Module[{pr = Thread[{1, {#2, #}}], 
     paths = upRightPaths[#, #2], 
     gridlines = Range@{#2, #}, ar = #/#2, opts = {##3}}, 
    Map[ListLinePlot[#, PlotRange -> pr, GridLines -> gridlines, 
        AspectRatio -> ar, opts, Axes -> False, 
        PlotStyle -> Directive[Red, Thick], 
        PlotRangePadding -> Scaled[.01], 
        PlotRangeClipping -> False, 
        ImageSize -> 100] &] @ paths] &;

Multicolumn[dPathsPlot[4, 4, ImageSize -> 40], 9]

Multicolumn[dPathsPlot[5, 4, ImageSize -> 40], 12]

Answer 2

• We set r={1,0} be the right direction, u={0,1} be the upper direction and d={1,1} be the diogonal direction.

• for m*n grid, when we set dd be the number of diogonals,then the number of r is m-dd and the number of u is n-dd, here 0<=dd<=Min[m,n].

• We can use Permutations to find all the permutations of the repeatable arrangements.

Clear["Global`*"];
m = 3;
n = 3;
dd = 2;
list=Permutations@
 Join[ConstantArray[r, n - dd], ConstantArray[u, m - dd], 
  ConstantArray[d, dd]]

• graphics.

Graphics[{Show[GridGraph[{m + 1, n + 1}]][[1]], AbsoluteThickness[3], 
    Thread[{# /. {r -> Green, u -> Blue, d -> Red}, 
      Arrow /@ 
       Partition[
        FoldList[
         Plus, {1, 1}, # /. {r -> {1, 0}, u -> {0, 1}, d -> {1, 1}}], 
        2, 1]}]}] & /@ list

• graphics for all of the dd where 0<=dd<=Min[m,n]

delannoyNumber[m_, n_] := Module[{list, r, u, d},
  list = 
   Flatten[Table[
     Permutations@
      Join[ConstantArray[r, n - dd], ConstantArray[u, m - dd], 
       ConstantArray[d, dd]], {dd, 0, Min[m, n]}], 1];
  Graphics[{Show[GridGraph[{m + 1, n + 1}]][[1]], 
      AbsoluteThickness[3], 
      Thread[{# /. {r -> Green, u -> Blue, d -> Red}, 
        Arrow /@ 
         Partition[
          FoldList[
           Plus, {1, 
            1}, # /. {r -> {1, 0}, u -> {0, 1}, d -> {1, 1}}], 2, 
          1]}]}, ImageSize -> Tiny] & /@ list]
delannoyNumber[3, 3]

Edit:randomDelannoyPlot.

Clear[randomDelannoyPlot];
randomDelannoyPlot[m_, n_] := 
 Module[{r, u, d, dd, result}, dd = RandomInteger[{0, Min[m, n]}];
  result = 
   RandomSample[
    Join[ConstantArray[r, m - dd], ConstantArray[u, n - dd], 
     ConstantArray[d, dd]], m + n - dd];
  Graphics[{Show[GridGraph[{n + 1, m + 1}]][[1]], Arrowheads[Medium], 
    AbsoluteThickness[1], 
    Thread[{result /. {r -> Green, u -> Blue, d -> Red}, 
      Arrow /@ 
       Partition[
        FoldList[Plus, {1, 1}, 
         result /. {r -> {1, 0}, u -> {0, 1}, d -> {1, 1}}], 2, 1]}]}]]
randomDelannoyPlot[20, 15]