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?

EDIT: Question 1 has been answered by Jean-Pierre. However Question 2 is still open.

$\endgroup$
1
  • $\begingroup$ David Eppstein has a Python implementation of a Stirling permutation generator; someone might consider re-implementing that in Mathematica. $\endgroup$ – J. M.'s ennui Feb 22 at 16:23
2
+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

$\endgroup$
2
  • $\begingroup$ Wow, incredible. Thanks a lot. $\endgroup$ – Bhoris Dhanjal Feb 24 at 14:59
  • $\begingroup$ just wonder how can you learn all these things? $\endgroup$ – anhnha Feb 24 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

$\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 Feb 22 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}}
$\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

$\endgroup$

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.