Skip to main content
Mathematica

Return to Answer

added 2036 characters in body
Source Link
Jean-Pierre
Jean-Pierre
  • 5.2k
  • 9
  • 15

We can verify this with a Euler tour of our 15 trees using DepthFirstScan[], which will recover the stirling permutations:

ggg = {{{0 \[UndirectedEdge] 1, 1}, {0 \[UndirectedEdge] 2, 
     2}, {0 \[UndirectedEdge] 3, 3}}, {{0 \[UndirectedEdge] 1, 
     1}, {0 \[UndirectedEdge] 3, 3}, {0 \[UndirectedEdge] 2, 
     2}}, {{0 \[UndirectedEdge] 3, 3}, {0 \[UndirectedEdge] 1, 
     1}, {0 \[UndirectedEdge] 2, 2}}, {{0 \[UndirectedEdge] 1, 
     1}, {0 \[UndirectedEdge] 2, 2}, {1 \[UndirectedEdge] 3, 
     3}}, {{0 \[UndirectedEdge] 1, 1}, {0 \[UndirectedEdge] 2, 
     2}, {2 \[UndirectedEdge] 3, 3}},
   
   {{0 \[UndirectedEdge] 2, 2}, {0 \[UndirectedEdge] 1, 
     1}, {0 \[UndirectedEdge] 3, 3}}, {{0 \[UndirectedEdge] 2, 
     2}, {0 \[UndirectedEdge] 3, 3}, {0 \[UndirectedEdge] 1, 
     1}}, {{0 \[UndirectedEdge] 3, 3}, {0 \[UndirectedEdge] 2, 
     2}, {0 \[UndirectedEdge] 1, 1}}, {{0 \[UndirectedEdge] 2, 
     2}, {0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 3, 
     3}}, {{0 \[UndirectedEdge] 2, 2}, {0 \[UndirectedEdge] 1, 
     1}, {2 \[UndirectedEdge] 3, 3}},
   
   {{0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 2, 
     2}, {0 \[UndirectedEdge] 3, 3}}, {{0 \[UndirectedEdge] 3, 
     3}, {0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 2, 
     2}}, {{0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 3, 
     3}, {1 \[UndirectedEdge] 2, 2}}, {{0 \[UndirectedEdge] 1, 
     1}, {1 \[UndirectedEdge] 2, 2}, {1 \[UndirectedEdge] 3, 
     3}}, {{0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 2, 
     2}, {2 \[UndirectedEdge] 3, 3}}};
ggg2 = ggg /. {a_ \[UndirectedEdge] b_, c_} :> 
    Labeled[a \[UndirectedEdge] b, c];
list = {};
Map[DepthFirstScan[#, 
    0, {"PrevisitVertex" -> (If[# != 0, AppendTo[list, #], 
         AppendTo[list, "\n"]] &), 
     "PostvisitVertex" -> (If[# != 0, AppendTo[list, #], 
         AppendTo[list, " "]] &)}] &, ggg2];
Row[list]

enter image description here

We can verify this with a Euler tour of our 15 trees using DepthFirstScan[], which will recover the stirling permutations:

ggg = {{{0 \[UndirectedEdge] 1, 1}, {0 \[UndirectedEdge] 2, 
     2}, {0 \[UndirectedEdge] 3, 3}}, {{0 \[UndirectedEdge] 1, 
     1}, {0 \[UndirectedEdge] 3, 3}, {0 \[UndirectedEdge] 2, 
     2}}, {{0 \[UndirectedEdge] 3, 3}, {0 \[UndirectedEdge] 1, 
     1}, {0 \[UndirectedEdge] 2, 2}}, {{0 \[UndirectedEdge] 1, 
     1}, {0 \[UndirectedEdge] 2, 2}, {1 \[UndirectedEdge] 3, 
     3}}, {{0 \[UndirectedEdge] 1, 1}, {0 \[UndirectedEdge] 2, 
     2}, {2 \[UndirectedEdge] 3, 3}},
   
   {{0 \[UndirectedEdge] 2, 2}, {0 \[UndirectedEdge] 1, 
     1}, {0 \[UndirectedEdge] 3, 3}}, {{0 \[UndirectedEdge] 2, 
     2}, {0 \[UndirectedEdge] 3, 3}, {0 \[UndirectedEdge] 1, 
     1}}, {{0 \[UndirectedEdge] 3, 3}, {0 \[UndirectedEdge] 2, 
     2}, {0 \[UndirectedEdge] 1, 1}}, {{0 \[UndirectedEdge] 2, 
     2}, {0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 3, 
     3}}, {{0 \[UndirectedEdge] 2, 2}, {0 \[UndirectedEdge] 1, 
     1}, {2 \[UndirectedEdge] 3, 3}},
   
   {{0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 2, 
     2}, {0 \[UndirectedEdge] 3, 3}}, {{0 \[UndirectedEdge] 3, 
     3}, {0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 2, 
     2}}, {{0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 3, 
     3}, {1 \[UndirectedEdge] 2, 2}}, {{0 \[UndirectedEdge] 1, 
     1}, {1 \[UndirectedEdge] 2, 2}, {1 \[UndirectedEdge] 3, 
     3}}, {{0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 2, 
     2}, {2 \[UndirectedEdge] 3, 3}}};
