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]:=
permutationQ[lis_]:=If[(Head[lis]===List)&&Union[lis]===Range[Length[lis]],T
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