Defining a directed graph with labeled edges step-by-step

Question

Let n be a positive integer. I would like to define a directed graph gr[n_,a_,b_] (actually a bounded poset) as follows:

1. Level 0: we start with a vertex labeled by the list {1,2,1,3,2,1,...,n,n-1,...,1} (denoted by g for greatest element)
2. Level 1: we add vertices again labeled by lists of length ${n+1 \choose 2}$ that are created from g in two different ways:
   • for every consecutive sequence in g of the form k,k+1,k we add a vertex labeled again by g, except that we substitute the sequence k,k+1,k by k+1,k,k+1. We attach the vertex g to every of the added vertices with a directed edge and label all of these edges with a.
   • for every consecutive sequence in g of the form k,l with |k-l|>1 we add a vertex labeled again by g, except that that we substitute the sequence k,l by l,k. We attach the vertex g to every of the added vertices with a directed edge and label all of these edges with b. It is forbidden to resubstitute l,k with k,l again in the next level (and only in the next level) otherwise this algorithm wouldn't terminate.
3. we iterate the procedure until we reach the last level with exactly one vertex with label {n,n-1,n-2,...,1,...n,n-1,n-2,n,n-1,n} (the least element in the poset)

As an example, I drew a picture of gr[3,a,b]:

Actually, the graph itself is not important to me, I only need an output in the end from which I can extract the information how many a's and b's are on the path from g to every other vertex v.

Of course, I don't expect you to give me a full solution to this problem. For starters I would just like to know if you think this is realizable in Mathematica and maybe a suggestion what kind of Mathematica functions is typically used for these type of problems. In particular, how to define a directed graph with labeled edges and vertices in a step-by-step way?

Answer 1

ClearAll[jrl, rulea, ruleb, replace]
rulea = {beg___, a_, b_, a_, end___} /; b == a + 1 :> {beg, b, a, b, end};
ruleb = {beg___, a_, b_, end___} /; Abs[a - b] > 1 :> {beg, b, a, end};
jrl = Apply[Join]@*Map[ReplaceList[{rulea, ruleb}]];
replace = DirectedEdge[first_, last_] :> (DirectedEdge[last, #] & /@ 
    (DeleteCases[first][jrl@{last}]));

n = 3;
g0 = Flatten[Reverse /@ Range[Range[n]]];

edges = DeleteDuplicatesBy[Sort]@
   Rest[Flatten@NestList[# /. replace &, {DirectedEdge[0, g0]}, 2^n]];

img = Import["https://i.sstatic.net/71vmI.png"];

Row[{Graph[edges, VertexShapeFunction -> (Text[Style[FromDigits@#2, 12, Black], #] &), 
      ImageSize -> Medium, 
      EdgeLabels -> {e_ :> If[MemberQ[ReplaceList[rulea]@e[[1]], e[[2]]], 
       Framed[Style["a", 12], FrameStyle -> None, Background -> White], 
       Framed[Style["b", 12], FrameStyle -> None, Background -> White]]}, 
      PerformanceGoal -> "Quality", 
      GraphLayout -> "LayeredDigraphEmbedding"], 
  Show[img, ImageSize -> Medium]}, Spacer[10]]

For n = 4 this is painfully slow.

n = 4;
g0 = Flatten[Reverse /@ Range[Range[n]]];

edges = DeleteDuplicatesBy[Sort]@Rest[Flatten@
     NestList[# /. replace &, {DirectedEdge[0, g0]}, 2^4]];

Graph[edges, 
 VertexShapeFunction -> (Text[Style[FromDigits@#2, 8, Black], #] &), 
 ImageSize -> 900, AspectRatio -> 1, 
 EdgeLabels -> {e_ :> If[MemberQ[ReplaceList[rulea]@e[[1]], e[[2]]], 
     Framed[Style["a", 8], FrameStyle -> None, Background -> White], 
     Framed[Style["b", 8], FrameStyle -> None, Background -> White]]},
  PerformanceGoal -> "Speed"]