(************** Content-type: application/mathematica ************** CreatedBy='Mathematica 5.0' Mathematica-Compatible Notebook This notebook can be used with any Mathematica-compatible application, such as Mathematica, MathReader or Publicon. The data for the notebook starts with the line containing stars above. To get the notebook into a Mathematica-compatible application, do one of the following: * Save the data starting with the line of stars above into a file with a name ending in .nb, then open the file inside the application; * Copy the data starting with the line of stars above to the clipboard, then use the Paste menu command inside the application. Data for notebooks contains only printable 7-bit ASCII and can be sent directly in email or through ftp in text mode. Newlines can be CR, LF or CRLF (Unix, Macintosh or MS-DOS style). NOTE: If you modify the data for this notebook not in a Mathematica- compatible application, you must delete the line below containing the word CacheID, otherwise Mathematica-compatible applications may try to use invalid cache data. For more information on notebooks and Mathematica-compatible applications, contact Wolfram Research: web: http://www.wolfram.com email: info@wolfram.com phone: +1-217-398-0700 (U.S.) Notebook reader applications are available free of charge from Wolfram Research. *******************************************************************) (*CacheID: 232*) (*NotebookFileLineBreakTest NotebookFileLineBreakTest*) (*NotebookOptionsPosition[ 235774, 4416]*) (*NotebookOutlinePosition[ 237032, 4459]*) (* CellTagsIndexPosition[ 236913, 4452]*) (*WindowFrame->Normal*) Notebook[{ Cell[CellGroupData[{ Cell[TextData[{ "Implementing mathematical concepts in ", StyleBox["Mathematica", FontSlant->"Italic"], ": \nQuotients in permutation groups." }], "Subtitle"], Cell["\<\ Ivan Cnop Vrije Universiteit Brussell Pleinlaan 2, B 1050 Brussels, Belgium icnop @ vnet3.vub.ac.be Presented at the Koblenz ICTMT3 Conference,1997\ \>", "Subsubtitle", FontSize->12], Cell[CellGroupData[{ Cell["Introduction", "Section"], Cell[TextData[{ "Understanding quotients poses problems for the average student. This is \ the case even for discrete and finite structures. A quotient is a set of \ equivalence classes under some equivalence relation. In some cases the \ quotient inherits the operations on the original structure and the properties \ thereof. Here color coding can help understanding how quotients work. Such \ color codings are quite natural and readily available in the ", StyleBox["Mathematica", FontSlant->"Italic"], " documentation. The Color wheel is the most obvious example: its Hues \ correspond to equal arguments and saturation corresponds to moduli. Coloring \ polar coordinates is the simplest example of coloring in the ComplexMap \ Package. Along the same idea, a ContourPlot or DensityPlot of a function \ shows the equivalence relating points with nearby values by coloring or \ shades of grey. In this case little algebraic or geometric structure is \ involved, except for some very special functions.\n\nIn other cases, it is \ possible to get useful information by coloring objects in the right way. \ Coloring a sphere or a torus according to meridians (longitude) and latitudes \ explains how they relate to rectangles in the plane. These colorings are done \ using the parameters in the ParmetricPlot command. Spherical coordinates blow \ up near the poles on a sphere. They do not blow up on a torus. Thus we find \ that identifying opposite sides of a rectangle with periodic coloring, this \ rectangle can be rolled into a tube which can then be turned into a torus. \ Rolling first in either direction gives the same final result. If one tries \ to do a similar coloring on the Klein Bottle according to the longitude and \ latitude parameters it will lead to the surprising result that in one \ direction the coloring must be symmetric around the axis. The portion next to \ this axis is turned into a Mobius strip.\n\nSubstantial information about \ finite groups can be derived from appropriate colorings of the geometric \ objects under consideration. Choosing an appropriate coloring of the \ Dodecahedron exhibits an inscribed cube (or an inscribed tetrahedron) and \ enables us to investigate which rotations of the Dodecahedron preserve the \ inscribed cube (or the inscribed tetrahedron), showing interesting subgroups. \ Rotations or order five preserve neither of these. Coloring the four \ diagonals of the cube will then show that mappings of a cube onto itself are \ all permutations on four elements. This brings us to the abstract setting of \ permutation groups.\n\nAbstract groups require some care. Here is a setup of \ input lines for obtaining quotients by a subgroup in the group of \ permutations on a set of n elements. In this text user-defined functions are \ not capitalised." }], "Text"] }, Closed]], Cell[CellGroupData[{ Cell["Permutation subgroups", "Section", Evaluatable->False, AspectRatioFixed->True, CellTags->"permutation subgroups"], Cell[CellGroupData[{ Cell["\<\ Lists of permutations [includes package, objects, perms, \ comp]\ \>", "Subsection", Evaluatable->False, AspectRatioFixed->True], Cell["<True], Cell["\<\ In this example, we consider permutations on a set with four \ elements \ \>", "Text"], Cell["\<\ n=4; objects=Table[j,{j,n}];\ \>", "Input", AspectRatioFixed->True], Cell["perms=Permutations[objects];", "Input", AspectRatioFixed->True], Cell["\<\ Each permutation is given by listing the images of 1,2,3,4 . This \ group can be visualised by numbering from 1 to 4 the diagonals of a cube (or \ a octahedron) and following the positions of the diagonals after rotating the \ cube in all possible ways. But this will not be done here since it is not the \ purpose of this lesson, and it is not easy to visualise permutation groups \ for bigger n by some geometric action. Permutations are automatically \ ordered and can be recalled by the index [[ ]] . For viewing the \ lexicographic ordering of permutations, leave out the last semicolon. Here \ is one permutation:\ \>", "Text"], Cell[CellGroupData[{ Cell["perms[[9]]", "Input", AspectRatioFixed->True], Cell[BoxData[ \({2, 3, 1, 4}\)], "Output"] }, Closed]], Cell["\<\ The composition law for permutations is given by indirect adressing \ of images\ \>", "Text"], Cell["\<\ comp[perm2_,perm1_]:= \t\tTable[perm2[[perm1[[j]]]],{j,n}]\ \>", "Input", AspectRatioFixed->True], Cell[CellGroupData[{ Cell["comp[perms[[7]],perms[[7]]]", "Input", AspectRatioFixed->True], Cell[BoxData[ \({1, 2, 3, 4}\)], "Output"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell["\<\ control if subset is subgroup [includes sub, subGroupQ, gener1, \ generated, subg]\ \>", "Subsection", Evaluatable->False, AspectRatioFixed->True], Cell["\<\ Selecting a nonempty set of elements in the permutation group\ \>", "Text"], Cell[CellGroupData[{ Cell["indices={1,8,17,24}", "Input", AspectRatioFixed->True], Cell[BoxData[ \({1, 8, 17, 24}\)], "Output"] }, Closed]], Cell[CellGroupData[{ Cell["sub=Table[perms[[indices[[j]]]],{j,Length[indices]}]", "Input", AspectRatioFixed->True], Cell[BoxData[ \({{1, 2, 3, 4}, {2, 1, 4, 3}, {3, 4, 1, 2}, {4, 3, 2, 1}}\)], "Output"] }, Closed]], Cell["\<\ one has to verify that these permutations form a subgroup by \ checking that the composition law is internal (unit element and inverses come \ for free in the case of finite groups): \ \>", "Text"], Cell["\<\ subGroupQ[sub_]:= \t\tUnion[ \t\t\tFlatten[ \t\t\t\tOuter[ \t\t\t\t\tcomp,sub,sub,1 \t\t\t\t\t] \t\t\t\t,1] \t\t\t]\t==sub\ \>", "Input", AspectRatioFixed->True], Cell["\<\ The Flatten operation has its level specified since permutations \ are themselves lists (with four elements each). The Union operation filters out doubles. The above choice of sub is indeed a subgroup:\ \>", "Text"], Cell[CellGroupData[{ Cell["subGroupQ[sub]", "Input", AspectRatioFixed->True], Cell[BoxData[ \(True\)], "Output"] }, Closed]], Cell["\<\ If this returns False, one can look for the subgroup generated by \ the subset by Nesting Outer[comp[\t]] or finding its FixedPoint : \ \>", "Text"], Cell[BoxData[{ \(gener1[sub_] := Union[sub, \n\t\t\t\tFlatten[Outer[comp, sub, sub, 1]\n\t\t\t\t\t, 1]\n\t\t\t\t]\n\), "\n", \(generated[sub_] := FixedPoint[gener1, sub]\)}], "Input"], Cell["and replacing sub by this generated[sub]", "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(subg = \ If[subGroupQ[sub], sub, generated[sub]]\)], "Input"], Cell[BoxData[ \(General::"spell1" \(\(:\)\(\ \)\) "Possible spelling error: new symbol name \"\!\(subg\)\" is similar to \ existing symbol \"\!\(sub\)\"."\)], "Message"], Cell[BoxData[ \({{1, 2, 3, 4}, {2, 1, 4, 3}, {3, 4, 1, 2}, {4, 3, 2, 1}}\)], "Output"] }, Closed]] }, Closed]], Cell[CellGroupData[{ Cell["\<\ finding cosets and ordering along this partition [includes coset, \ add, l, ordering]\ \>", "Subsection", Evaluatable->False, AspectRatioFixed->True], Cell["\<\ It is now possible to find all left cosets of this subgroup (if it \ is a subgroup!)\t\ \>", "Text"], Cell["\<\ coset[j_]:=Flatten[ \t\t\tOuter[comp,{perms[[j]]},subg,1] \t\t\t,1]\ \>", "Input", AspectRatioFixed->True], Cell["\<\ which may be repeated to form a table of all cosets. The problem is \ that these are not disjoint. Some cosets contain elements from other cosets, \ but listed in a different order. Therefore, one has to consider only new cosets, which can be added one by one \ by\ \>", "Text"], Cell["\<\ add[j_]:= \tSort[ \t\tFlatten[ \t\t\tTable[ \t\t\t\tPosition[perms,coset[j][[k]]] \t\t\t\t,{k,Length[subg]} \t\t\t\t] \t\t\t] \t\t]\ \>", "Input", AspectRatioFixed->True], Cell["after the original subgroup. Try this out by performing:", "Text"], Cell[CellGroupData[{ Cell["add[7]", "Input", AspectRatioFixed->True], Cell[BoxData[ \({2, 7, 18, 23}\)], "Output"] }, Closed]], Cell[CellGroupData[{ Cell["perms[[add[7]]]", "Input", AspectRatioFixed->True], Cell[BoxData[ \({{1, 2, 4, 3}, {2, 1, 3, 4}, {3, 4, 2, 1}, {4, 3, 1, 2}}\)], "Output"] }, Closed]], Cell["\<\ Repeating this step, we obtain an ordering of the elements in the \ group which reflects the partition into cosets. We start with the original \ subgroup\ \>", "Text"], Cell[CellGroupData[{ Cell["\<\ l=Flatten[ \t\tTable[Position[perms,subg[[k]]] \t\t\t\t,{k,Length[subg]} \t\t]]\ \>", "Input", AspectRatioFixed->True], Cell[BoxData[ \({1, 8, 17, 24}\)], "Output"] }, Closed]], Cell["and add new cosets", "Text"], Cell[CellGroupData[{ Cell["\<\ ordering= \tDo[ \t\tl=If[ \t\t\tUnion[Join[l,add[j]]]==Union[l],l,Join[l,add[j]] \t\t\t] \t\t,{j,Factorial[n]} \t];l \t\ \>", "Input", AspectRatioFixed->True], Cell[BoxData[ \(General::"spell1" \(\(:\)\(\ \)\) "Possible spelling error: new symbol name \"\!\(ordering\)\" is similar \ to existing symbol \"\!\(Ordering\)\"."\)], "Message"], Cell[BoxData[ \({1, 8, 17, 24, 2, 7, 18, 23, 3, 11, 14, 22, 4, 12, 13, 21, 5, 9, 16, 20, 6, 10, 15, 19}\)], "Output"] }, Closed]], Cell[TextData[ "This is somewhat tricky since checking equality of cosets requires sorting \ elements, and the elements in the final list should never be sorted by the \ lexicographic ordering built into Mathematica\:2122. "], "Text"] }, Closed]], Cell[CellGroupData[{ Cell["Colorcoding cosets [includes: colors, mult, m, g, grid]", "Subsection", Evaluatable->False, AspectRatioFixed->True], Cell["Now the coloring of elements is straightforward:", "Text"], Cell["\<\ colors[m_]:=Hue[ \tN[ \tFloor[(m-1)/Length[subg]]/Length[perms] Length[subg] \t] \t] \ \>", "Input", AspectRatioFixed->True], Cell["\<\ if the order of elements is taken to be that of the list l :\ \>", "Text"], Cell["\<\ mult[pos1_,pos2_]:= \tFirst[First[Position[perms, \t\tcomp[ perms[[l[[pos1]]]],perms[[l[[pos2]]]] ] \t\t\t\t\t]]]\ \>", "Input", AspectRatioFixed->True], Cell["\<\ m[pos1_,pos2_]:= \tFirst[ \t\tFirst[ \t\t\tPosition[l,mult[pos1,pos2]] \t\t] \t]\ \>", "Input", AspectRatioFixed->True], Cell["Finally all elements are colored ", "Text"], Cell["\<\ g=Table[colors[m[pos1,pos2]],{pos1,Length[l]},{pos2,Length[l]}];\ \>\ ", "Input", AspectRatioFixed->True], Cell[CellGroupData[{ Cell["\<\ Show[Graphics[ \tRasterArray[g]] \t,AspectRatio->Automatic \t,GridLines->None]\ \>", "Input", AspectRatioFixed->True], Cell[GraphicsData["PostScript", "\<\ %! %%Creator: Mathematica %%AspectRatio: 1 MathPictureStart /Mabs { Mgmatrix idtransform Mtmatrix dtransform } bind def /Mabsadd { Mabs 3 -1 roll add 3 1 roll add exch } bind def %% Graphics %%IncludeResource: font Courier %%IncludeFont: Courier /Courier findfont 10 scalefont setfont % Scaling calculations 0.0238095 0.0396825 0.0238095 0.0396825 [ [ 0 0 0 0 ] [ 1 1 0 0 ] ] MathScale % Start of Graphics 1 setlinecap 1 setlinejoin newpath 0 0 m 1 0 L 1 1 L 0 1 L closepath clip newpath % Start of colorimage (RGB) p .02381 .02381 translate .95238 .95238 scale 72 string 24 24 8 [24 0 0 24 0 0] { \tcurrentfile \t1 index \treadhexstring \tpop } false 3 Mcolorimage FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF0000FF0000FF0000FF0000FF00 00FFFF00FFFF00FFFF00FFFF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00FF FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF0000FF0000FF0000FF0000FF00 00FFFF00FFFF00FFFF00FFFF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00FF FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF0000FF0000FF0000FF0000FF00 00FFFF00FFFF00FFFF00FFFF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00FF FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF0000FF0000FF0000FF0000FF00 00FFFF00FFFF00FFFF00FFFF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00FF FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00000000FF0000FF0000FF0000FF FF00FFFF00FFFF00FFFF00FF00FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00000000FF0000FF0000FF0000FF FF00FFFF00FFFF00FFFF00FF00FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00000000FF0000FF0000FF0000FF FF00FFFF00FFFF00FFFF00FF00FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00000000FF0000FF0000FF0000FF FF00FFFF00FFFF00FFFF00FF00FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF 00FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFFFF0000FF0000FF0000FF0000 FFFF00FFFF00FFFF00FFFF00FF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000FF 00FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFFFF0000FF0000FF0000FF0000 FFFF00FFFF00FFFF00FFFF00FF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000FF 00FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFFFF0000FF0000FF0000FF0000 FFFF00FFFF00FFFF00FFFF00FF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000FF 00FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFFFF0000FF0000FF0000FF0000 FFFF00FFFF00FFFF00FFFF00FF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000FF 00FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00FF00FFFF00FFFF00FFFF00FF 0000FF0000FF0000FF0000FFFF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00 00FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00FF00FFFF00FFFF00FFFF00FF 0000FF0000FF0000FF0000FFFF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00 00FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00FF00FFFF00FFFF00FFFF00FF 0000FF0000FF0000FF0000FFFF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00 00FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00FF00FFFF00FFFF00FFFF00FF 0000FF0000FF0000FF0000FFFF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00 0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00FFFFFF00FFFF00FFFF00FFFF00 FF0000FF0000FF0000FF000000FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00 0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00FFFFFF00FFFF00FFFF00FFFF00 FF0000FF0000FF0000FF000000FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00 0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00FFFFFF00FFFF00FFFF00FFFF00 FF0000FF0000FF0000FF000000FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00 0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00FFFFFF00FFFF00FFFF00FFFF00 FF0000FF0000FF0000FF000000FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00 FF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000FF00FFFF00FFFF00FFFF00FFFF 00FF0000FF0000FF0000FF00FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000 FF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000FF00FFFF00FFFF00FFFF00FFFF 00FF0000FF0000FF0000FF00FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000 FF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000FF00FFFF00FFFF00FFFF00FFFF 00FF0000FF0000FF0000FF00FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000 FF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000FF00FFFF00FFFF00FFFF00FFFF 00FF0000FF0000FF0000FF00FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000 pop P % End of image % End of Graphics MathPictureEnd \ \>"], "Graphics", ImageSize->{288, 288}, ImageMargins->{{43, 0}, {0, 0}}, ImageRegion->{{0, 1}, {0, 1}}, ImageCache->GraphicsData["Bitmap", "\<\ CF5dJ6E]HGAYHf4PAg9QL6QYHg"], ImageRangeCache->{{{0, 287}, {287, 0}} -> {-0.600126, -0.600126, 0.0878058, \ 0.0878058}}], Cell[BoxData[ TagBox[\(\[SkeletonIndicator] Graphics \[SkeletonIndicator]\), False, Editable->False]], "Output"] }, Closed]], Cell["\<\ It may be surprising that we did not check the normality of the \ subgroup. If the subgroup is not normal this RasterArray is messy since \ multiplication of the cosets is not independent of their representing \ elements. The subgroup is normal if and only if the RasterArray shows a neat \ square block structure. In many cases it will be easy to recognise the \ structure of the quotient group by this pattern. The above 6 by 6 block table \ is the multiplication table of permutations on 3 elements.\ \>", "Text"], Cell[TextData[{ "Getting back to the nice case of the 24 permutations on n=4 objects, with \ the Klein four-group its subgroup, all elements are ordered and colored into \ 6 colors by the raster above. The Klein four-group is the single red (Hue \ zero) block in the lower left hand corner. The whole table is really a 24 by \ 24 square table. This fact can be made clear by adding some options while \ rendering the ", StyleBox["Graphics", FontWeight->"Bold"], ": first define a ticks grid and then add the following options in ", StyleBox["Show", FontFamily->"Courier", FontWeight->"Bold"], ": " }], "Text"], Cell[CellGroupData[{ Cell[BoxData[ \(\(grid = Table[i, {i, 0, Length[perms]}];\)\)], "Input"], Cell[BoxData[ \(General::"spell1" \(\(:\)\(\ \)\) "Possible spelling error: new symbol name \"\!\(grid\)\" is similar to \ existing symbol \"\!\(Grid\)\"."\)], "Message"] }, Closed]], Cell[CellGroupData[{ Cell[BoxData[ \(Show[Graphics[RasterArray[g]]\n\t\t, GridLines \[Rule] {grid, grid}\n\t\t, AspectRatio \[Rule] Automatic]\)], "Input"], Cell[GraphicsData["PostScript", "\<\ %! %%Creator: Mathematica %%AspectRatio: 1 MathPictureStart /Mabs { Mgmatrix idtransform Mtmatrix dtransform } bind def /Mabsadd { Mabs 3 -1 roll add 3 1 roll add exch } bind def %% Graphics %%IncludeResource: font Courier %%IncludeFont: Courier /Courier findfont 10 scalefont setfont % Scaling calculations 0.0238095 0.0396825 0.0238095 0.0396825 [ [ 0 0 0 0 ] [ 1 1 0 0 ] ] MathScale % Start of Graphics 1 setlinecap 1 setlinejoin newpath 0 0 .5 r .25 Mabswid [ ] 0 setdash .02381 0 m .02381 1 L s .06349 0 m .06349 1 L s .10317 0 m .10317 1 L s .14286 0 m .14286 1 L s .18254 0 m .18254 1 L s .22222 0 m .22222 1 L s .2619 0 m .2619 1 L s .30159 0 m .30159 1 L s .34127 0 m .34127 1 L s .38095 0 m .38095 1 L s .42063 0 m .42063 1 L s .46032 0 m .46032 1 L s .5 0 m .5 1 L s .53968 0 m .53968 1 L s .57937 0 m .57937 1 L s .61905 0 m .61905 1 L s .65873 0 m .65873 1 L s .69841 0 m .69841 1 L s .7381 0 m .7381 1 L s .77778 0 m .77778 1 L s .81746 0 m .81746 1 L s .85714 0 m .85714 1 L s .89683 0 m .89683 1 L s .93651 0 m .93651 1 L s .97619 0 m .97619 1 L s 0 .02381 m 1 .02381 L s 0 .06349 m 1 .06349 L s 0 .10317 m 1 .10317 L s 0 .14286 m 1 .14286 L s 0 .18254 m 1 .18254 L s 0 .22222 m 1 .22222 L s 0 .2619 m 1 .2619 L s 0 .30159 m 1 .30159 L s 0 .34127 m 1 .34127 L s 0 .38095 m 1 .38095 L s 0 .42063 m 1 .42063 L s 0 .46032 m 1 .46032 L s 0 .5 m 1 .5 L s 0 .53968 m 1 .53968 L s 0 .57937 m 1 .57937 L s 0 .61905 m 1 .61905 L s 0 .65873 m 1 .65873 L s 0 .69841 m 1 .69841 L s 0 .7381 m 1 .7381 L s 0 .77778 m 1 .77778 L s 0 .81746 m 1 .81746 L s 0 .85714 m 1 .85714 L s 0 .89683 m 1 .89683 L s 0 .93651 m 1 .93651 L s 0 .97619 m 1 .97619 L s 0 0 m 1 0 L 1 1 L 0 1 L closepath clip newpath % Start of colorimage (RGB) p .02381 .02381 translate .95238 .95238 scale 72 string 24 24 8 [24 0 0 24 0 0] { \tcurrentfile \t1 index \treadhexstring \tpop } false 3 Mcolorimage FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF0000FF0000FF0000FF0000FF00 00FFFF00FFFF00FFFF00FFFF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00FF FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF0000FF0000FF0000FF0000FF00 00FFFF00FFFF00FFFF00FFFF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00FF FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF0000FF0000FF0000FF0000FF00 00FFFF00FFFF00FFFF00FFFF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00FF FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF0000FF0000FF0000FF0000FF00 00FFFF00FFFF00FFFF00FFFF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00FF FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00000000FF0000FF0000FF0000FF FF00FFFF00FFFF00FFFF00FF00FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00000000FF0000FF0000FF0000FF FF00FFFF00FFFF00FFFF00FF00FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00000000FF0000FF0000FF0000FF FF00FFFF00FFFF00FFFF00FF00FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00000000FF0000FF0000FF0000FF FF00FFFF00FFFF00FFFF00FF00FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF 00FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFFFF0000FF0000FF0000FF0000 FFFF00FFFF00FFFF00FFFF00FF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000FF 00FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFFFF0000FF0000FF0000FF0000 FFFF00FFFF00FFFF00FFFF00FF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000FF 00FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFFFF0000FF0000FF0000FF0000 FFFF00FFFF00FFFF00FFFF00FF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000FF 00FF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFFFF0000FF0000FF0000FF0000 FFFF00FFFF00FFFF00FFFF00FF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000FF 00FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00FF00FFFF00FFFF00FFFF00FF 0000FF0000FF0000FF0000FFFF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00 00FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00FF00FFFF00FFFF00FFFF00FF 0000FF0000FF0000FF0000FFFF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00 00FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00FF00FFFF00FFFF00FFFF00FF 0000FF0000FF0000FF0000FFFF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00 00FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00FF00FFFF00FFFF00FFFF00FF 0000FF0000FF0000FF0000FFFF0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00 0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00FFFFFF00FFFF00FFFF00FFFF00 FF0000FF0000FF0000FF000000FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00 0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00FFFFFF00FFFF00FFFF00FFFF00 FF0000FF0000FF0000FF000000FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00 0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00FFFFFF00FFFF00FFFF00FFFF00 FF0000FF0000FF0000FF000000FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00 0000FF0000FF0000FF0000FFFF00FFFF00FFFF00FFFF00FFFFFF00FFFF00FFFF00FFFF00 FF0000FF0000FF0000FF000000FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF00 FF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000FF00FFFF00FFFF00FFFF00FFFF 00FF0000FF0000FF0000FF00FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000 FF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000FF00FFFF00FFFF00FFFF00FFFF 00FF0000FF0000FF0000FF00FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000 FF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000FF00FFFF00FFFF00FFFF00FFFF 00FF0000FF0000FF0000FF00FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000 FF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000FF00FFFF00FFFF00FFFF00FFFF 00FF0000FF0000FF0000FF00FFFF00FFFF00FFFF00FFFF00FF0000FF0000FF0000FF0000 pop P % End of image % End of Graphics MathPictureEnd \ \>"], "Graphics", ImageSize->{288, 288}, ImageMargins->{{43, 0}, {0, 0}}, ImageRegion->{{0, 1}, {0, 1}}, AnimationDisplayTime->0.353448, ImageCache->GraphicsData["Bitmap", "\<\ CF5dJ6E]HGAYHf4PAg9QL6QYHg"], ImageRangeCache->{{{0, 287}, {287, 0}} -> {-0.600126, -0.600126, 0.0878058, \ 0.0878058}}], Cell[BoxData[ TagBox[\(\[SkeletonIndicator] Graphics \[SkeletonIndicator]\), False, Editable->False]], "Output"] }, Closed]], Cell["\<\ Another striking result is obtained if one makes a coloring for the \ elements in \"perms\" according to their position in the list \" l \" , by \ replacing Length[subg] by 1 in the coloring function: this means that we \ take a quotient by the one-element subgroup. It is then possible to toggle \ between this 24 by 24 coloring and the quotient blocks obtained above, and \ one sees even better how the elements get grouped into cosets: reddish \ elements in the red coset, yellowish elements in the yellow coset, and so on. \ \ \>", "Text"] }, Closed]], Cell[CellGroupData[{ Cell["Original colorcoding elements [ ]", "Subsection", Evaluatable->False, AspectRatioFixed->True, AnimationDisplayTime->0.353448], Cell[CellGroupData[{ Cell["Programming", "Subsubsection"], Cell["\<\ originalcolors[m_]:=Hue[(m-1)/Length[perms]] \ \>", "Input", AspectRatioFixed->True, AnimationDisplayTime->0.353448], Cell["\<\ The order of elements is again taken to be that of the list l :\ \ \>", "Text", AnimationDisplayTime->0.353448], Cell["\<\ mult[pos1_,pos2_]:= \tFirst[First[Position[perms, \t\tcomp[ perms[[l[[pos1]]]],perms[[l[[pos2]]]] ] \t\t\t\t\t]]]\ \>", "Input", AspectRatioFixed->True, AnimationDisplayTime->0.353448], Cell["\<\ m[pos1_,pos2_]:= \tFirst[ \t\tFirst[ \t\t\tPosition[l,mult[pos1,pos2]] \t\t] \t]\ \>", "Input", AspectRatioFixed->True, AnimationDisplayTime->0.353448], Cell["Finally all elements are colored individually", "Text", AnimationDisplayTime->0.353448], Cell["\<\ g1=Table[ \toriginalcolors[m[pos1,pos2]] \t,{pos1,Length[l]},{pos2,Length[l]} \t];\ \>", "Input", AspectRatioFixed->True, AnimationDisplayTime->0.353448], Cell[CellGroupData[{ Cell["\<\ Show[Graphics[ \tRasterArray[g1]] \t,AspectRatio->Automatic \t,GridLines\[Rule]{grid,grid}]\ \>", "Input", AspectRatioFixed->True, AnimationDisplayTime->0.353448], Cell[GraphicsData["PostScript", "\<\ %! %%Creator: Mathematica %%AspectRatio: 1 MathPictureStart /Mabs { Mgmatrix idtransform Mtmatrix dtransform } bind def /Mabsadd { Mabs 3 -1 roll add 3 1 roll add exch } bind def %% Graphics %%IncludeResource: font Courier %%IncludeFont: Courier /Courier findfont 10 scalefont setfont % Scaling calculations 0.0238095 0.0396825 0.0238095 0.0396825 [ [ 0 0 0 0 ] [ 1 1 0 0 ] ] MathScale % Start of Graphics 1 setlinecap 1 setlinejoin newpath 0 0 .5 r .25 Mabswid [ ] 0 setdash .02381 0 m .02381 1 L s .06349 0 m .06349 1 L s .10317 0 m .10317 1 L s .14286 0 m .14286 1 L s .18254 0 m .18254 1 L s .22222 0 m .22222 1 L s .2619 0 m .2619 1 L s .30159 0 m .30159 1 L s .34127 0 m .34127 1 L s .38095 0 m .38095 1 L s .42063 0 m .42063 1 L s .46032 0 m .46032 1 L s .5 0 m .5 1 L s .53968 0 m .53968 1 L s .57937 0 m .57937 1 L s .61905 0 m .61905 1 L s .65873 0 m .65873 1 L s .69841 0 m .69841 1 L s .7381 0 m .7381 1 L s .77778 0 m .77778 1 L s .81746 0 m .81746 1 L s .85714 0 m .85714 1 L s .89683 0 m .89683 1 L s .93651 0 m .93651 1 L s .97619 0 m .97619 1 L s 0 .02381 m 1 .02381 L s 0 .06349 m 1 .06349 L s 0 .10317 m 1 .10317 L s 0 .14286 m 1 .14286 L s 0 .18254 m 1 .18254 L s 0 .22222 m 1 .22222 L s 0 .2619 m 1 .2619 L s 0 .30159 m 1 .30159 L s 0 .34127 m 1 .34127 L s 0 .38095 m 1 .38095 L s 0 .42063 m 1 .42063 L s 0 .46032 m 1 .46032 L s 0 .5 m 1 .5 L s 0 .53968 m 1 .53968 L s 0 .57937 m 1 .57937 L s 0 .61905 m 1 .61905 L s 0 .65873 m 1 .65873 L s 0 .69841 m 1 .69841 L s 0 .7381 m 1 .7381 L s 0 .77778 m 1 .77778 L s 0 .81746 m 1 .81746 L s 0 .85714 m 1 .85714 L s 0 .89683 m 1 .89683 L s 0 .93651 m 1 .93651 L s 0 .97619 m 1 .97619 L s 0 0 m 1 0 L 1 1 L 0 1 L closepath clip newpath % Start of colorimage (RGB) p .02381 .02381 translate .95238 .95238 scale 72 string 24 24 8 [24 0 0 24 0 0] { \tcurrentfile \t1 index \treadhexstring \tpop } false 3 Mcolorimage FF0000FF4000FF8000FFC000FFFF00C0FF0080FF0040FF0000FF0000FF4000FF8000FFC0 00FFFF00C0FF0080FF0040FF0000FF4000FF8000FFC000FFFF00FFFF00C0FF0080FF0040 FF4000FF0000FFC000FF8000C0FF00FFFF0040FF0080FF0000FF4000FF0000FFC000FF80 00C0FF00FFFF0040FF0080FF4000FF0000FFC000FF8000FFFF00C0FF00FFFF0040FF0080 FF8000FFC000FF0000FF400080FF0040FF00FFFF00C0FF0000FF8000FFC000FF0000FF40 0080FF0040FF00FFFF00C0FF8000FFC000FF0000FF4000FFFF0080FF0040FF00FFFF00C0 FFC000FF8000FF4000FF000040FF0080FF00C0FF00FFFF0000FFC000FF8000FF4000FF00 0040FF0080FF00C0FF00FFFFC000FF8000FF4000FF0000FFFF0040FF0080FF00C0FF00FF FFFF00C0FF0040FF0080FF00FF0000FF4000FFC000FF80000000FF4000FFC000FF8000FF FF00FFFF00C0FF0040FF008000FF0000FF4000FFC000FF8000FFFF00C0FF0040FF0080FF C0FF00FFFF0080FF0040FF00FF4000FF0000FF8000FFC0004000FF0000FF8000FFC000FF FF00C0FF00FFFF0080FF004000FF4000FF0000FF8000FFC000C0FF00FFFF0080FF0040FF 80FF0040FF00C0FF00FFFF00FF8000FFC000FF4000FF00008000FFC000FF4000FF0000FF FF0080FF0040FF00C0FF00FF00FF8000FFC000FF4000FF000080FF0040FF00C0FF00FFFF 40FF0080FF00FFFF00C0FF00FFC000FF8000FF0000FF4000C000FF8000FF0000FF4000FF FF0040FF0080FF00FFFF00C000FFC000FF8000FF0000FF400040FF0080FF00FFFF00C0FF 00FF0000FF8000FF4000FFC000FFFF0080FF00C0FF0040FFFF0000FF8000FF4000FFC000 FFFF0080FF00C0FF0040FF00FF00FFFF0080FF00C0FF00400000FF8000FF4000FFC000FF 00FF4000FFC000FF0000FF8000C0FF0040FF00FFFF0080FFFF4000FFC000FF0000FF8000 C0FF0040FF00FFFF0080FF00FF00C0FF0040FF00FFFF00804000FFC000FF0000FF8000FF 00FF8000FF0000FFC000FF400080FF00FFFF0040FF00C0FFFF8000FF0000FFC000FF4000 80FF00FFFF0040FF00C0FF00FF0080FF00FFFF0040FF00C08000FF0000FFC000FF4000FF 00FFC000FF4000FF8000FF000040FF00C0FF0080FF00FFFFFFC000FF4000FF8000FF0000 40FF00C0FF0080FF00FFFF00FF0040FF00C0FF0080FF00FFC000FF4000FF8000FF0000FF 00FFFF0080FF0040FF00C0FF00FF0000FF8000FFC000FF40FF00FFFF0080FF0040FF00C0 0000FF8000FFC000FF4000FFFF0000FF8000FFC000FF4000FFFF0080FF0040FF00C0FF00 00C0FF0040FF0080FF00FFFF00FF4000FFC000FF8000FF00FF00C0FF0040FF0080FF00FF 4000FFC000FF8000FF0000FFFF4000FFC000FF8000FF0000C0FF0040FF0080FF00FFFF00 0080FF00FFFF00C0FF0040FF00FF8000FF0000FF4000FFC0FF0080FF00FFFF00C0FF0040 8000FF0000FF4000FFC000FFFF8000FF0000FF4000FFC00080FF00FFFF00C0FF0040FF00 0040FF00C0FF00FFFF0080FF00FFC000FF4000FF0000FF80FF0040FF00C0FF00FFFF0080 C000FF4000FF0000FF8000FFFFC000FF4000FF0000FF800040FF00C0FF00FFFF0080FF00 0000FFC000FF4000FF8000FFFF00FFFF0040FF00C0FF0080FFFF0040FF00C0FF0080FF00 FF0000FFC000FF4000FF800000FFFF0040FF00C0FF0080FF00FF0000FFC000FF4000FF80 4000FF8000FF0000FFC000FFFF00C0FF0080FF00FFFF0040C0FF0080FF00FFFF0040FF00 FF4000FF8000FF0000FFC00000C0FF0080FF00FFFF0040FF00FF4000FF8000FF0000FFC0 8000FF4000FFC000FF0000FFFF0080FF00C0FF0040FF00FF80FF00C0FF0040FF00FFFF00 FF8000FF4000FFC000FF00000080FF00C0FF0040FF00FFFF00FF8000FF4000FFC000FF00 C000FF0000FF8000FF4000FFFF0040FF00FFFF0080FF00C040FF00FFFF0080FF00C0FF00 FFC000FF0000FF8000FF40000040FF00FFFF0080FF00C0FF00FFC000FF0000FF8000FF40 FF00FFFF0040FF0080FF00C00000FFC000FF8000FF4000FF00FFFF0040FF0080FF00C0FF 00FF0000FFC000FF8000FF40FFFF0040FF0080FF00C0FF00FF0000FFC000FF8000FF4000 FF00C0FF0080FF0040FF00FF4000FF8000FFC000FF0000FF00C0FF0080FF0040FF00FFFF 00FF4000FF8000FFC000FF00C0FF0080FF0040FF00FFFF00FF4000FF8000FFC000FF0000 FF0080FF00C0FF00FFFF00408000FF4000FF0000FFC000FF0080FF00C0FF00FFFF0040FF 00FF8000FF4000FF0000FFC080FF00C0FF00FFFF0040FF00FF8000FF4000FF0000FFC000 FF0040FF00FFFF00C0FF0080C000FF0000FF4000FF8000FF0040FF00FFFF00C0FF0080FF 00FFC000FF0000FF4000FF8040FF00FFFF00C0FF0080FF00FFC000FF0000FF4000FF8000 pop P % End of image % End of Graphics MathPictureEnd \ \>"], "Graphics", ImageSize->{288, 288}, ImageMargins->{{43, 0}, {0, 0}}, ImageRegion->{{0, 1}, {0, 1}}, AnimationDisplayTime->0.353448, ImageCache->GraphicsData["Bitmap", "\<\ CF5dJ6E]HGAYHf4PAg9QL6QYHg"], ImageRangeCache->{{{0, 287}, {287, 0}} -> {-0.600126, -0.600126, 0.0878058, \ 0.0878058}}], Cell[BoxData[ TagBox[\(\[SkeletonIndicator] Graphics \[SkeletonIndicator]\), False, Editable->False]], "Output"] }, Closed]], Cell["\<\ The best result is seen when we toggle between this last picture \ and the one with the quotient: it is clear which elements fall in which \ coset.\ \>", "Text", AnimationDisplayTime->0.353448], Cell["g=Table[colors[m[pos1,pos2]],{pos1,1},{pos2,Length[l]}];", "Input", AspectRatioFixed->True], Cell[CellGroupData[{ Cell["\<\ Show[Graphics[ \tRasterArray[g]] \t,AspectRatio->Auto