Illustration of Motzkin numbers: how to delete duplicates

Question

The $n$-th Motzkin number is the number of different ways of drawing non-intersecting chords between $n$ points on a circle (not necessarily touching every point by a chord -- see https://en.wikipedia.org/wiki/Motzkin_number).

When drawing these different ways one can draw circles with non-intersecting chords, but this generates duplicates (modulo rotations and symmetries).

For example the $4$-th Motzkin number is $M_4=9$, the corresponding representations being as follows.

Given all possible configurations of a circle with $n$ points and non-intersecting chords, how to delete duplicate graphics (that are identical modulo rotations and symmetries)?

Following is the drawing code, it generates such duplicates

HasIntersectionQ[lines_] := GeneralUtilities`Scope[
    If[Length@lines < 2, Return@False];
    AnyTrue[Subsets[lines, {2}], LineIntersectionQ]
]
LineIntersectionQ[{a_Line, b_Line}] := GeneralUtilities`Scope[
    If[Length@Union@Flatten[{First@a, First@b}, 1] != 4, Return@True];
    Length@FindInstance[{x, y}\[Element]N@a && {x, y}\[Element]N@b, {x, y}] != 0
]
draw[lines_] := Graphics[{
    CapForm["Round"], RGBColor["#ADD8E6"],
    Thickness[0.01], Circle[],
    PointSize[0.05], Point /@ CirclePoints[n],
    Red, Thickness[0.05], lines
}];

n = 4;
lines = Line /@ Subsets[CirclePoints[n], {2}];
draw /@ GeneralUtilities`Discard[Subsets[lines, Floor[n / 2]], HasIntersectionQ]

Answer 1

Here's a faster alternative. We don't work with points. We work with the angles. In fact, let's not even work with angles. Let us work with the integer scale of the angle.

E.g. $\{\cos(3\frac{2\pi}{7}),\sin(3\frac{2\pi}{7})\} \rightarrow 3\frac{2\pi}{7} \rightarrow 3$

When we are check for two lines crossing, we have two pairs of integers: $\{a,b\},\{p,q\}$. From the way they are generated, we always have $a$ as the smallest number. Then the only non-crossing configurations are: $a<b<p<q$ and $a<p<q<b$.

We can pick out unique configurations by converting the lines to a set of lengths.

ClearAll@LineIntersectionQ;
LineIntersectionQ[{{a_?NumberQ, b_}, {p_, q_}}] := 
LineIntersectionQ[{{a, b}, {p, q}}] = ! ((a < p && q < b) || b < p);
LineIntersectionQ[_] := False;
ClearAll@HasIntersectionQ;
HasIntersectionQ[a_] := AnyTrue[Subsets[a, {2}], LineIntersectionQ];

ClearAll@lengthy;
lengthy[v_, n_] := 
  Sort@Map[Module[{a, b}, {a, b} = # (2 Pi)/n; 
      If[b - a > Pi, 2 P] - (b - a), b - a]] &, v];

ClearAll@draw;
draw[a_, n_] := 
  Graphics[{CapForm["Round"], RGBColor[173, 216, 230], 
    Thickness[0.01], Circle[], PointSize[0.05], 
    Point /@ CirclePoints[{1, 0}, n], Red, Thickness[0.05], 
    Line /@ Map[{Cos[# (2 Pi)/n], Sin[# (2 Pi)/n]} &, a, {2}]}];

ClearAll@Motzkin;
Motzkin[n_Integer] :=
  Module[{angles},
   angles = Subsets[Range[0, n - 1], {2}];
   angles = Discard[Subsets[angles, Floor[n/2]], HasIntersectionQ];
   angles = DeleteDuplicatesBy[angles, lengthy[#, n] &];
   
   draw[#, n] & /@ angles
   ];

This can generate up to 10 points in ok time:

The slowest bit remains generating all the possible subsets, then filtering them. There is a huge amount of clearly wrong combinations generated. E.g. {{0,1},{0,2}} repeats vertex 0 so shouldn't even be considered. One could put in a bunch of effort to replace Subsets with something better for this application. But given the rate at which the Motzkin numbers increase, it might not be worth it.

Answer 2

Some attempts:

norm[l_] := First@Sort@Map[Sort, Table[Map[RotationMatrix[2 Pi * i / n].#&, l, {3}], {i, n}], {3}];

n = 4;
lines = Line /@ Subsets[CirclePoints[n], {2}];
MapIndexed[draw, cs = GeneralUtilities`Discard[Subsets[lines, Floor[n / 2]], HasIntersectionQ]];
MapIndexed[draw, cs = DeleteDuplicates[norm /@ cs]]

Seems to work for n = 4:

But n = 5 fails:

Answer 3

First we need to organize Module since all functions depends on n. Second, we add one filter more based on ArcLength. Finally we have

 Clear["Global`*"]

f[nn_] := 
 Module[{n = nn}, 
  HasIntersectionQ[lines_] := 
   GeneralUtilities`Scope[If[Length@lines < 2, Return@False];
    AnyTrue[Subsets[lines, {2}], LineIntersectionQ]];
  LineIntersectionQ[{a_Line, b_Line}] := 
   GeneralUtilities`Scope[
    If[Length@Union@Flatten[{First@a, First@b}, 1] != 4, Return@True];
    Length@
      FindInstance[{x, y} \[Element] N@a && {x, y} \[Element] N@b, {x,
         y}] != 0];
  draw[lines_] := 
   Graphics[{CapForm["Round"], RGBColor["#ADD8E6"], Thickness[0.01], 
     Circle[], PointSize[0.05], Point /@ CirclePoints[{1, 0}, n], Red,
      Thickness[0.05], lines}]; 
  norm[l_] := 
   First@Sort@
     Map[Sort, 
      Table[Map[RotationMatrix[2 Pi*i/n] . # &, l, {3}] // 
        FullSimplify, {i, n}], {3}]; 
  norm1[l_] := Sort@Map[Sort, Map[ArcLength, l], {3}];
  lines = Line /@ Subsets[N@CirclePoints[{1, 0}, n], {2}];
  cs = GeneralUtilities`Discard[Subsets[lines, Floor[n/2]], 
    HasIntersectionQ]; cs1 = DeleteDuplicatesBy[cs, norm]; 
  cs2 = DeleteDuplicatesBy[cs1, norm1];
  g = Map[draw, cs2]; g]

With f we can compute f[4], f[5], f[6]

Answer 4

Not a complete answer, apologies.

For some reason the drawing code doesn't work for me.

Too much for a comment, maybe you could treat them as an image?

i = Table[ImageRotate[c0, i], {i, 0, 2 Pi, 2 Pi/n}]

If you rotate by n , DeleteDuplicates[] works pretty nicely.

You can make a True / False method

images = MorphologicalComponents[#] & /@ i;
(And @@ Thread[images[[1]] == images[[2]]])

Testing if any rotation already exists

If you treat as an image it's a similar problem to a puzzle posted: How to delete duplicate graphics of the same kind?

Avoiding images maybe you could use a matrix or the line and test similarity using JordanDecomposition[] , I guess you'd still need rotation though.