Services & Resources / Wolfram Forums
-----
 /
MathGroup Archive
1997
*January
*February
*March
*April
*May
*June
*July
*August
*September
*October
*November
*Archive Index
*Ask about this page
*Print this page
*Give us feedback
*Sign up for the Wolfram Insider

MathGroup Archive 1997

[Date Index] [Thread Index] [Author Index]

Search the Archive

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



  • Prev by Date: Xah's graphs under rotation
  • Next by Date: Message
  • Previous by thread: Xah's graphs under rotation
  • Next by thread: Message