Return to Revisions

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]

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]

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

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

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]