3
$\begingroup$

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:

Stirling permutations of order 4

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:

Euler tour

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?
Improve this question
$\endgroup$
1

4 Answers 4

Reset to default
3
+100
$\begingroup$

Update 2: Visualization

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

Examples:

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]

enter image description here

strlngPermutations(3):

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

enter image description here

strlngPermutations(4):

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

enter image description here

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

enter image description here

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

enter image description here

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}

Original answer:

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

enter image description here

Improve this answer
$\endgroup$
2
  • $\begingroup$ Wow, incredible. Thanks a lot. $\endgroup$
    – Bhoris Dhanjal
    Commented Feb 24, 2021 at 14:59
  • $\begingroup$ just wonder how can you learn all these things? $\endgroup$
    – emnha
    Commented Feb 24, 2021 at 22:08
3
$\begingroup$

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

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

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

Improve this answer
$\endgroup$
1
  • $\begingroup$ 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. $\endgroup$
    – Bhoris Dhanjal
    Commented Feb 22, 2021 at 2:44
2
$\begingroup$

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}}
Improve this answer
$\endgroup$
2
$\begingroup$

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]

veAdd[g_, opts : OptionsPattern[]] :=
 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"]

enter image description here

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

enter image description here

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]

enter image description here

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]

enter image description here

Improve this answer
$\endgroup$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service and acknowledge you have read our privacy policy.

Not the answer you're looking for? Browse other questions tagged or ask your own question.