ggg2 = ggg /. {a_ \[UndirectedEdge] b_, c_} :> 
    Labeled[a \[UndirectedEdge] b, c];
list = {};
Map[DepthFirstScan[#, 
    0, {"PrevisitVertex" -> (If[# != 0, AppendTo[list, #], 
         AppendTo[list, "\n"]] &), 
     "PostvisitVertex" -> (If[# != 0, AppendTo[list, #], 
         AppendTo[list, " "]] &)}] &, ggg2];
Row[list]

enter image description here

added 3280 characters in body
Source Link
Jean-Pierre
Jean-Pierre
  • 5.2k
  • 9
  • 15

Question 2: Regarding the second question, we can derive the list of Strirling permutations from an Euler tour of the list of all possible plane oriented trees, without having to call a strirling function. This requires adding nodes one at a time, tracking all possible position about its location. The left to right order of child nodes is significant. I will do this manually.

The first edge:

GraphPlot[{{0 \[UndirectedEdge] 1, 1}}, 
 GraphLayout -> {"LayeredEmbedding", "RootVertex" -> 0}, 
 EdgeLabelStyle -> Directive[Blue, Bold, 20], ImageSize -> Tiny]

enter image description here

The second edge: 3 different ways to add it to the first edge. The Euler tour of these correspond to stirlingPermutaion[2].

Row[Map[GraphPlot[#, 
    GraphLayout -> {"LayeredEmbedding", "RootVertex" -> 0}, 
    EdgeLabelStyle -> 
     Directive[Blue, Bold, 20]] &, {{{0 \[UndirectedEdge] 1, 
     1}, {0 \[UndirectedEdge] 2, 2}}, {{0 \[UndirectedEdge] 2, 
     2}, {0 \[UndirectedEdge] 1, 1}}, {{0 \[UndirectedEdge] 1, 
     1}, {1 \[UndirectedEdge] 2, 2}}}], Spacer[10]]

enter image description here

The third edge: 15 different ways to add it to either the first or second edge. Each row in the grid below is derived from one of the three trees obtained above for the second edge.The Euler tour of these correspond to stirlingPermutaion[3].

