(* +-------------+ *) (* | Tessellations of the Euclidean, Elliptic and Hyperbolic Plane | *) (* +----------------------------------------------------------------------+ *) (* | Name: Tess.m | *) (* | | *) (* | Authors: Miodrag Sremcevic (msremac@agnld.uni-potsdam.de) | *) (* | Radmila Sazdanovic (seasmile@galeb.etf.bg.ac.yu) | *) (* | | *) (* | Copyright: (c) 2002 | *) (* | | *) (* | Version: 1.7, 12. September 2002 (for Mathematica 4.0) | *) (* | | *) (* | Usage: TessUsage.nb | *) (* | | *) (* | Context: "Tess`" | *) (* | | *) (* | WWW (soon): http://www.agnld.uni-potsdam.de/~msremac | *) (* | http://galeb.etf.bg.ac.yu/~seasmile | *) (* | | *) (* | Requirements: L2Primitives.m by I. Knezevic, R. Sazdanovic & | *) (* | S. Vukmirovic (www.MathSource.com) | *) (* | http://www.MathSource.com/Content/Applications/Graphics/2D/0211-879 | *) (* | | *) (* | Keywords: Tessellation, Tiling, Hyperbolic plane, | *) (* | Lobachevskian plane, Polyhedra, Elliptic plane | *) (* | | *) (* | History: 0.9.3 22.01.2002 zeroth version | *) (* | 1.1 27.01.2002 first normal version | *) (* | 1.4 07.03.2002 Matomium conference, Bruxelles | *) (* | 1.6.3 15.05.2002 Poster presentation, Belgrade | *) (* | 1.7 12.09.2002 submitted to MathSource | *) (* +----------------------------------------------------------------------+ *) (* | Tess is a package for generation and drawing of Archimedean | *) (* | (including regular and uniform) tessellations in Euclidean (E2), | *) (* | Elliptic (S2 - polyhedra), and Lobachevskian (L2, or hyperbolic) | *) (* | plane. The tiles of Archimedean tessellations are regular polygons | *) (* | and all vertices are of the same type. Tessellations are given with | *) (* | their vertex configuration. The vertex configuration does not | *) (* | define uniquely tiling, and the program calculates, for a given | *) (* | vertex configuration, all different (if any) realizations of the | *) (* | tiling. The package correctly finds all uniform (semi-regular) | *) (* | tilings, Archimedean tilings which are not uniform, and also | *) (* | `colored' realizations. A typical command for drawing a tiling is | *) (* | TessShow[{4,4,4,6}]. Beside the drawing of tessellations, the | *) (* | program provides additional data, such as: geometry and type of | *) (* | tessellation, number of possible realizations, angles of tiles and | *) (* | transformation rules between neighboring vertices. The drawing in | *) (* | hyperbolic plane is realized using I. Knezevic, R. Sazdanovic & | *) (* | S. Vukmirovic package L2Primitives (www.MathSource.com). | *) (* +----------------------------------------------------------------------+ *) (* | Functions: | *) (* | Tess[ Vertex ] | *) (* | TessGraphics[ Vertex | Tiling ] | *) (* | TessShow[ Vertex | Tiling ] | *) (* | TessCompare[ Vertex1 , Vertex2 ] | *) (* | Faces[ Tiling ] | *) (* | Vertices[ Tiling ] | *) (* | SearchVertices[Order,Sum,Polyg,N,NumReal,Total,NumUnion,Prism] | *) (* +----------------------------------------------------------------------+ *) (* ######################################################################## *) (* ## CONTEXT AND GLOBALS ## *) (* ######################################################################## *) BeginPackage["Tess`"] Needs["L2Primitives`"] Info; NPolygons; Test; Realization; Border; Annotate; Thickness; PolygonColor; LOrigin; FirstPoly; TessGraph; L2; S2; E2; Sphere; Tess::usage = "Tess[ Vertex ] where Vertex={n1,...,nN} , n1,...,nN,N>=3 , is a vector containing vertex configuration (example {5,3,3,3,3}). If called with option Test->All or Test->On procedure just tests existance of the input tesselation. Otherways it gives object with a head: TessGraph, containing the tesselation, or False if tesselation does not exist." TessGraphics::usage = "TessGraphics[ Input ] gives Graphics primitives of the input tesselation. Input can be vertex configuration {n1,...,nN} or TessGraph object." TessShow::usage = "TessShow[ Input ] plots the input tesselation. Input can be vertex configuration {n1,...,nN} or TessGraph object." TessCompare::usage = "TessCompare[ Vertex1 , Vertex2 ]" Faces::usage = "Faces[ x ] returns coordinates of faces of the input TessGraph object." Vertices::usage = "Vertices[ x ] returns coordinates of vertices of the input TessGraph object." SearchVertices::usage = "SearchVertices[Order,Sum,Polygons,N,NumRealizations,Total,NumUnion,Prism] returns the vertices that correspond to the given conditions. Examples: SearchVertices[0,2, 12, 5, Infinity, Infinity, {2, Infinity}] will find all 8 uniform E2 tesselations excluding regular SearchVertices[0,{0,1.99},10,5,Infinity,Infinity,{2,Infinity},False] finds all 13 uniform S2 excluding regular, prisms and antiprisms." Begin["`Private`"] (* ######################################################################## *) lRemember = False; Options[ Tess ] = { Info->On , NPolygons->100 , Test->Off , Realization->1 , LOrigin->Automatic , FirstPoly->Automatic , Order->1 }; Tess[ lInput_List?fVertexQ , opts___Rule ] := Module[ { oTest,oInfo,oNPolygons,oLOrigin,oRealization,oFirstPoly, lVertex,lAll,oOrder,iTmp,iI } , oTest = Test /. {opts} /. Options[ Tess ]; oInfo = Info /. {opts} /. Options[ Tess ]; oNPolygons = NPolygons /. {opts} /. Options[ Tess ]; oLOrigin = LOrigin /. {opts} /. Options[ Tess ]; oRealization = Realization /. {opts} /. Options[ Tess ]; oFirstPoly = FirstPoly /. {opts} /. Options[ Tess ]; oOrder = Order /. {opts} /. Options[ Tess ]; lVertex = fMakeAllSymm[ lInput ] // First; If[ Head[lRemember]===List && lRemember[[1]]===lVertex && Length[lRemember]===3 && ( oOrder===0 && lRemember[[3]]===0 || oOrder>0 && lRemember[[3]]>=oOrder ) , lAll = lRemember[[2]]; , If[ oOrder===0 , lAll = fFindRealizations[ Range[ Length[lVertex] ] , fMakeRule[lVertex] // First ]; , If[ Head[lRemember]===List && lRemember[[1]]===lVertex && lRemember[[3]]>0 , lAll = lRemember[[2]]; iTmp = lRemember[[3]]; , lAll = {}; iTmp = 1; ]; Do[ lAll = fFindNewRealizations[ lVertex , iI , lAll ] ,{iI,iTmp,oOrder}]; ]; lRemember = { lVertex , lAll , oOrder }; ]; If[ oInfo===On , fPrintInfo[lVertex,lAll]; ]; If[ oTest===All , Return[ Length[ lAll ] ]; ]; If[ oTest===On , Return[ lAll =!= {} ]; ]; If[ oTest===List , Return[ lAll ]; ]; If[ Length[lAll]ToString[iO] ], If[ sS==="Snub" , " Snub" , "" ] }] // DisplayForm; Options[ TessGraphics ] = { Model->Automatic , Annotate ->On , PlotPoints->Automatic , Border->On , Thickness->0.005 , PolygonColor->List , Line->On , Polygon->On , EdgeForm->0.05 }; TessGraphics[ lGraph_?fVertexQ , opts___Rule ] := Module[ { oModel,oPlotPoints,oLine,oBorder,oThickness,oAnnotate,oPolygonColor, lVertex,lVertNext,lVertPoly,lFaceVert,lVertCoord,lFacePoly,lRealization, lTemp,iS,oGeometry,iN,lUnion,lSum,fPoly,fGraphics, lProlog,lEpilog,oGraphics,lOutput } , oModel = Model /. {opts} /. Options[ TessGraphics ]; oPlotPoints = PlotPoints /. {opts} /. Options[ TessGraphics ]; oLine = Line /. {opts} /. Options[ TessGraphics ]; oPolygon = Polygon /. {opts} /. Options[ TessGraphics ]; oBorder = Border /. {opts} /. Options[ TessGraphics ]; oThickness = Thickness /. {opts} /. Options[ TessGraphics ]; oAnnotate = Annotate /. {opts} /. Options[ TessGraphics ]; oPolygonColor = PolygonColor /. {opts} /. Options[ TessGraphics ]; oEdgeForm = EdgeForm /. {opts} /. Options[ TessGraphics ]; If[ oEdgeForm=!=0 && oEdgeForm>0 , oEdgeForm = oEdgeForm * oThickness ]; If[ oEdgeForm<0 , oEdgeForm = - oEdgeForm ]; If[ Head[lGraph]===TessGraph , {lVertex,lVertNext,lVertPoly,lFaceVert,lVertCoord,lFacePoly,lRealization} = List @@ lGraph ; , lTemp = Tess[lGraph , Test->Off , fFilterOptions[Tess,opts] , Info->Off]; If[ Head[lTemp] =!= TessGraph , Print["INPUT TESSELATION DOES NOT EXIST: Check Tess[", lGraph,",Test->All] first!"]; Abort[]; ]; {lVertex,lVertNext,lVertPoly,lFaceVert,lVertCoord,lFacePoly,lRealization} = List @@ lTemp ; ]; {iS,oGeometry,iN,lUnion,lSum} = fBasicProperties[ lVertex ]; If[ oGeometry===S2 && oModel===Automatic , oModel=Polygon ]; If[ oGeometry===L2 && oModel===Automatic , oModel=PoincareDisk ]; If[ oGeometry===S2 && oPlotPoints===Automatic , oPlotPoints=2 ]; If[ oGeometry===L2 && oPlotPoints===Automatic , oPlotPoints=20 ]; fMakeFuncPoly[ fPoly ,oGeometry,oModel,oPlotPoints,oLine,oPolygon, fMakeFuncColor[ oPolygonColor , lRealization ] , oEdgeForm ]; fGraphics = If[ oGeometry===S2 , Graphics3D , Graphics ]; lProlog = {}; If[ oLine===On , AppendTo[ lProlog , Thickness[oThickness] ]; ]; lEpilog = {}; If[ oGeometry===L2 && oBorder===On, If[ oModel===KleinDisk || oModel===PoincareDisk , AppendTo[ lEpilog , Circle[{0,0},1] ]; If[ oAnnotate===On , sTmp1 = "<" <> StringDrop[(StringJoin@@Map[ (ToString[#]<>",")& , lVertex ]),-1] <> ">"; sTmp2 = If[ lRealization[[3]]===1, "Uniform" , "NonUni^"<>ToString[lRealization[[3]]] ]; sTmp3 = If[ lRealization[[4]]==="Snub" ,"Snub" ,"" ]; lEpilog = Join[ lEpilog , { Text[sTmp1,{-1,1},{-1,1}] , Text[sTmp2,{-1,.9},{-1,1}] , Text[sTmp3,{-1,.8},{-1,1}] } ]; ]; , AppendTo[ lEpilog , Line[ {{-10,0},{10,0}} ] ]; ]; ]; oGraphics = {}; If[ oGeometry=!=S2 , AppendTo[ oGraphics , AspectRatio->Automatic ]; ]; If[ Head[oPolygon]===List, fErasePolygons[oPolygon , fPoly , lRealization ]; ]; fGraphics[{ Sequence @@ lProlog , MapIndexed[ fPoly , Thread[{ Map[ lVertCoord[[#]]& , lFaceVert ] , lFacePoly }] ] , Sequence @@ lEpilog }, fFilterOptions[fGraphics,opts] , Sequence @@ oGraphics ] ]; TessGraphics[ x___ ] := Message[ TessGraphics::usage ]; TessShow[ lGraph_?fVertexQ , opts___Rule ] := Module[ {lVertex,iS,oGeometry,iN,lUnion,lSum,oModel} , If[ Head[lGraph]===TessGraph , lVertex = lGraph[[1]]; , lVertex = lGraph; ]; {iS,oGeometry,iN,lUnion,lSum} = fBasicProperties[ lVertex ]; oModel = Model /. {opts} /. Options[ TessGraphics ]; If[ oGeometry===S2 && oModel===Automatic , oModel=Polygon ]; If[ oGeometry===L2 && oModel===Automatic , oModel=PoincareDisk ]; If[ oGeometry === E2 , Show[ TessGraphics[ lGraph, fFilterOptions[ TessGraphics , opts ] , fFilterOptions[ Tess , opts ] , Info -> Off ] , fFilterOptions[ Graphics , opts ] , AspectRatio -> Automatic ] // Return ]; If[ oGeometry === L2 , Show[ TessGraphics[ lGraph, fFilterOptions[ TessGraphics , opts ] , fFilterOptions[ Tess , opts ] , Info -> Off ] , fFilterOptions[ Graphics , opts ] , AspectRatio -> Automatic , If[ oModel === HalfPlane , PlotRange -> {{-5,5},{-0.05,5}} , PlotRange -> {{-1.02,1.02},{-1.02,1.02}} ] ] // Return ]; Show[ TessGraphics[ lGraph, fFilterOptions[ TessGraphics , opts ] , fFilterOptions[ Tess , opts ] , Info -> Off ] , fFilterOptions[ Graphics3D , opts ] , PlotRange -> {{-1, 1}, {-1, 1}, {-1, 1}} ] ]; TessShow[ x___ ] := Message[ TessShow::usage ] ; TessCompare[ Vertex1_List?fVertexQ , Vertex2_List?fVertexQ ] := ( If[ Length[Vertex1] =!= Length[Vertex2] , Return[False] ]; MemberQ[ fMakeAllSymm[Vertex2] , Vertex1 ] ); TessCompare[ x___ ] := Message[ TessComapre::usage ]; Faces [ lGraph_TessGraph?fVertexQ ] := Map[ lGraph[[5]][[#]]& , lGraph[[4]] ]; Vertices[ lGraph_TessGraph?fVertexQ ] := lGraph[[5]] ; Faces[ x___ ] := Message[ Faces::usage ]; Vertices[ x___ ] := Message[ Vertices::usage ]; lL2Isometries = { L2Reflection, L2Translation , L2Rotation }; TessGraph /: (f_)[arg___][ g_TessGraph?fVertexL2Q ] := MapAt[ Map[ f[arg] , # ] & , g , 5 ] /; MemberQ[lL2Isometries, f] SearchVertices[ oOrder_:1 , oSum_:2 , oPoly_:6 , oN_:5 , oReal_:Infinity , oTot_:100 , oU_:Infinity , oPrism_:True ]:= Module[ { iS1,iS2,iP1,iP2,iN1,iN2,iR1,iR2,iU1,iU2, lAllV={},lAllS={},lAllR={},lBad={}, iT,lComb,iJ,iN,iS,lVertex,iR,iOut,iU,fPrism } , If[ Head[oSum]===List , {iS1,iS2} = oSum; , iS1 = iS2 = oSum; ]; If[ Head[oPoly]===List , {iP1,iP2} = oPoly; , iP1 = 3; iP2 = oPoly; ]; If[ Head[oN]===List , {iN1,iN2} = oN; , iN1 = 3; iN2 = oN; ]; If[ Head[oReal]===List , {iR1,iR2} = oReal; , iR1 = 1; iR2 = oReal; ]; If[ Head[oU]===List , {iU1,iU2} = oU; , iU1 = 1; iU2 = oU; ]; If[ oPrism===True, fPrism = True&; , fPrism[{3, 4, 4} ] := False; fPrism[{3, 3, 3, x_? ( # != 3 & )} ] := False; fPrism[{4, 4, x_? ( # != 4 & )} ] := False; fPrism[ x___ ] := True; ]; iT = 0; lComb = Table[ (iP2-iP1+1)^iI , {iI,iN1,iN2} ]; Do[ iJ = iI; iN = 1; While[ iJ>=lComb[[iN]] , iJ -= lComb[[iN++]] ]; iN += iN1 - 1; lVertex = Table[ iOut = Mod[ iJ , iP2-iP1+1 ] + iP1; iJ = Quotient[ iJ , iP2-iP1+1 ]; iOut ,{iN}]; iS = Plus @@ ((lVertex-2)/lVertex); If[ iS>=iS1 && iS<=iS2 , iU = Length[ lVertex // Union ]; If[ iU>=iU1 && iU<=iU2 , lVertex = fMakeAllSymm[lVertex] // First; If[ fPrism[lVertex] && !MemberQ[lAllV,lVertex] && !MemberQ[lBad,lVertex], iR = Tess[ lVertex , Test->All , Info->Off , Order->oOrder ]; If[ iR>=iR1 && iR<=iR2 , AppendTo[ lAllV , lVertex ]; AppendTo[ lAllS , iS ]; AppendTo[ lAllR , iR ]; If[ ++iT >= oTot , Break[]; ]; , AppendTo[ lBad , lVertex ]; ]; ]; ]; ]; ,{iI,0,(Plus @@ lComb)-1}]; Thread[ { lAllV , lAllS , lAllR } ] ]; SearchVertices[ x___ ] := Message[ SearchVertices::usage ]; Options[ fPrintInfo ] = { Info->On }; fPrintInfo[ lVertex_ ,lRealizations_ , opts___Rule ] := Module[ { iS,oGeometry,iN,lUnion,lSum,oAlpha,oR,rEdge,oInfo, oPolygons,oGroup,sUniform,sSnub,oPolySize,sTmp,lTmp,lNew } , oInfo = Info /. {opts} /. Options[ fPrintInfo ]; {iS,oGeometry,iN,lUnion,lSum} = fBasicProperties[ lVertex ]; { oAlpha , oR , rEdge } = fAngles[ lVertex ]; If[ oInfo===On , Print["Vertex:",lVertex," Geometry:",oGeometry," Sum:",iS]; Print["Fund. triang.:", Thread[ SuperscriptBox[lUnion,lSum] ]//MatrixForm// DisplayForm , " Alpha=",oAlpha//MatrixForm, " R=",oR//MatrixForm," Edge=",rEdge ]; ]; If[ lRealizations==={} , Print["Tesselation does not exist!"]; Return[]; ]; Do[ {oPolygons,oGroup,sUniform,sSnub} = lRealizations[[iI]]; oPolySize = Map[ (First[#]->Length[Last[#]])& , oPolygons ]; oPolygons = Map[ (lTmp=Last[#]; Map[ (lNew=Drop[#,1]; If[lNew=!={}, SubscriptBox[First[#], "("<>StringDrop[StringJoin@@Map[ToString[#]<>","&,lNew] ,-1]<>")" ] // DisplayForm ,#//First] )& ,lTmp] )& , oPolygons]; sTmp = If[ sUniform===1, " Uniform" , " NonUni^"<>ToString[sUniform] ]; If[ sSnub==="Snub" , sTmp = sTmp<>" Snub";]; If[ oInfo===On , Print["Realization#",iI," Vertex:",oGroup[[1,1]],sTmp]; Print[" Polygons:",oPolySize//MatrixForm,oPolygons//MatrixForm]; Print[" Group:",oGroup//MatrixForm]; , Print["P:",oPolySize//MatrixForm,oPolygons//MatrixForm, "G:",oGroup//MatrixForm," ",sUniform," ",sSnub]; ]; ,{iI,Length[lRealizations]}]; ]; fAngles[ lVertex_ ] := Module[ { iNumError,rDelta,lOther,rAOld,rANew, iS,oGeometry,iN,lUnion,lSum, lAlpha,lR,rEdge } , {iS,oGeometry,iN,lUnion,lSum} = fBasicProperties[ lVertex ]; If[ oGeometry===E2 , Return[ { Thread[ lUnion -> N[Pi(lUnion-2)/lUnion] ] , Thread[ lUnion -> N[1/2/Sin[Pi/lUnion] ] ] , N[1] } ]; ]; If[ Length[lUnion] == 1 , lAlpha = {2 Pi / iN}; , iNumError = Max[ $MachinePrecision , $MinPrecision ]; lAlpha = Pi (lUnion-2)/lUnion ; While[ rDelta = 2 * Pi - Apply[ Plus , lAlpha * lSum]; Abs[ rDelta ] > 10^(-iNumError) , lOther = Drop[ lAlpha , -1 ]; rAOld = Last[ lAlpha]; rANew = rAOld + rDelta * Tan[ rAOld/2 ] / Apply[ Plus , Tan[ lAlpha/2 ] * lSum]; lOther = 2 * ArcSin[ Cos[Pi/Drop[lUnion,-1]] / Cos[Pi/Last[lUnion]] * Sin[rANew/2] ]; lAlpha = N[ Append[ lOther , rANew ] , 2*iNumError ]; ]; ]; If[ oGeometry === S2 , rEdge = 2 ArcCos [ Cos[Pi/Last[lUnion]] / Sin[Last[lAlpha]/2] ]; lR = ArcCos [ Cot[Pi/lUnion] Cot[lAlpha/2] ]; , rEdge = 2 ArcCosh[ Cos[Pi/Last[lUnion]] / Sin[Last[lAlpha]/2] ]; lR = ArcCosh[ Cot[Pi/lUnion] Cot[lAlpha/2] ]; ]; { Thread[ lUnion -> N[lAlpha] ] , Thread[ lUnion -> N[lR] ] , N[ rEdge ] } ]; fPolygon[ iNumber_ , {oAlpha_,oR_,rEdge_} , geometry -> S2 ] := Module[ {rR,rPhi}, rR = iNumber /. oR; Table[ rPhi = - iI 2 Pi / iNumber; { Sin[ rR ] Cos[ rPhi ], Sin[ rR ] Sin[ rPhi ], Cos[ rR ] } ,{iI,0,iNumber-1}] // N ]; fPolygon[ iNumber_ , {oAlpha_,oR_,rEdge_} , geometry -> E2 ] := N[ Table[ { Cos[-2*iI*Pi/iNumber] , Sin[-2*iI*Pi/iNumber] } ,{iI,0,iNumber-1}] * (iNumber /. oR) ] fPolygon[ iNumber_ , {oAlpha_,oR_,rEdge_} , geometry -> L2 ] := Module[ {rR,iI,rPhi}, rR = Tanh[ iNumber /. oR ]; Table[ rPhi = - iI 2 Pi / iNumber; LPoint[ N[ rR * { Cos[rPhi] , Sin[rPhi] } ] ] ,{iI,0,iNumber-1}] ]; fRotate[ lA_ , lB_ , iNumber_ , {oAlpha_,oR_,rEdge_} , geometry -> E2 ] := Module[ {lD,rAlpha} , rAlpha = iNumber /. oAlpha; lD = lA - lB; N[ lB + { lD[[1]]*Cos[rAlpha] + lD[[2]]*Sin[rAlpha] , -lD[[1]]*Sin[rAlpha] + lD[[2]]*Cos[rAlpha] } ] ]; fRotate[ lA_ , lB_ , iNumber_ , {oAlpha_,oR_,rEdge_} , geometry -> L2 ] := L2Rotation[ lB , iNumber /. oAlpha ][ lA ] ; fRotate[ lA_ , lB_ , iNumber_ , {oAlpha_,oR_,rEdge_} , geometry -> S2 ] := fE3Rotate[ lB , -(iNumber /. oAlpha) , lA ]; fE3Rotate[lN_ , rPhi_ , lB_ ] := Module[{rTmp=lN.lN,ln}, If[ rTmp == 0 , Return[ lB ] ]; ln = lN / Sqrt[ rTmp ]; N[ lB*Cos[rPhi] + ln*(ln.lB)*(1-Cos[rPhi]) + Cross[ln,lB]*Sin[rPhi] ] ]; Options[ fS2Polygon ] = { PlotPoints->2 }; fS2Polygon[ lList_ , opts___ ] := Module[ {oPlotPoints,lCenter,iN,iI} , oPlotPoints = PlotPoints /. {opts} /. Options[ fS2Polygon ]; If[ (iN=Length[lList]) == 3 , fS2Triangle[ lList , oPlotPoints ] // Flatten , lCenter = (Plus @@ lList) // fNormVector; Table[ fS2Triangle[ { lList[[iI]] , lList[[Mod[iI+1,iN,1]]] , lCenter } ,oPlotPoints] ,{iI,iN}] // Flatten ] ]; fS2Triangle[ {lX_,lY_,lZ_} , iNum_ ] := Module[ {lA,lB,lC} , lA = fNormVector[ lX + lY ]; lB = fNormVector[ lY + lZ ]; lC = fNormVector[ lZ + lX ]; { fS2Triangle[ { lA , lB , lY } , iNum-1 ] , fS2Triangle[ { lB , lC , lZ } , iNum-1 ] , fS2Triangle[ { lC , lA , lX } , iNum-1 ] , fS2Triangle[ { lA , lB , lC } , iNum-1 ] } ]; fS2Triangle[ {lX_,lY_,lZ_} , 0 ] := Polygon[ { lX , lY , lZ } ] ; fNormVector[ lA_ ] := lA / Sqrt[lA.lA] ; Options[ fS2Line ] = { PlotPoints->20 }; fS2Line[ lAA_ , lBB_ , opts___Rule ] := Module[{lC,oPlotPoints,rAngle,iI}, oPlotPoints = PlotPoints /. {opts} /. Options[ fS2Line ]; rAngle = ArcCos[ lAA . lBB ]; lC = Cross[ lAA , lBB ] // fNormVector; Table[ fE3Rotate[ lC , iI*rAngle/(oPlotPoints+1) , lAA ] // fNormVector ,{iI,0,oPlotPoints+1}] ]; fErasePolygons[oPolygon_ , fMake_ , {oPolygons_,oGroup_,sUniform_,sSnub_} ] := Module[ { lVirtPolygons,oPolySize,lVertex,iS,oGeometry,iN,lUnion,lSum, iI,iJ,lTmp } , lVirtPolygons = Map[ First , oPolygons ]; oPolySize = Map[ (First[#]->Length[Last[#]])& , oPolygons ]; lVertex = oGroup[[1, 1]] /. oPolySize; {iS,oGeometry,iN,lUnion,lSum} = fBasicProperties[ lVertex ]; oRules = Head[oPolygon]===List && (And @@ Map[ (Head[#]===Rule)&,oPolygon]); If[ oRules && And @@ Map[ ( MemberQ[lVirtPolygons,#//First] && MemberQ[{On,Off},#//Last] )& ,oPolygon] , Do[ If[ oPolygon[[iI,2]]===Off, fMake[{lCoords_,oPolygon[[iI,1]]},{iNum_}] := Sequence[]; ]; ,{iI,oPolygon//Length}]; Return[]; ]; If[ oRules && And @@ Map[ ( MemberQ[lVertex,#//First] && MemberQ[{On,Off},#//Last] )& ,oPolygon] , Do[ If[ oPolygon[[iI,2]]===Off , lTmp = Map[First, Select[oPolySize, (Last[#]===oPolygon[[iI,1]])& ]]; Do[ fMake[{lCoords_,lTmp[[iJ]]},{iNum_}] := Sequence[]; ,{iJ,lTmp//Length}]; ]; ,{iI,oPolygon//Length}]; Return[]; ]; ]; fMakeFuncColor[ oPolygonColor_ , {oPolygons_,oGroup_,sUniform_,sSnub_} ] := Module[ { lVirtPolygons,oPolySize,lVertex,iS,oGeometry,iN,lUnion,lSum, lTmp,iTmp,oRules,lDummy,lDummy2,oNewRules } , lVirtPolygons = Map[ First , oPolygons ]; oPolySize = Map[ (First[#]->Length[Last[#]])& , oPolygons ]; lVertex = oGroup[[1, 1]] /. oPolySize; {iS,oGeometry,iN,lUnion,lSum} = fBasicProperties[ lVertex ]; If[ oPolygonColor===Random , Return[ RGBColor[Random[], Random[], Random[] ] & ]; ]; If[ oPolygonColor===1 , Return[ Block[{iI,iJ,iL,iK,lTemp}, iL = Mod[ # , 3 ]; iI = Mod[ IntegerPart[ -# / 3 ] , 5 ]; iJ = Mod[ IntegerPart[ -# / 15 ] , 5 ]; iK = 4 - Mod[ IntegerPart[ -# / 125 ] , 5 ]; lTemp = RotateLeft[ {iI,iJ,iK} , iL ]; RGBColor[ Sequence @@ (lTemp/4) ] ] & ] ]; If[ oPolygonColor===2 , Return[ Hue[( FromDigits[Reverse[IntegerDigits[Mod[# - 1, 64], 2, 8]], 2] + 1 ) / 255 ] & ] ]; If[ oPolygonColor===GrayLevel , With[ {lDummy=Length[oPolySize]+1} , GrayLevel[ (lDummy-#2)/lDummy ]& ] // Return ]; If[ oPolygonColor===Hue , lTmp = Map[ Last , oPolySize ] // Reverse // fUnsortedUnion; iTmp = Length[lUnion]; fMakeFuncColor[ Thread[lTmp -> (Range[iTmp] - 1)/iTmp] , {oPolygons,oGroup,sUniform,sSnub} ] // Return ]; If[ oPolygonColor===Union , lTmp = Map[ Last , oPolySize ] // Reverse // fUnsortedUnion; iTmp = Length[lUnion]; With[ {lDummy=Thread[lTmp -> (Range[iTmp] - 1)/iTmp],lDummy2=oPolySize} , Hue[#2 /. lDummy2 /. lDummy] & ] // Return ]; If[ oPolygonColor===List , lTmp = Map[ First , oPolySize ] // Reverse ; iTmp = Length[ oPolySize ]; With[ {lDummy=Thread[lTmp -> (Range[iTmp] - 1)/iTmp]} , Hue[#2 /. lDummy] & ] // Return ]; oRules = Head[oPolygonColor]===List && (And @@ Map[ (Head[#]===Rule)&,oPolygonColor]); If[ oRules && And @@ Map[ ( MemberQ[lVertex,#//First] && NumberQ[#//Last] )& ,oPolygonColor] , oTmp = fMakeColors[oPolygons,oPolygonColor]; With[ {lDummy=oTmp} , (Hue @@ (#2 /. lDummy) ) & ] // Return ]; If[ oRules && And @@ Map[ ( MemberQ[lVertex,#//First] && MemberQ[{RGBColor,Hue,CMYKColor,GrayLevel},Head[#//Last]] )& ,oPolygonColor] , With[ {lDummy=oPolygonColor,lDummy2=oPolySize} , (#2 /. lDummy2 /. lDummy) & ] // Return ]; If[ oRules && And @@ Map[ ( MemberQ[lVirtPolygons,#//First] && MemberQ[{RGBColor,Hue,CMYKColor,GrayLevel},Head[#//Last]] )& ,oPolygonColor] , With[ {lDummy=oPolygonColor} , (#2 /. lDummy) & ] // Return ]; ( Sequence @@ {} ) & ]; fMakeColors[ oPolyPoly_ , oPolygonHue_ ] := Module[ {iSkip,iTotal,lPoly,lPHue,lPSat,lPVal,lTmp} , iSkip = Length[ oPolyPoly[[1,2,1]] ]; iTotal = Length[ oPolyPoly ]; lPoly = Map[ fFindSymmetry[#//Last//Flatten,iSkip]& , oPolyPoly ]; lPHue = Map[ #[[2]]& , lPoly] /. oPolygonHue; lPSat = Table[ lTmp = lPoly[[iI,2]] // Divisors // Reverse; ( Position[ lTmp , lPoly[[iI,1]]//Abs ][[1,1]] +0 ) / (Length[lTmp]+0) ,{iI,iTotal}]; lPVal = Table[ lTmp = Select[ lPoly , #[[{1,2}]]==lPoly[[iI]][[{1,2}]] & ]; ( Position[ lTmp , lPoly[[iI]] ][[1,1]] + 1 ) / (Length[lTmp]+1) ,{iI,iTotal}]; Thread[ Range[iTotal] -> Thread[ {lPHue,lPSat,lPVal} ] ] ]; fMakeFuncPoly[fMake_,oGeometry_,oModel_,oPlotPoints_,oLine_,oPolygon_,fColor_,oEdge_]:= Module[ {lTmp,fPolygon,iI,lEdge,lDummy,fDummy,fLine,fPlotPoints} , fPolygon = If[oPolygon===Off,(Sequence@@{})&,Polygon]; If[ oGeometry===S2 && oModel===Sphere , If[ oEdge===0 , lEdge = EdgeForm[]; , lEdge = EdgeForm[ Thickness[oEdge] ]; ]; fLine = If[ oLine===On , Line , (Sequence@@{})& ]; fPolygon = If[oPolygon===Off,(Sequence@@{})&,fS2Polygon]; With[ {lDummy=lEdge,fDummy=fLine} , fMake[{lCoords_,iPoly_},{iNum_}] := Module[ {lTmp,iN=Length[lCoords]} , { Table[ fS2Line[ lCoords[[iI]] , lCoords[[Mod[iI+1,iN,1]]] , PlotPoints->3*oPlotPoints+1]//fDummy ,{iI,iN}] , { lDummy, fColor[iNum,iPoly] , fPolygon[ lCoords , PlotPoints->oPlotPoints-1 ] } } ]; ]; Return[]; ]; If[ oGeometry=!=L2 && oLine===On , fMake[{lCoords_,iPoly_},{iNum_}] := Sequence @@ { {fColor[iNum,iPoly],fPolygon[lCoords]} , Append[lCoords,lCoords//First ] // Line }; Return[]; ]; If[ oGeometry=!=L2 , fMake[{lCoords_,iPoly_},{iNum_}] := {fColor[iNum,iPoly],fPolygon[lCoords]} ; Return[]; ]; If[ Head[oPlotPoints]===List, With[{lDummy=Append[oPlotPoints//Sort, {Infinity, 1}]}, fPlotPoints[x_] := Module[{iI = 1}, While[Not[ lDummy[[iI,1]]<=x && lDummy[[iI+1,1]]>x ], iI++]; lDummy[[iI, 2]] ] ]; , With[{lDummy=oPlotPoints}, fPlotPoints = lDummy&; ]; ]; With[{lDummy=fPlotPoints}, If[ oLine=!=On , fMake[{lCoords_,iPoly_},{iNum_}] := Module[ {lTmp} , lTmp = LToGraphics[ Append[lCoords,lCoords//First ] // LLine , Model -> oModel , PlotPoints -> lDummy[iNum] ] // First; {fColor[iNum,iPoly],fPolygon[lTmp]} ]; Return[]; ]; fMake[{lCoords_,iPoly_},{iNum_}] := Module[ {lTmp} , lTmp = LToGraphics[ Append[lCoords,lCoords//First ] // LLine , Model -> oModel , PlotPoints -> lDummy[iNum] ] // First; Sequence @@ { {fColor[iNum,iPoly],fPolygon[lTmp]} , Line[ lTmp ] } ]; ]; ]; fVertexQ[ lInput_TessGraph ] := fVertexQ[ lInput[[1]] ]; fVertexQ[ lInput_List ] := Length[lInput]>=3 && (And @@ Map[((#>=3)&&IntegerQ[#])&,lInput]); fVertexQ[ lInput___ ] := False; fVertexL2Q[ lInput_TessGraph ] := fVertexL2Q[ lInput[[1]] ]; fVertexL2Q[ lInput_List?fVertexQ ] := (Plus @@ ((lInput-2)/lInput)) > 2; fVertexL2Q[ lInput___ ] := False; fBasicProperties[ lVertex_ ] := Module[{iS,oGeometry,iN,lUnion,lSum}, iS = Apply[Plus, (lVertex - 2)/lVertex ]; oGeometry = If[ iS<2 , S2 , If[ iS==2 , E2 , L2 ] ]; iN = Length[lVertex]; lUnion = Union[ lVertex ]; lSum = Map[ Count[lVertex,#]& , lUnion ]; {iS,oGeometry,iN,lUnion,lSum} ]; fPattern[ lList_ , lLev_:{-1} ] := Module[ {ind=1, fF} , fF[x_] := (fF[x] = ind; ind++); Map[ fF , lList , lLev ] ]; fFixRule[ lY_ ] := FixedPoint[ fUnionRule , lY//Union ]; fUnionRule[ lY_ ] := Module[{fF,fG,x,y,z,iTmp,dummy}, fG[x_] := x; fF[x_->y_] := ( fG[x] = iTmp = fG[y]; With[ {dummy=iTmp} , fF[x->z_]:=fGreaterLesser[z,dummy] ]; x->iTmp ); Map[fF, lY] // Union ]; SetAttributes[ fGreaterLesser , Listable ]; fGreaterLesser[ x_ , y_ ] := If[ x===y , Sequence@@{} , If[ x>y , x->y , y->x ] ]; fFixGroup[ oIGroup_ , oIChange_ , oVirt2Real_ , lIPolygons_ , iN_ , iQ_ ] := Module[ {oChange,lPolygons,oGroup,oNewChange,fF,x,y,z,dummy} , oChange = fFixRule[ oIChange ]; lPolygons = lIPolygons /. oChange; oNewChange = {}; fF[x_ -> y_] := ( fF[x -> y ] = Sequence[]; With[{dummy=y}, fF[x -> z_] := ( If[ (dummy /. oVirt2Real) =!= (z /. oVirt2Real) , Throw[False] ]; oNewChange = Join[ oNewChange , fGreaterLesser[ z , dummy ] ]; Sequence @@ {} ); ]; x -> y ); oGroup = Map[ fF , oIGroup /. oChange ]; fFixGroup[ oGroup , oNewChange , oVirt2Real , lPolygons , iN , iQ ] ]; fFixGroup[ oIGroup_ , {} , oVirt2Real_ , lIPolygons_ , iN_ , iQ_ ] := { oIGroup , lIPolygons }; fFindNewRealizations[ lVertex_ , iQ_ , lIOutput_:{} ] := Module[ { lAll,lOutput=lIOutput,iS,oGeometry,iN,lUnion,lSum, lTmp,lReal,lVirt,oVirt2Real,lComb1L,lComb1R,lVirtComb, oVirtComb , oInvVirtComb,lPermFrom,lPermTo,lPermNum, iI,iJ,iK,IL,iPermTotal,lGroup0,lGroup,lClases, oGroup,lPolygons,lAround,lOld,lNew,oChange, lP,lArP2,lArP1,lArP,iTmp,lTmp1,lTmp2,lTmp3,lNewPoly,oSnub,sSnub, fF,ind,bSAME } , {iS,oGeometry,iN,lUnion,lSum} = fBasicProperties[ lVertex ]; lTmp = Range[iN]; lReal = Table[ lVertex , {iQ} ] // Flatten; lVirt = Table[ lTmp+(iI-1)*iN , {iI,iQ} ] // Flatten; oVirt2Real = Thread[ lVirt -> lReal ]; lComb1L = fMakeAllSymm[ Range[ iN ] , Reflect->Off ]; lComb1R = Map[ Reverse , lComb1L ]; lTmp = Join[ lComb1L , lComb1R ]; lVirtComb = Table[ Sequence@@(lTmp+(iI-1)*iN) , {iI,iQ} ]; { oVirtComb , oInvVirtComb } = fMakeRule[ lVirtComb ]; If[ Info===On , Print["lReal=",lReal," lVirt=",lVirt," oVirt2Real=",oVirt2Real]; Print[ "Comb:", MatrixForm[oVirtComb], " Real:",MatrixForm[ Range[2*iN*iQ] /. oVirtComb /. oVirt2Real ] ]; ]; lTmp = Map[ Take[#,2]& , lVirtComb /. oVirt2Real ]; lTmp = Select[lTmp // Union, (#[[1]] <= #[[2]]) &]; lPermFrom = lPermTo = lPermNum = {}; Do[ AppendTo[ lPermFrom , Select[ Range[2*iN*iQ] , ((Take[#/.oVirtComb, 2] /. oVirt2Real) === lTmp[[iI]]) & ] ]; AppendTo[ lPermTo , Select[ Range[2*iN*iQ] , ((Take[#/.oVirtComb,2]/.oVirt2Real) === Reverse[lTmp[[iI]]])& ] ]; AppendTo[ lPermNum , If[ Equal @@ lTmp[[iI]] , - fDiffFactoriel[ lPermFrom[[iI]]//Length ] , (lPermFrom[[iI]]//Length)! ] ]; ,{iI,Length[lTmp]}]; iPermTotal = Apply[ Times , Abs[lPermNum] ]; If[ Info===On , Print[ "Map:", { lTmp , lPermFrom , lPermTo , lPermNum } // MatrixForm, " Tot=",iPermTotal ]; ]; lAll = {}; Do[ lGroup0 = lGroup = fGiveGroup[ iI , lPermFrom , lPermTo , lPermNum ]; lTmp = Map[(Quotient[#//Last,iN,1]+1)&,lGroup]; oClases = Table[ iI->Union[{iI},Take[lTmp,{(iI-1)*iN+1,iI*iN}]] ,{iI,2*iQ}]; lClases = FixedPoint[ ((#/.oClases)//Flatten//Union)& , {1} ]; lTmp = Map[ (Quotient[#,2,1]+1) &, lClases] // Union ; If[ Length[ lTmp ] < iQ , Continue[] ]; lGroup = lGroup[[ Map[((# - 1)*iN + Range[iN]) &, lClases] // Flatten ]]; oGroup = lGroup /. oVirtComb; lPolygons = Table[ Range[(iI-1)*iN+1,iI*iN] , {iI,iQ} ]; lAround = Table[ lOld = oGroup[[iJ,1]]; lNew = NestList[ RotateLeft[ # /. oGroup ]& , lOld , First[lOld] /. oVirt2Real ]; If[ (lOld /. oVirt2Real)=!=(Last[lNew] /. oVirt2Real), Throw[False] ]; lNew ,{iJ,Length[oGroup]}] // Catch; If[ lAround===False , Continue[] ]; lTmp = fFixGroup[ oGroup , { Map[fGreaterLesser[# // First, # // Last] &, lAround] , fGreaterLesser[ Map[#[[1, 1]] &, oGroup] , Map[#[[2, 2]] &, oGroup] ] }//Flatten , oVirt2Real, lPolygons, iN, iQ ] // Catch; If[ lTmp===False , Continue[] ]; { oGroup , lPolygons } = lTmp; If[ Length[Map[fMostSymmetric,lPolygons]//fUnsortedUnion] < iQ , Continue[] ]; lTmp = Flatten[lPolygons]; oChange = Thread[ Range[iN*iQ] -> lTmp ]; lAround = lAround /. oChange; lP = lTmp // Union; iTmp = 1; lArP = Table[ While[ lAround[[iTmp,1,1]] != lP[[iI]] , iTmp++ ]; Map[ Reverse[Drop[#,2]]& , Drop[lAround[[iTmp++]],-1] ] ,{iI,lP//Length}]; lArP1 = Map[ fShortSymmetry , lArP ]; lArP2 = Map[ MapAt[Function[x, fFindFirst[x /. oVirt2Real]], #, 4] & , lArP1 ]; lNew = Sort[Range[lP // Length], OrderedQ[lArP2[[{#1, #2}]]] &]; oChange = Thread[ lP[[lNew]] -> Range[lP//Length] ]; oGroup = Sort[oGroup /. oChange]; lArP2 = lArP2[[lNew]]; lArP1 = lArP1[[lNew]]; lNewPoly = Thread[ Range[lP // Length] -> Map[Table[ Sequence @@ fFindFirst[#[[4]]/.oChange] ,{-#[[2]]/#[[1]]}] &, lArP1] ]; oSnub = Map[ ( RotateRight[ Reverse[ First[#] ],2] -> RotateRight[ Reverse[ Last[#] ],2] )& ,oGroup] // Sort; sSnub= If[ oSnub===oGroup , "Self" , "Snub" ]; lTmp = { lNewPoly , oGroup , iQ , sSnub }; If[ MemberQ[ lOutput , lTmp ] , Continue[] ]; If[ sSnub==="Snub" , If[ MemberQ[ lOutput , { lNewPoly , oSnub , iQ , sSnub } ], Continue[] ]; ]; AppendTo[ lOutput , lTmp ]; lTmp1 = Map[fFindFirst[Map[fPattern, #[[4]]]] &, lArP1]; AppendTo[ lAll , { MapIndexed[ Join[#, { lTmp1[[#2]] , lArP1[[#2]][[1, 4]] } ] & ,lArP2] , oGroup , iQ , sSnub } ]; ,{iI,iPermTotal}]; iI = 1; While[ iI < Length[lAll] , iJ = iI + 1; While[ iJ <= Length[lAll] , If[ lAll[[iI,3]]=!=lAll[[iJ,3]] || lAll[[iI,4]]=!=lAll[[iJ,4]] || Length[lAll[[iI,2]]]=!=Length[lAll[[iJ,2]]] || Map[Drop[#,-1]&,lAll[[iI,1]]]=!=Map[Drop[#,-1]&,lAll[[iJ,1]]] , ++iJ; Continue[]; ]; lTmp = fPattern[ Map[ Drop[#, -1] &, lAll[[iI, 1]]] , 1 ]; lTmp1 = Split[ lTmp ]; Module[{fF, ind = 1}, fF[x_] := ind++; lTmp2 = Map[fF, lTmp1, {-1}]; ]; lTmp3 = Map[ Length[#]!& , lTmp2 ]; bSAME = False; Do[ oChange = fGiveGroup[ iL , lTmp2 , lTmp2 , lTmp3 ]; If[ lAll[[iI,2]]===Sort[lAll[[iJ,2]]/.oChange] && Map[Last, lAll[[iI, 1]]]===(Map[Last, lAll[[iI, 1]]]/.oChange) , bSAME = True; Break[]; ]; ,{iL,2,Times@@lTmp3}]; If[ !bSame , ++iJ; Continue[] ]; lAll = Drop[ lAll , {iJ} ]; lOutput = Drop[ lOutput , {iJ} ]; If[ oInfo===On , Print["Found iI=",iI," iJ=",iJ," are same!"] ]; ]; ++iI; ]; lOutput ]; fFindRealizations[ lVirtVertex_ , oVirt2Real_ ] := Module[ { iS,oGeometry,iN,lUnion,lSum, lVirtComb,oVirtComb,oInvVirtComb,iNumComb, iNew,iOld,lNew,lOld, oInfo=Off, lTmp,oTmp,oInvTmp,lTmp1,oTmp1,iI,iJ,iK,iL,bGOOD, lPermFrom,lPermTo,lPermNum,lFrom,lTo,iPermTotal, lArround,oArr,oInvArr,oGroup, lNewPoly,oNewPoly,oInvNewPoly,oNewPSize,lNewComb, oNewGroup,oPolyPoly,oSnub,sSnub,sUniform, lOutput } , {iS,oGeometry,iN,lUnion,lSum} = fBasicProperties[ lVirtVertex /. oVirt2Real ]; If[ Length[ lUnion ] == 1 , iTmp = lUnion[[1]]; Return[ {{ {1 -> Table[iTmp,{iTmp},{iN-2}]}, {Table[1,{iN}] -> Table[1,{iN}]}, "Uniform" , "Self" }}] ]; lVirtComb = Sort[ fMakeAllSymm[ lVirtVertex ] , OrderedQ[{#1, #2} /. oVirt2Real]& ]; { oVirtComb , oInvVirtComb } = fMakeRule[ lVirtComb ]; iNumComb = Length[ lVirtComb ]; lTmp1 = Map[ Take[#,2]& , lVirtComb /. oVirt2Real ]; lPermFrom = lPermTo = lPermNum = {}; For[ iI=1 , iI<=iNumComb , iI++ , {iJ,iK} = lTmp1[[iI]]; If[ iJ<=iK, lFrom = Position[ lTmp1 , {iJ,iK} ] // Flatten; iI = Last[ lFrom ]; lTo = Position[ lTmp1 , {iK,iJ} ] // Flatten; AppendTo[ lPermFrom , lFrom ]; AppendTo[ lPermTo , lTo ]; AppendTo[ lPermNum , If[ iJ == iK, - fDiffFactoriel[ Length[lFrom] ] , Length[lFrom]! ] ]; ]; ]; iPermTotal = Apply[ Times , Abs[lPermNum] ]; If[ oInfo===On, Print[oGeometry," Poly:",Table[ SuperscriptBox[lUnion[[iI]],lSum[[iI]]] ,{iI,Length[lUnion]}] // DisplayForm ," oV2R=",oVirt2Real," Vv=",lVirtVertex," Rv=",lVirtVertex/.oVirt2Real ]; Print[ "Comb:", MatrixForm[oVirtComb], " Real:",MatrixForm[ Range[iNumComb] /. oVirtComb /. oVirt2Real ] ]; Print[ "Map:", { lPermFrom , lPermTo , lPermNum } // MatrixForm, " Tot=",iPermTotal ]; ]; lOutput = {}; Do[ oGroup = fGiveGroup[ iI , lPermFrom , lPermTo , lPermNum ] /. oVirtComb; Do[ lOld = iJ /. oVirtComb; lNew = Nest[ RotateLeft[ # /. oGroup ]& , lOld , lVirtComb[[iJ,1]] /. oVirt2Real ]; bGOOD = (lOld /. oVirt2Real) === (lNew /. oVirt2Real); If[ Not[bGOOD] , Break[]; ]; ,{iJ,iNumComb}]; If[ bGOOD , lTmp = fMakeAllSymm[ oGroup[[1,1]] , Reflect -> Off]; If[ lTmp === Union[ lTmp /. oGroup ] , oGroup = Select[ oGroup , (MemberQ[lTmp, First[#]])& ]; ]; lTmp = Table[ lTmp = oGroup[[iJ,1]]; Table[ lOut = Reverse[ Drop[ lTmp , 2 ] ]; lTmp = RotateLeft[ lTmp /. oGroup ]; lOut ,{ lVirtComb[[iJ,1]] /. oVirt2Real }] // Flatten // ( # /. oVirt2Real )& // fFindSymmetry[#,iN-2]& ,{iJ, Length[oGroup] }] ; { oArr , oInvArr } = fMakeRule[ Map[ (#//Last//Flatten)& , lTmp ] ]; lNewPoly = Map[ (#//Last//Flatten)& , lTmp//Union ]; { oNewPoly , oInvNewPoly } = fMakeRule[ lNewPoly ]; oPolyPoly = MapIndexed[ ( First[#2] -> Table[Take[#,{iI,iI+iN-3}],{iI,1,Length[#],iN-2}] )& , lNewPoly ]; oNewPSize = Map[ (First[#]->Length[Last[#]])& , oPolyPoly ]; oTmp1 = oArr /. oInvNewPoly; oTmp = Map[ (First[#]->(Last[#] /. oTmp1))& , oInvVirtComb ]; lNewComb = Table[ lOld = lVirtComb[[iJ]]; Table[ lOut = lOld /. oTmp; lOld = RotateLeft[ lOld ]; lOut ,{iN}] ,{iJ,iNumComb}]; oTmp = Table[ lVirtComb[[iJ]] -> lNewComb[[iJ]] ,{iJ,iNumComb}]; oNewGroup = oGroup /. oTmp; oNewGroup = Union[ oNewGroup /. oNewGroup ]; lTmp = Map[ First , oNewGroup ]; bGOOD = Apply[ And , Map[ (Take[First[#],2]===Reverse[Take[Last[#],2]])& , oNewGroup ] ] && Apply[ And , Map[ MemberQ[lTmp,Last[#]]& , oNewGroup ] ]; For[ iJ=1 , iJ<=Length[oNewGroup] && bGOOD , iJ++ , lOld = oNewGroup[[ iJ , 1 ]]; lNew = Nest[ RotateLeft[ # /. oNewGroup ]& , lOld , First[lOld] /. oNewPSize ]; bGOOD = lOld === lNew ; ]; If[ bGOOD , {sUniform,oSnub} = fGroupProperties[ oNewGroup ]; sSnub= If[ oSnub===oNewGroup , "Self" , "Snub" ]; If[ Not[MemberQ[ lOutput , {oPolyPoly,oNewGroup,sUniform,sSnub} ] ]&& Not[MemberQ[ lOutput , {oPolyPoly,oSnub ,sUniform,sSnub} ] ] , AppendTo[ lOutput , {oPolyPoly,oNewGroup,sUniform,sSnub} ]; ]; ]; ]; ,{iI,iPermTotal}]; lOutput ]; fGroupProperties[ oGroup_ ] := Module[ {iUniform,oSnub}, oSnub = Map[ ( RotateRight[ Reverse[ First[#] ],2] -> RotateRight[ Reverse[ Last[#] ],2] )& , oGroup ] // Sort; iUniform = Map[ fMostSymmetric[#//First]& , oGroup]//fUnsortedUnion//Length; { iUniform , oSnub } ]; fGiveGroup[ iNumber_ , lPermFrom_ , lPermTo_ , lPermNum_ ] := Module[{iJ,iI=iNumber-1,lNumbers,lTo,lFrom}, lNumbers = Map[ (iJ=Mod[iI,#];iI=Quotient[iI,#];iJ)& , Abs[lPermNum] ]; lTo = Table[ lPermTo[[iI]] [[ If[ lPermNum[[iI]] > 0 , fPermSame[ lNumbers[[iI]]+1 , Length[ lPermTo[[iI]] ] ] , fPermDiff[ lNumbers[[iI]]+1 , Length[ lPermTo[[iI]] ] ] ] ]] ,{iI,Length[lPermTo]}] // Flatten; lFrom = lPermFrom // Flatten; Apply[ Union , Table[ { lTo[[iI]]->lFrom[[iI]] , lFrom[[iI]]->lTo[[iI]] } , {iI,Length[lFrom]} ] ] ]; fMakeRule[ lInput_ ] := { MapIndexed[ (First[#2]->#)& , lInput ] , MapIndexed[ (#->First[#2])& , lInput ] }; fPermSame[ iNum_ , iLev_ ] := Module[{iK, iJ=iNum-1, lTmp=Range[iLev], iI}, Table[ iJ = Mod[iJ,(iI+1)!]; iK = lTmp [[Quotient[iJ,iI!]+1]]; lTmp = Complement[lTmp,{iK}]; iK ,{iI,iLev-1,0,-1}] ]; fPermDiff[ 1 , iLev_ ] := Range[iLev]; fPermDiff[ 2 , 2 ] := {2,1}; fPermDiff[ iNum_ , iLev_ ] := Module[{iT2,iT3,iI,iPos,iRest,lTemp=Range[iLev-1]}, Do[ lTemp[[iI]] = lTemp[[iI-1]] + (iI-1) * lTemp[[iI-2]] ; ,{iI,3,iLev-1}]; { iT3 , iT2 } = Take[ lTemp , -2 ]; If[ iNum <= iT2, Join[ {1} , fPermDiff[iNum,iLev-1]+1 ] , iI = iNum - iT2 - 1; iPos = Quotient[iI,iT3] + 2; iRest = Mod[iI,iT3] + 1; lTemp = Map[ If[#<=iPos-2,#+1,#+2]& , fPermDiff[iRest,iLev-2] ]; Join[ {iPos} , Take[ lTemp , iPos-2 ] , {1} , Take[ lTemp , iPos-iLev ] ] ] ]; fDiffFactoriel[ iLev_ ] := Module[ {iI,lTemp=Range[iLev]} , Do[ lTemp[[iI]] = lTemp[[iI-1]] + (iI-1) * lTemp[[iI-2]] ; ,{iI,3,iLev}]; Last[ lTemp ] ]; fMostSymmetric[ lList_ ] := fFindFirst[Join[ NestList[ RotateLeft , lList , Length[lList] - 1 ] , NestList[ RotateLeft , lList//Reverse , Length[lList] - 1 ] ]] fFindFirst[ lList_ ] := Module[ {}, lOut = lList // First; Do[ If[ !OrderedQ[{ lOut , lList[[iI]] }] , lOut= lList[[iI]] ] ,{iI,2,Length[lList]}]; lOut ]; fShortSymmetry[ lInput_ ] := Module[ {iN,iI,iTmp,lTake,lTmp1,lTmp2,bReflect} , iN = Length[ lInput ]; For[iI=1,iI<=iN,iI++, If[ IntegerQ[iTmp=iN/iI] , lTake = Take[lInput,iI]; If[ Table[Sequence@@lTake,{iTmp}]==lInput , Break[]]; ]; ]; lTmp1 = NestList[ RotateLeft , lTake, iI-1]; iTmp = Length[lTake//First]; lTmp2 = Table[ Take[RotateRight[lTake//Flatten//Reverse],{(iJ-1)*iTmp+1,iJ*iTmp}] ,{iJ,iI}]; If[ Not[ bReflect=MemberQ[ lTmp1 , lTmp2 ] ] , lTmp1 = Join[ lTmp1 , NestList[ RotateLeft , lTmp2, iI-1] ]; ]; { -iI , iN , bReflect , lTmp1 } ]; fShortSymmetryOld[ lInput_ , iSkip_ ] := Module[ {iN,iI,iTmp,lTake,lTmp1,lTmp2,bReflect} , iN = Length[ lInput ] / iSkip ; For[iI=1,iIiSkip , Reflect->Off ]; lTmp2 = Map[ RotateRight[#//Reverse]& , lTmp1 ]; bReflect = MemberQ[ lTmp2 , lTake ]; If[ Not[bReflect] , lTmp1 = Join[ lTmp1 , lTmp2 ] ]; lC = ffOrder[ lTake , iSkip ]; Do[ lC2 = ffOrder[ lTmp1[[iJ]] , iSkip ]; If[ OrderedQ[{ lC , lC2 }]//Not , lC = lC2; lTake = lTmp1[[iJ]]; ]; ,{iJ,Length[lTmp1]}]; lTake = Table[ Take[lTake,{iSkip*(iJ-1)+1,iSkip*iJ}] , {iJ,iI} ]; lTmp1 = Table[ Sequence @@ lTake , {iN/iI} ]; { -iI , iN , bReflect , lTake , lTmp1 } ]; ffOrder[ lInput_ , iSkip_ ] := Module[ {iN=Length[lInput]/iSkip} , { Table[ lInput[[iSkip*(iJ-1)+1]] , {iJ,iN} ] , Table[ Take[lInput,{iSkip*(iJ-1)+2,iSkip*iJ}] , {iJ,iN} ] } // Flatten ]; Options[ fMakeAllSymm ] = { Reflect->On , Skip->1 }; fMakeAllSymm[ lInput_ , opts___] := Module[{oReflect,oSkip,lTemp=lInput,iI}, oReflect = Reflect /. {opts} /. Options[ fMakeAllSymm ]; oSkip = Skip /. {opts} /. Options[ fMakeAllSymm ]; Union[ Table[ lTemp = RotateLeft[lTemp,oSkip] ,{iI,1,Length[lInput],oSkip}] , If[ oReflect===On , lTemp = RotateRight[Reverse[lInput]]; Table[ lTemp = RotateLeft[lTemp,oSkip] ,{iI,1,Length[lInput],oSkip}] , {} ] ] ]; fUnsortedUnion[lX_] := Module[ {fF} , fF[lY_] := (fF[lY] = Sequence[]; lY); Map[ fF , lX ] ]; fGoArround[ lVertNext_ , iN_ , iIndVert_ , iPos_ , iDir_ ] := Module[ {lFoundVertices,iPosOnFrom,iFrom,iNext} , lFoundVertices = { iFrom=iIndVert }; iPosOnFrom = Mod[ iPos+iDir , iN , 1 ]; While[ (iNext=lVertNext[[iFrom,iPosOnFrom]]) > 0 , iPosOnFrom = Mod[ Position[ lVertNext[[iNext]],iFrom ] [[1,1]] + iDir ,iN,1]; AppendTo[ lFoundVertices , iFrom=iNext ]; ]; { lFoundVertices , iPosOnFrom } ]; fGraph[{oPolygons_,oGroup_,sUniform_,sSnub_},iNPolygons_,iFirstPoly_,lOrigin_]:= Module[ { iI,iJ,iK,iL,iNext,iPoly,iTmp, lTemp,lTemp1,lTemp2, lFoundVertices,iPosOnFrom, oPolySize,iPutFirstPoly,iSizeFirstPoly, lVirtVert,lRealVert, iSum,oGeometry,iN,lUnion,lSum,lAngles, lVertNext,lVertPoly,lFaceVert,lFacePoly,lVertCoord, iNumVertices,iNumFaces,iSearch,iLimit } , oPolySize = Map[ (First[#]->Length[Last[#]])& , oPolygons ]; iPutFirstPoly = If[ MemberQ[ Map[Last,oPolySize] , iFirstPoly ] , Select[ oPolySize , (Last[#]==iFirstPoly)& ] [[-1, 1]] , oPolySize[[-1,1]] ]; iSizeFirstPoly = iPutFirstPoly /. oPolySize; lVirtVert = Select[oGroup, #[[1, 1]] == iPutFirstPoly &] [[1, 1]]; lRealVert = lVirtVert /. oPolySize; {iSum,oGeometry,iN,lUnion,lSum} = fBasicProperties[ lRealVert ]; lAngles = fAngles[ lRealVert ]; iLimit = If[ oGeometry === S2 , Infinity , iNPolygons ]; lVertNext = Table[ 0 , {iSizeFirstPoly} , {iN} ]; Do[ lVertNext[[ iI , 1 ]] = Mod[iI+1,iSizeFirstPoly,1]; lVertNext[[ iI , 2 ]] = Mod[iI-1,iSizeFirstPoly,1]; ,{iI,iSizeFirstPoly}]; iNumVertices = iSizeFirstPoly; lTemp = lVirtVert; lVertPoly = Join[ { lVirtVert } , Table[ lTemp = RotateRight[ lTemp ] /. oGroup ,{iI,2,iSizeFirstPoly} ] ]; lFaceVert = { Range[ iSizeFirstPoly ] }; lFacePoly = { iPutFirstPoly }; iNumFaces = 1; lVertCoord = fPolygon[ iSizeFirstPoly , lAngles , geometry -> oGeometry ]; If[ oGeometry===L2 && Head[ lOrigin ]===LPoint , lVertCoord = First[ L2Translation[First[lVertCoord],lOrigin][LLine[lVertCoord]] ]; ]; iSearch = 1; While[ iNumFaces < iLimit , iI = iSearch; iJ = 2; While[ iI <= iNumVertices , If[ lVertNext[[iI,iJ]]==0 , Break[]; ]; If[ (++iJ)>iN , iI++ ; iJ=2; ]; ]; If[ iI > iNumVertices , Break[]; ]; iSearch = iI; iNumVertices++; lTemp = RotateLeft[ RotateLeft[ lVertPoly[[iI]] , iJ-2 ] /. oGroup ]; AppendTo[ lVertNext , Table[ 0 , {iN} ] ]; AppendTo[ lVertPoly , lTemp ]; lVertNext[[ iI , iJ ]] = iNumVertices ; lVertNext[[ iNumVertices , 1 ]] = iI; iNext = lVertNext[[ iI , iJ-1 ]]; iPoly = lVertPoly[[ iI , iJ-1 ]] /. oPolySize; AppendTo[ lVertCoord , fRotate[ lVertCoord[[iNext]] , lVertCoord[[iI]] , iPoly , lAngles , geometry->oGeometry ] ]; iK = 2; While[ lVertNext[[iNumVertices,iK-1]]>0 && lVertNext[[iNumVertices,iK]]==0, { lFoundVertices , iPosOnFrom } = fGoArround[ lVertNext , iN , iNumVertices , iK , -1 ]; iPoly = lVertPoly[[iNumVertices,iK-1]]; If[ ( iPoly /. oPolySize )==Length[ lFoundVertices ] , lVertNext[[iNumVertices, iK ]] = iTmp = lFoundVertices//Last; lVertNext[[iTmp , iPosOnFrom]] = iNumVertices; AppendTo[ lFaceVert , lFoundVertices ]; AppendTo[ lFacePoly , iPoly ]; iNumFaces++; If[ (++iK)>iN , Break[]; ]; , Break[]; ]; ]; iK = iN; iL = 1; While[ lVertNext[[iNumVertices,iL]]>0 && lVertNext[[iNumVertices,iK]]==0, { lFoundVertices , iPosOnFrom } = fGoArround[ lVertNext , iN , iNumVertices , iK , +1 ]; iPoly = lVertPoly[[iNumVertices,iK]]; If[ ( iPoly /. oPolySize )==Length[ lFoundVertices ] , lVertNext[[iNumVertices, iK ]] = iTmp = lFoundVertices//Last; lVertNext[[iTmp , iPosOnFrom]] = iNumVertices; AppendTo[ lFaceVert , lFoundVertices ]; AppendTo[ lFacePoly , iPoly ]; iNumFaces++; If[ (--iK)<1 , Break[]; ]; iL = iK+1 ; , Break[]; ]; ]; ]; If[ oGeometry===S2 , lTemp = lFaceVert[[ -1 ]]; lFaceVert = Drop[ lFaceVert , -1 ]; lFacePoly = Drop[ lFacePoly , -1 ]; iI = First[ lTemp ]; iJ = Last [ lTemp ]; iK = Position[ lVertNext[[iJ]] , iI ] [[1,1]]; iL = Position[ lVertNext[[iI]] , iJ ] [[1,1]]; lVertNext[[ iI , iL ]] = 0; lVertNext[[ iJ , iK ]] = 0; { lTemp1 , iTmp } = fGoArround[ lVertNext , iN , iI , iL , -1 ]; { lTemp2 , iTmp } = fGoArround[ lVertNext , iN , iI , iL , +1 ]; lFaceVert = Join[ lFaceVert , { lTemp1 , lTemp2 } ]; lFacePoly = Join[ lFacePoly , lVertPoly[[iI]] [[{iL-1,iL}]] ]; lVertNext[[ iI , iL ]] = iJ; lVertNext[[ iJ , iK ]] = iI; ]; { lVertNext , lVertPoly , lFaceVert , lVertCoord , lFacePoly } ]; fFilterOptions[ command_Symbol , opts___ ] := Module[ {keywords=First /@ Options[command]} , Sequence @@ Select[ {opts},MemberQ[keywords, First[#]]& ] ]; (* ######################################################################## *) (* ## END OF CONTEXT "Tess`" ## *) (* ######################################################################## *) End[] EndPackage[] (* ######################################################################## *) (* ## END OF FILE AND PACKAGE ## *) (* ######################################################################## *)