Construct a permutation tree plot

Question

How to construct a tree like this? I was looking CompleteKaryTree initially, there are some similarities overall, but it's still different.

CompleteKaryTree[5, 2, GraphLayout -> "LayeredEmbedding", AspectRatio -> 1/4] 

Another way, I've generated the coordinates of all the points, but I don't know how to connect them

n=4;
pts=Join @@ Table[{1/2 (1+(n-j)!)+(i-1) (n-j)!,n-j-1},{j,0,n},{i,FactorialPower[n,j]}];
Graphics[{Point@pts}, ImageSize->Large]

Answer 1

You can use ExpressionGraph to draw the tree

expr = ConstantArray[x, Reverse @ Range[4]];

ExpressionGraph[expr, GraphLayout -> "LayeredEmbedding", ImageSize -> Large] 

 epxr2  = ConstantArray[x, Reverse @ Range[5]];

 ExpressionGraph[expr2, GraphLayout -> "LayeredEmbedding", ImageSize -> 700, 
 VertexSize -> Medium, AspectRatio -> 1/2] 

Define a function that constructs a permutation tree with edge labels:

ClearAll[rule, permutationTree]
rule = # /.  x : {___Integer} /; Length[x] > 1 :>
   (Reverse /@ Subsets[Reverse@x, {Length[x] - 1}]) &;
 
permutationTree[n_, opts : OptionsPattern[Graph]] := 
 Module[{eg = ExpressionGraph[ConstantArray[x, Reverse@Range[n]], 
     opts, GraphLayout -> "LayeredEmbedding", 
     ImageSize -> 700, VertexSize -> Medium, AspectRatio -> 1/2], 
   edgelabels},
  edgelabels =  Thread[First @ Last @ Reap@
        BreadthFirstScan[eg, 1, {"FrontierEdge" -> Sow}] -> 
          Flatten@NestList[rule, Range[n], n - 1]] ; 
  SetProperty[eg, EdgeLabels -> edgelabels]]

Examples:

permutationTree[3] 

permutationTree[4] 

permutationTree[4, GraphLayout -> "RadialEmbedding", 
  AspectRatio -> 1, EdgeLabelStyle -> Large]

permutationTree[5, ImageSize -> 900]  

Alternatively, you can use TreeForm:

TreeForm[expr,  ImageSize -> Large, VertexLabeling -> False] 

Note: For versions older than v12.0, replace ExpressionGraph with GraphComputation`ExpressionGraph. (See also this answer.)

Answer 2

Using a slight modification of the code in Wolfram Demonstrations >> Permutation Tree (linked by George Varnavides in comments) and adding edge labels:

ClearAll[permTree]
permTree[n_, opts : OptionsPattern[Graph]] := Module[{el = Union @@ 
 Map[Rule @@@ Partition[FoldList[Append, {}, #], 2, 1] &, Permutations @ Range @ n]},
  Graph[el, opts, DirectedEdges -> False, 
   GraphLayout -> "LayeredEmbedding", EdgeLabels -> {e_ :> e[[2, -1]]}]]

Examples:

permTree[3, ImageSize -> Large, 
   VertexLabels -> {v_ /; Length[v] == 3 :> Placed[Column @ v, Below]}]

permTree[4, ImageSize -> 800, 
   VertexLabels -> {v_ /; Length[v] == 4 :> Placed[Column @ v, Below]}]

permTree[4, ImageSize -> Large, GraphLayout -> "RadialEmbedding"]

Answer 3

In 12.3 or later, you can use NestTree:

choice[{_, list_List}]:=
  MapIndexed[{e, pos} |-> {e, Delete[list, pos]}, list]

permutationTree[list_List] :=
  NestTree[choice, {Null, list}, Infinity, First]
permutationTree[n_Integer] :=
  permutationTree[Range[n]]

Answer 4

Using my package IGraph/M,

Needs["IGraphM`"]
IGSymmetricTree[{4, 3, 2, 1}, GraphLayout -> "LayeredEmbedding"]

See its documentation, which shows precisely the tree you are asking for.

Answer 5

We create the points recursively. Given the numbers of siblings in every generation by e.g. ngen=ngen = {4, 3, 2, 1}, in a first step we create 4 descendants. Then for every sibling we create another 3 descendants, then 2, then 1. Finally we use TreePlot. You may play with labels, I simply number the edges here:

ngen = {4, 3, 2, 1};
p = 0;
Clear[step];
step[n0_, 
  gen_] := (next = 
   Table[n0 \[UndirectedEdge] ++p, ngen[[gen]]]; {next, 
   If[gen == Length@ngen, Nothing[], step[#[[2]], gen + 1] & /@ next]})
tr = step[0, 1];
TreePlot[tr // Flatten(*,0,VertexLabels\[Rule]"Name"*), 
 EdgeLabels -> "Index"]