Grid[Partition[
  Map[GraphPlot[#, 
     GraphLayout -> {"LayeredEmbedding", "RootVertex" -> 0}, 
     EdgeLabelStyle -> 
      Directive[Blue, Bold, 20]] &, {{{0 \[UndirectedEdge] 1, 
      1}, {0 \[UndirectedEdge] 2, 2}, {0 \[UndirectedEdge] 3, 
      3}}, {{0 \[UndirectedEdge] 1, 1}, {0 \[UndirectedEdge] 3, 
      3}, {0 \[UndirectedEdge] 2, 2}}, {{0 \[UndirectedEdge] 3, 
      3}, {0 \[UndirectedEdge] 1, 1}, {0 \[UndirectedEdge] 2, 
      2}}, {{0 \[UndirectedEdge] 1, 1}, {0 \[UndirectedEdge] 2, 
      2}, {1 \[UndirectedEdge] 3, 3}}, {{0 \[UndirectedEdge] 1, 
      1}, {0 \[UndirectedEdge] 2, 2}, {2 \[UndirectedEdge] 3, 3}},
    
    {{0 \[UndirectedEdge] 2, 2}, {0 \[UndirectedEdge] 1, 
      1}, {0 \[UndirectedEdge] 3, 3}}, {{0 \[UndirectedEdge] 2, 
      2}, {0 \[UndirectedEdge] 3, 3}, {0 \[UndirectedEdge] 1, 
      1}}, {{0 \[UndirectedEdge] 3, 3}, {0 \[UndirectedEdge] 2, 
      2}, {0 \[UndirectedEdge] 1, 1}}, {{0 \[UndirectedEdge] 2, 
      2}, {0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 3, 
      3}}, {{0 \[UndirectedEdge] 2, 2}, {0 \[UndirectedEdge] 1, 
      1}, {2 \[UndirectedEdge] 3, 3}},
    
    {{0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 2, 
      2}, {0 \[UndirectedEdge] 3, 3}}, {{0 \[UndirectedEdge] 3, 
      3}, {0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 2, 
      2}}, {{0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 3, 
      3}, {1 \[UndirectedEdge] 2, 2}}, {{0 \[UndirectedEdge] 1, 
      1}, {1 \[UndirectedEdge] 2, 2}, {1 \[UndirectedEdge] 3, 
      3}}, {{0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 2, 
      2}, {2 \[UndirectedEdge] 3, 3}}}], 5], Frame -> All

enter image description here

Question 2: Regarding the second question, we can derive the list of Strirling permutations from an Euler tour of the list of all possible plane oriented trees, without having to call a strirling function. This requires adding nodes one at a time, tracking all possible position about its location. The left to right order of child nodes is significant. I will do this manually.

The first edge:

GraphPlot[{{0 \[UndirectedEdge] 1, 1}}, 
 GraphLayout -> {"LayeredEmbedding", "RootVertex" -> 0}, 
 EdgeLabelStyle -> Directive[Blue, Bold, 20], ImageSize -> Tiny]

enter image description here

The second edge: 3 different ways to add it to the first edge. The Euler tour of these correspond to stirlingPermutaion[2].

Row[Map[GraphPlot[#, 
    GraphLayout -> {"LayeredEmbedding", "RootVertex" -> 0}, 
    EdgeLabelStyle -> 
     Directive[Blue, Bold, 20]] &, {{{0 \[UndirectedEdge] 1, 
     1}, {0 \[UndirectedEdge] 2, 2}}, {{0 \[UndirectedEdge] 2, 
     2}, {0 \[UndirectedEdge] 1, 1}}, {{0 \[UndirectedEdge] 1, 
     1}, {1 \[UndirectedEdge] 2, 2}}}], Spacer[10]]

enter image description here

The third edge: 15 different ways to add it to either the first or second edge. Each row in the grid below is derived from one of the three trees obtained above for the second edge.The Euler tour of these correspond to stirlingPermutaion[3].

Grid[Partition[
  Map[GraphPlot[#, 
     GraphLayout -> {"LayeredEmbedding", "RootVertex" -> 0}, 
     EdgeLabelStyle -> 
      Directive[Blue, Bold, 20]] &, {{{0 \[UndirectedEdge] 1, 
      1}, {0 \[UndirectedEdge] 2, 2}, {0 \[UndirectedEdge] 3, 
      3}}, {{0 \[UndirectedEdge] 1, 1}, {0 \[UndirectedEdge] 3, 
      3}, {0 \[UndirectedEdge] 2, 2}}, {{0 \[UndirectedEdge] 3, 
      3}, {0 \[UndirectedEdge] 1, 1}, {0 \[UndirectedEdge] 2, 
      2}}, {{0 \[UndirectedEdge] 1, 1}, {0 \[UndirectedEdge] 2, 
      2}, {1 \[UndirectedEdge] 3, 3}}, {{0 \[UndirectedEdge] 1, 
      1}, {0 \[UndirectedEdge] 2, 2}, {2 \[UndirectedEdge] 3, 3}},
    
    {{0 \[UndirectedEdge] 2, 2}, {0 \[UndirectedEdge] 1, 
      1}, {0 \[UndirectedEdge] 3, 3}}, {{0 \[UndirectedEdge] 2, 
      2}, {0 \[UndirectedEdge] 3, 3}, {0 \[UndirectedEdge] 1, 
      1}}, {{0 \[UndirectedEdge] 3, 3}, {0 \[UndirectedEdge] 2, 
      2}, {0 \[UndirectedEdge] 1, 1}}, {{0 \[UndirectedEdge] 2, 
      2}, {0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 3, 
      3}}, {{0 \[UndirectedEdge] 2, 2}, {0 \[UndirectedEdge] 1, 
      1}, {2 \[UndirectedEdge] 3, 3}},
    
    {{0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 2, 
      2}, {0 \[UndirectedEdge] 3, 3}}, {{0 \[UndirectedEdge] 3, 
      3}, {0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 2, 
      2}}, {{0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 3, 
      3}, {1 \[UndirectedEdge] 2, 2}}, {{0 \[UndirectedEdge] 1, 
      1}, {1 \[UndirectedEdge] 2, 2}, {1 \[UndirectedEdge] 3, 
      3}}, {{0 \[UndirectedEdge] 1, 1}, {1 \[UndirectedEdge] 2, 
      2}, {2 \[UndirectedEdge] 3, 3}}}], 5], Frame -> All

enter image description here

Source Link
Jean-Pierre
Jean-Pierre
  • 5.2k
  • 9
  • 15

Not the fastest approach for question 1, but here is a way. All permutations are produced and each is tested. There are various possibilities to achieve a tabular result. Here I just used Multicolumn.

strirlingPermutation[k_] := (
  list = Riffle[Table[i, {i, 1, k}], Table[i, {i, 1, k}]];
  check[x_List] := (
    done = {};
    n = 1;
    While[n <= Length[x],
     If[MemberQ[done, x[[n]]],
      p = Position[done, x[[n]]][[1]][[1]];
      If[Min[done[[p ;;]]] != x[[n]], Return[False]]];
     AppendTo[done, x[[n]]];
     n++;
     ];
    Return[True];
    );
  Multicolumn[Select[Permutations[list], check[#] &], k]
  )
strirlingPermutation[3]

enter image description here