Mathematica 9 is now available
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

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



  • 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