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