Xah's graphs under rotation

• To: mathgroup at smc.vnet.net
• Subject: [mg7601] Xah's graphs under rotation
• From: "w.meeussen" <meeussen.vdmcc at vandemoortele.be>
• Date: Thu, 19 Jun 1997 15:53:19 -0400 (EDT)
• Sender: owner-wri-mathgroup at wolfram.com

```hi all,

inspired by Xah's loopNpoints.nb, a small addition:

if permutations over n elements are displayed graphicaly, with proviso that
(Quote[mg7514])
(1)
Two lists are considered the same if one is the other shifted.(RotateRight).
(2)
Two lists are considered the same if one is the other reversed.
(EndQuote[mg7514])

and, in addition, that the resulting graphs should be grouped according to
rotation symmetriy, one gets:

Slight modification in sequence of reducedPerms[]:
In[3]:=
reducedPerms[n_]
:=Select[Prepend[#,1]&/@Permutations at Range[2,n],(#[[2]]<#[[n]])&]
a definition of permutations (you could also load DiscreteMath`Permutations`)
In[4]:=
rue,False,False]

*** a few helper functions ***

In[5]:=
cycle[lis_?permutationQ,n_]:=(Mod[#+n,Length[lis]])&/@(lis-1) +1
In[6]:=
rotate[lis_,n_]:=Module[{it=cycle[lis,n]},RotateLeft[it,
Position[it,Min[it]][[1,1]]-1]]

*** now the one-liner ***

In[7]:=
it=reducedPerms[6]
In[8]:=
pointers=Union[Union[#]&/@(
DeleteCases[Table[
Position[it,rotate[it[[i]],j]],{i,1,Length at it},{j,6}],{},
{2}]/.{{a_Integer}}->a)]

*** this produces the permutations ***
In[9]:=
Part[it,#]&/@pointers

*** this is Xah's graphic rendering of them ***
*** needs loopNPoints for the permutationgraphics[] ***
In[10]:=
Show[GraphicsArray[Map[permutationGraphics[#,AspectRatio->Automatic,
PlotRange->All]&,(Part[it,#]&/@pointers),{2}]]]

wouter.

Dr. Wouter L. J. MEEUSSEN
eu000949 at pophost.eunet.be
w.meeussen.vdmcc at vandemoortele.be

```

• Prev by Date: MatrixExp[DiagonalMatrix[{1,1,-1,-1}]] & MMA 3.0
• Next by Date: correction: Xah's graphs under rotation
• Previous by thread: MatrixExp[DiagonalMatrix[{1,1,-1,-1}]] & MMA 3.0
• Next by thread: correction: Xah's graphs under rotation