1
$\begingroup$

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]:

my diagram

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?

$\endgroup$
1
$\begingroup$
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.stack.imgur.com/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]]

enter image description here

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"]

enter image description here

| improve this answer | |
$\endgroup$
  • $\begingroup$ wow, i need to go through it, but this looks good! For n=4 you use replace2, is this just replace, or something else? $\endgroup$ – Bipolar Minds May 19 at 11:02

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.