loop n points notebook
by Xah Lee. 1997/06

Introduction

This notebook contain codes that generate graphics to illustrate ways of forming a loop among n points. It is of interest to Mathematica programers.
Xah Lee. 1997/06.
xah@xahlee.org
http://xahlee.org/

Copyright 1997 by Xah Lee. You have permission to copy, modify, or distribute this notebook provided that this notice remains intact.

The problem

Two function we want to write.
(1) A program that returns all possible permutations with the criteria that two permutations are considered equal by reversal or shift. (Reverse, RotateRight)
(2) A graphics program such that given a permutation, it generate graphics connecting points distributed around the circle in the order of the given permutation.
The graphics function is done with permutationGraphics. The list is generated by the code following the code for permutationGraphics.

permutationGraphics

There is not much to explain here. The code is quite simple if you understand Mathematica Graphics and graphics primitives.

Clear[permutationGraphics];
\(\(permutationGraphics::usage = "permutationGraphics[permutationA,opts] returns a Graphics object illustrating ways to connect given points. permutationA is a permutation of 1 to n integers. opts are Options passed to Graphics. Usage Example: Show[permutationGraphics[{1,2,5,4,3},AspectRatio->Automatic]]";\)\)

\(permutationGraphics[perm_List, opts___Rule] := 
      Module[{points, n = Length@perm, lineGP, pointGP, labelGP, 
          plotLabelGP}, 
        points = \(Table[{Cos@t, Sin@t}, {t, 0, 2*Pi - \((2*\(Pi/n\)/2)\), 
                2*Pi/n}]\)[\([perm]\)]; 
		lineGP = 
          Line@\ Append[points, First@points]; 
		pointGP = 
          Point /@ points; 
		labelGP = 
          MapThread[
            Text[#1, #2* .8, {0, 0}, 
                TextStyle -> {FontSize -> 9, FontFamily -> "Courier", 
                    FontColor -> Hue[0, 1,  .7]}] &, {perm, 
              points}]; 
		plotLabelGP = 
          Text[StringReplace[
              ToString@
                perm, {" " -> "", "," -> "", "{" -> "", "}" -> ""}], {0, \(- .1\)}, 
            TextStyle -> {FontFamily -> "Courier", 
                FontColor -> 
                  Hue[ .7, 1,  .7]}]; 
		Graphics[{PointSize[ .03], 
            pointGP, lineGP, GrayLevel[0], labelGP, plotLabelGP}, 
          opts]
		]\)

Generating the list

The mathematics of generating complete permutations without reversal and shifts are thus: From all the permutations, pick those that satisfy the two conditions: (1) Its first element is 1. (2) Its 2nd element is less than its last element. 
The code below is based on this fact.

Clear[n, resultA, i, j, li, perm];
n = 5;
resultA = Table[0, {(n - 1)!/2}];
i = 1; j = 1;
perm = Permutations@Range@n;

While[i <= Length@resultA, 
      If[perm[[j, 2]] < perm[[j, -1]], 
        resultA[[i]] = perm[[j]]; i++]; j++]

resultA

Here is a much more efficient implementation (from Daniel Lichtblau <danl@wolfram.com>)

Clear[reducedPerms1];
reducedPerms[n_]  :=  
      Select[Prepend[#, 1] & /@ 
          Permutations@
            Range[2, n], (#[[2]] > #[[n]]) &]

Now Map permutationGraphics to the permutations to obtain a list of Graphics, then use GraphicsArray to show them all nicely.

Clear[graArray];
graArray = permutationGraphics[#, AspectRatio -> Automatic, 
              PlotRange -> All] & /@ reducedPerms@5;

Show[GraphicsArray[Partition[graArray, 4]]];