# How to visually display the Stirling permutations of $k^{th}$ order?

Definition of Stirling permutation from Wikipedia:

In combinatorial mathematics, a Stirling permutation of order k is a permutation of the multiset $$\{1, 1, 2, 2, ..., k, k\}$$ (with two copies of each value from 1 to k) with the additional property that, for each value i appearing in the permutation, the values between the two copies of i are larger than i.

An example of the Stirling permutations of order 4 is as follows:

Another interesting image from the Wikipedia page states that a Stirling permutation can be constructed from an Euler tour of a plane tree with its edges labeled by construction order. With an example as such:

My questions are as follows:

1. How do I define a function that outputs the $$k^{th}$$ order Stirling permutations in a tabular manner as shown in the first image?
2. How do I display all Stirling permutations in the form of the plane trees and corresponding Euler tours as shown in the second image? Is this even possible to do?
• David Eppstein has a Python implementation of a Stirling permutation generator; someone might consider re-implementing that in Mathematica. Feb 22, 2021 at 16:23

## Update 2: Visualization

ClearAll[strlngPermGraph]
strlngPermGraph[sp_, opts : OptionsPattern[]] :=
Module[{vl = DeleteDuplicates @ sp,
pos = PositionIndex @ sp,
eL = EdgeList @* TransitiveReductionGraph @* GraphUnion},
Graph[Prepend[vl, 0],
SimpleGraph @ RelationGraph[And @@ Between[pos @ #] /@ pos[#2] &, vl]],
GraphLayout -> {"LayeredEmbedding", "RootVertex" -> 0},
EdgeLabels -> {e_ :> Placed[Last @ e, {Left, "Middle"}]}, opts]]


### Wikipedia example:

perm = {1, 2, 6, 6, 2, 4, 4, 1, 3, 3, 5, 5};

strlngPermGraph[perm,
EdgeShapeFunction -> "Line", EdgeStyle -> Thick, ImageSize -> 200,
EdgeLabelStyle -> 16, VertexSize -> Medium, PlotLabel -> perm]


### strlngPermutations(3):

Grid[Partition[strlngPermGraph[#, PlotLabel -> #] & /@ strlngPermutations[3], 5],
Dividers -> All]


### strlngPermutations(4):

Grid[Partition[strlngPermGraph[#, PlotLabel -> #, VertexSize -> 0,
ImageSize -> Tiny, AspectRatio -> 1] & /@ strlngPermutations[4], 7],
Dividers -> All]


## Update: A recursive method

We make use of two observations:

1. in every permutation in strlngPermutations[k] the pair {k, k} should stay together, and
2. we can get strlngPermutations[k] by inserting k k in 2 k - 1 positions of each permutation in strlngPermutations[k - 1]
ClearAll[strlngPermutations]
strlngPermutations[1] = {{1, 1}};
strlngPermutations[k_] := Join @@
(Function[x, Flatten[Insert[x, {k, k}, #]] & /@ Range[2 k - 1]] /@
strlngPermutations[k - 1])


### Examples:

Multicolumn[Sort @ strlngPermutations @ 3, 5, Appearance -> "Horizontal"]


Multicolumn[Sort @ strlngPermutations @ 4, 5, Appearance -> "Horizontal"]


Length[strlngPermutations @ #] & /@ Range[9]

{1, 3, 15, 105, 945, 10395, 135135, 2027025, 34459425}


To get the lengths of permutation lists without computing the permutations, we can use the same idea:

numberofStirlingPermutations[1] = 1;
numberofStirlingPermutations[k_] := (2 k - 1) numberofStirlingPermutations[k - 1]

numberofStirlingPermutations /@ Range[15]

{1, 3, 15, 105, 945,
10395, 135135, 2027025, 34459425, 654729075,
13749310575, 316234143225, 7905853580625, 213458046676875, 6190283353629375}


Also a brute-force approach (filtering permutations) as in Jean-Pierre's answer, (so k needs to be small so that Permutations[Range[2 k - 1]] does not eat up your entire memory), but much faster:

ClearAll[stirlingPerms]

stirlingPerms = ReplaceAll[# -> Sequence[#, #]] @
DeleteCases[{___, a_, b__, a_, ___} /; Min[{b}] < a] @
Permutations @ Most[Join @@ Table[{i, i}, {i, #}]] &;

stirlingPerms[3] // Column


• Wow, incredible. Thanks a lot. Feb 24, 2021 at 14:59
• just wonder how can you learn all these things? Feb 24, 2021 at 22:08

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]



• Thanks that works great! Any idea about how I can do the second question? From what I could see from the documentation I don't think I can really do it with Mathematica. I was planning on just drawing a few with Illustrator. Feb 22, 2021 at 2:44

The following routine is a modification of the implementation of Knuth's "Algorithm L" given here, and uses the same criterion kglr used in his answer to filter out Stirling permutations:

stirlingPermutations[n_Integer?Positive] := Module[{p = Quotient[Range[2 n - 1], 2, -1], j, k},
Reap[While[True,
If[! MatchQ[p, {___, a_, b__, a_, ___} /; Min[{b}] < a],
Sow[ReplaceAll[p, n -> Sequence[n, n]]]];
j = 2 (n - 1);
While[j > 0 && p[[j]] >= p[[j + 1]], j--];
If[j == 0, Break[]];
k = 2 n - 1;
While[p[[j]] >= p[[k]], k--];
p[[{j, k}]] = p[[{k, j}]];
p[[j + 1 ;;]] = p[[-1 ;; j + 1 ;; -1]]]][[-1, 1]]]


For example,

stirlingPermutations[3]
{{1, 1, 2, 2, 3, 3}, {1, 1, 2, 3, 3, 2}, {1, 1, 3, 3, 2, 2}, {1, 2, 2, 1, 3, 3},
{1, 2, 2, 3, 3, 1}, {1, 2, 3, 3, 2, 1}, {1, 3, 3, 1, 2, 2}, {1, 3, 3, 2, 2, 1},
{2, 2, 1, 1, 3, 3}, {2, 2, 1, 3, 3, 1}, {2, 2, 3, 3, 1, 1}, {2, 3, 3, 2, 1, 1},
{3, 3, 1, 1, 2, 2}, {3, 3, 1, 2, 2, 1}, {3, 3, 2, 2, 1, 1}}


A recursive approach to construct trees: for each node i in an input tree t, add a new edge i -> k and, for each descendant of j of i, insert k after j in the vertex list of t.

To get the Stirling permutation associated with a tree t, we replace directed edges in t with undirected edges and use FindPostmanTour.

ClearAll[veAdd, eTrees, postmanTour]

Module[{vl = VertexList[g],
voc = VertexOutComponent[g, #, 1] & /@ VertexList[g],
vc = VertexCount[g]},
Flatten[Function[x,
Graph[Insert[vl, vc, 1 + VertexIndex[g, #]],
Append[EdgeList[g], First[x] -> vc],
GraphLayout -> {"LayeredEmbedding", "RootVertex" -> 0},
EdgeLabels -> {e_ :> Placed[Last @ e, {Left, "Middle"}]},
opts] & /@ x] /@ voc]]

eTrees[1, opts : OptionsPattern[]] := {Graph[{0, 1}, {0 -> 1}, opts]};

eTrees[k_, opts : OptionsPattern[]] := Flatten[veAdd[#, opts] & /@ eTrees[k - 1]]

postmanTour[t_] := Module[{ug = UndirectedGraph[t,
Options[t] /. DirectedEdge -> UndirectedEdge]},
PropertyValue[{ug, #}, EdgeLabels][[1]] & /@
Reverse[FindPostmanTour[ug][[1]]]]


Examples:

Multicolumn[Sort[postmanTour /@ eTrees[3]], 5, Appearance -> "Horizontal"]


Grid[
Partition[Show[#, PlotLabel -> postmanTour@#] & /@ eTrees[3,
VertexShapeFunction -> (Disk[#, Offset[3]] &),
AspectRatio -> 1],
5],
Dividers -> All]


A random sample of 25 trees from eTrees[4]:

Grid[
Partition[
Show[#, PlotLabel -> postmanTour@#] & /@ RandomSample[eTrees[4,
VertexShapeFunction -> (Disk[#, Offset[3]] &),
AspectRatio -> 1, ImageSize -> 150], 25],
5],
Dividers -> All]


A random sample of 25 trees from eTrees[6]:

Grid[
Partition[
Show[#, PlotLabel -> postmanTour@#] & /@ RandomSample[eTrees[6,
VertexShapeFunction -> (Disk[#, Offset[3]] &),
AspectRatio -> 1, ImageSize -> 170], 25],
5],
Dividers -> All]