correction: Xah's graphs under rotation

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

Oops, forgot that rotation could produce permutations that were already dropped. this cures it: In[34]:= rotate[lis_,n_]:=Module[{it=cycle[lis,n],temp},temp=RotateLeft[it, Position[ it,Min[it]][[1,1]]-1];If[temp[[2]]<Last at temp,temp,RotateRight[Reverse[temp]]]] for beauty's sake, also set the loop over j to Length[First[it]] instead of 6 : In[42]:= pointers=Union[Union[#]&/@( DeleteCases[Table[ Position[it,rotate[it[[i]],j]],{i,1,Length at it},{j,Length[ First[it]]}],{},{2}]/.{{a_Integer}}->a)] Looks real nice now. >Date: Sun, 15 Jun 1997 16:12:12 >To: Xah Lee <xah at best.com> >From: "w.meeussen" <meeussen.vdmcc at vandemoortele.be> To: mathgroup at smc.vnet.net >Subject: [mg7602] [mg7602] Xah's graphs under rotation >Cc: mathgroup > >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]], True,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