{-# LANGUAGE CPP #-}{-# LANGUAGE FlexibleContexts #-}{-# LANGUAGE MultiParamTypeClasses #-}{-# LANGUAGE ScopedTypeVariables #-}{-# LANGUAGE TypeFamilies #-}{-# LANGUAGE ViewPatterns #-}{-# OPTIONS_GHC -fno-warn-name-shadowing #-}------------------------------------------------------------------------------- |-- Module : Diagrams.TwoD.Tilings-- Copyright : (c) 2011 Brent Yorgey-- License : BSD-style (see LICENSE)-- Maintainer : byorgey@cis.upenn.edu---- Tools for generating and drawing plane tilings made of regular-- polygons.-------------------------------------------------------------------------------moduleDiagrams.TwoD.Tilings(-- * The ring Q[sqrt 2, sqrt 3]Q236,rt2,rt3,rt6,toDouble,Q2,toR2,toP2-- * Regular polygons,TilingPoly(..),polySides,polyFromSides,polyCos,polySin,polyRotation,polyExtRotation-- * Tilings-- ** Types,Tiling(..),Edge,mkEdge,Polygon(..)-- ** Generation,TilingState(..),initTilingState,TilingM,generateTiling-- ** Pre-defined tilings,t3,t4,t6,mk3Tiling,t4612,t488,t31212,t3636,semiregular,rot,t3464,t33434,t33344,t33336L,t33336R-- * Diagrams,drawEdge,drawPoly,polyColor,drawTiling,drawTilingStyled)whereimportControl.Monad.State#if __GLASGOW_HASKELL__ >= 704importControl.Monad.Writerhiding((<>))#elseimportControl.Monad.Writer#endifimportControl.ArrowimportData.Function(on)importData.List(mapAccumL,sort)importData.VectorSpaceimportqualifiedData.FoldableasFimportqualifiedData.SetasSimportData.ColourimportDiagrams.Preludehiding(e)-------------------------------------------------------------- The ring Q[sqrt(2), sqrt(3)]-------------------------------------------------------------- Instead of using Doubles, which can't be compared for equality, it-- suffices to use elements of the rationals with sqrt(2) and sqrt(3)-- adjoined.-- | @Q236 a b c d@ represents @a + b sqrt(2) + c sqrt(3) + d-- sqrt(6)@.dataQ236=Q236RationalRationalRationalRationalderiving(Eq,Ord,Show,Read)-- | Convert a @Q236@ value to a @Double@.toDouble::Q236->DoubletoDouble(Q236abcd)=fromRationala+fromRationalb*sqrt2+fromRationalc*sqrt3+fromRationald*sqrt6rt2,rt3,rt6::Q236rt2=Q2360100rt3=Q2360010rt6=rt2*rt3instanceNumQ236where(+)=(^+^)(-)=(^-^)(Q236a1b1c1d1)*(Q236a2b2c2d2)=Q236(a1*a2+2*b1*b2+3*c1*c2+6*d1*d2)(a1*b2+b1*a2+3*c1*d2+3*d1*c2)(a1*c2+2*b1*d2+c1*a2+2*d1*b2)(a1*d2+b1*c2+c1*b2+d1*a2)abs(Q236abcd)=Q236(absa)(absb)(absc)(absd)fromIntegerz=Q236(fromIntegerz)000signum=error"no signum for Q236"instanceAdditiveGroupQ236wherezeroV=Q2360000(Q236a1b1c1d1)^+^(Q236a2b2c2d2)=Q236(a1+a2)(b1+b2)(c1+c2)(d1+d2)negateV(Q236abcd)=Q236(-a)(-b)(-c)(-d)instanceVectorSpaceQ236wheretypeScalarQ236=Rationals*^(Q236abcd)=Q236(s*a)(s*b)(s*c)(s*d)typeQ2=(Q236,Q236)toR2::Q2->R2toR2=r2.(toDouble***toDouble)toP2::Q2->P2toP2=p2.(toDouble***toDouble)-------------------------------------------------------------- Polygons-------------------------------------------------------------- | Regular polygons which may appear in a tiling of the plane.dataTilingPoly=Triangle|Square|Hexagon|Octagon|Dodecagonderiving(Eq,Ord,Show,Read,Enum,Bounded)polySides::Numa=>TilingPoly->apolySidesTriangle=3polySidesSquare=4polySidesHexagon=6polySidesOctagon=8polySidesDodecagon=12polyFromSides::(Numa,Eqa,Showa)=>a->TilingPolypolyFromSides3=TrianglepolyFromSides4=SquarepolyFromSides6=HexagonpolyFromSides8=OctagonpolyFromSides12=DodecagonpolyFromSidesn=error$"Bad polygon number: "++shown-- | Cosine of a polygon's internal angle.polyCos::TilingPoly->Q236polyCosTriangle=(1/2)*^1polyCosSquare=0polyCosHexagon=(-1/2)*^1polyCosOctagon=(-1/2)*^rt2polyCosDodecagon=(-1/2)*^rt3-- | Sine of a polygon's internal angle.polySin::TilingPoly->Q236polySinTriangle=(1/2)*^rt3polySinSquare=1polySinHexagon=(1/2)*^rt3polySinOctagon=(1/2)*^rt2polySinDodecagon=(1/2)*^1{-
R_th = ( cos th -sin th )
( sin th cos th )
-}-- | Rotate by polygon internal angle.polyRotation::TilingPoly->Q2->Q2polyRotationp(x,y)=(x*c-y*s,x*s+y*c)wherec=polyCosps=polySinp{-
(cos th sin th) ( -1 0 ) = (-cos th -sin th)
(-sin th cos th) ( 0 -1 ) (sin th -cos th)
-}-- | Rotate by polygon external angle.polyExtRotation::TilingPoly->Q2->Q2polyExtRotationp(x,y)=(-x*c-y*s,x*s-y*c)wherec=polyCosps=polySinp-------------------------------------------------------------- Tilings-------------------------------------------------------------- | A tiling, represented as a sort of zipper. @curConfig@ indicates-- the polygons around the current vertex, in couterclockwise order-- starting from the edge along which we entered the vertex.-- @follow@ allows one to move along an edge to an adjacent vertex,-- where the edges are numbered counterclockwise from zero,-- beginning with the edge along which we entered the current-- vertex.dataTiling=Tiling{curConfig::[TilingPoly],follow::Int->Tiling}-- | An edge is represented by a pair of vertices. Do not use the-- @Edge@ constructor directly; use 'mkEdge' instead.dataEdge=EdgeQ2Q2deriving(Eq,Ord,Show)-- | Smart constructor for @Edge@, which puts the vertices in a-- canonical order.mkEdge::Q2->Q2->EdgemkEdgev1v2|v1<=v2=Edgev1v2|otherwise=Edgev2v1-- | A polygon is represented by a list of its vertices, in-- counterclockwise order. However, the @Eq@ and @Ord@ instances-- for polygons ignore the order.newtypePolygon=Polygon{polygonVertices::[Q2]}derivingShowinstanceEqPolygonwhere(Polygonvs1)==(Polygonvs2)=sortvs1==sortvs2instanceOrdPolygonwherecompare=compare`on`(sort.polygonVertices)-- | The state maintained while generating a tiling, recording which-- vertices have been visited and which edges and polygons have been-- drawn.dataTilingState=TP{visitedVertices::(S.SetQ2),visitedEdges::(S.SetEdge),visitedPolygons::(S.SetPolygon)}initTilingState::TilingStateinitTilingState=TPS.emptyS.emptyS.empty-- | The @TilingM@ monad tracks a @TilingState@, and can output-- elements of some monoid @w@ along the way.typeTilingMwa=WriterTw(StateTilingState)agenerateTiling::forallw.Monoidw=>Tiling-- ^ The tiling to generate->Q2-- ^ The location of the starting vertex.->Q2-- ^ The starting direction, i.e. the-- direction along which we came into-- the starting vertex.->(Q2->Bool)-- ^ Predicate on vertices specifying-- which should be visited. The-- vertices for which the predicate-- evaluates to True must form a-- single connected component.->(Edge->w)-- ^ what to do with edges->(Polygon->w)-- ^ what to do with polygons->wgenerateTilingtvdvPredep=evalState(execWriterT(generateTiling'tvd))initTilingStatewheregenerateTiling'::Tiling->Q2->Q2->TilingMw()generateTiling'tvd-- stop if the current vertex fails the predicate|not(vPredv)=return()|otherwise=dots<-get-- stop if we've seen this vertex beforewhen(v`S.notMember`visitedVerticests)$do-- otherwise, mark it as visitedmodify(\ts->ts{visitedVertices=v`S.insert`visitedVerticests})-- get the neighboring vertices and the polygons surrounding-- this vertex, and filter out ones we've already generatedlet(neighbors,polys)=genNeighborstvdedges=S.fromList$map(mkEdgev)neighborsedges'=edges`S.difference`visitedEdgestspolys'=polys`S.difference`visitedPolygonsts-- generate some edges and polygonsF.mapM_(tell.e)edges'F.mapM_(tell.p)polys'-- remember that we generated themmodify(\ts->ts{visitedEdges=edges'`S.union`visitedEdgests})modify(\ts->ts{visitedPolygons=polys'`S.union`visitedPolygonsts})-- follow edges and continue recursivelyzipWithM_(\di->generateTiling'(followti)(v^+^d)d)(map(^-^v)$neighbors)[0..]-- | Generate the neighboring vertices and polygons of a given vertex.genNeighbors::Tiling->Q2->Q2->([Q2],S.SetPolygon)genNeighborstvd=(neighbors,S.fromListpolys)where(neighbors,polys)=unzip.snd$mapAccumL(\d'poly->(polyRotationpolyd',(v^+^d',genPolyVspolyvd')))(negateVd)(curConfigt)-- | Generate the vertices of the given polygon, with one vertex at the given point-- and an adjacent vertex at the given offset.genPolyVs::TilingPoly->Q2-- ^ one vertex->Q2-- ^ vector to second vertex->PolygongenPolyVspvd=Polygon.scanl(^+^)v.take(polySidesp-1).iterate(polyExtRotationp)$d-------------------------------------------------------------- Diagrams-------------------------------------------------------------- | Draw an edge with the given style.drawEdge::Renderable(PathR2)b=>StyleR2->Edge->DiagrambR2drawEdges(Edgev1v2)=(toP2v1~~toP2v2)#applyStyles-- | Draw a polygon with the given style.drawPoly::Renderable(PathR2)b=>(Polygon->StyleR2)->Polygon->DiagrambR2drawPolysp=applyStyle(sp).fromVertices.maptoP2.polygonVertices$p-- Simple per-polygon color schemepolyColor::(Floatinga,Orda)=>TilingPoly->ColourapolyColorTriangle=yellowpolyColorSquare=mediumseagreenpolyColorHexagon=bluevioletpolyColorOctagon=lightsteelbluepolyColorDodecagon=cornflowerblue-- | Draw a tiling, with a given width and height and default colors-- for the polygons.drawTiling::(Renderable(PathR2)b,BackendbR2)=>Tiling->Double->Double->DiagrambR2drawTiling=drawTilingStyled(mempty#lw0.02)(\p->mempty#lw0#fc(polyColor.polyFromSides.length.polygonVertices$p))-- | Draw a tiling with customizable styles for the polygons. This is-- just an example, which you can use as the basis of your own-- tiling-drawing routine.drawTilingStyled::(Renderable(PathR2)b,BackendbR2)=>StyleR2->(Polygon->StyleR2)->Tiling->Double->Double->DiagrambR2drawTilingStyledeStylepStyletwh=mkDia$generateTilingt(0,0)(1,0)inRect-- draw the edges and polygons into separate-- diagrams, so we can make sure all the edges are-- overlaid on top of all the polygons at the end(liftA2(,)(drawEdgeeStyle)mempty)(liftA2(,)mempty(drawPolypStyle))whereinRect((unr2.toR2)->(x,y))=-w/2<=x&&x<=w/2&&-h/2<=y&&y<=h/2mkDia(es,ps)=viewRect(es<>ps)viewRect=withEnvelope(rectwh::DR2)-------------------------------------------------------------- Some pre-defined tilings-------------------------------------------------------------- Regular tilings-- | <<diagrams/t3D.svg#diagram=t3D&width=300>>t3::Tilingt3=Tiling(replicate6Triangle)(constt3)-- > import Diagrams.TwoD.Tilings-- > t3D = drawTiling t3 10 10-- | <<diagrams/t4D.svg#diagram=t4D&width=300>>t4::Tilingt4=Tiling(replicate4Square)(constt4)-- > import Diagrams.TwoD.Tilings-- > t4D = drawTiling t4 10 10-- | <<diagrams/t6D.svg#diagram=t6D&width=300>>t6::Tilingt6=Tiling(replicate3Hexagon)(constt6)-- > import Diagrams.TwoD.Tilings-- > t6D = drawTiling t6 10 10-- Semi-regular tilings-- | Create a tiling with the same 3 polygons surrounding each vertex.-- The argument is the number of sides of the polygons surrounding a vertex.mk3Tiling::[Int]->Tilingmk3Tiling(ps@[a,b,c])=Tiling(mappolyFromSidesps)(\i->casei`mod`3of0->mk3Tiling(reverseps)1->mk3Tiling[a,c,b]2->mk3Tiling[b,a,c]_->error"i `mod` 3 is not 0, 1,or 2! the sky is falling!")mk3Tiling_=error"mk3Tiling may only be called on a list of length 3."-- | <<diagrams/t4612D.svg#diagram=t4612D&width=300>>t4612::Tilingt4612=mk3Tiling[4,6,12]-- > import Diagrams.TwoD.Tilings-- > t4612D = drawTiling t4612 10 10-- | <<diagrams/t488D.svg#diagram=t488D&width=300>>t488::Tilingt488=mk3Tiling[4,8,8]-- > import Diagrams.TwoD.Tilings-- > t488D = drawTiling t488 10 10-- | <<diagrams/t31212D.svg#diagram=t31212D&width=300>>t31212::Tilingt31212=mk3Tiling[3,12,12]-- > import Diagrams.TwoD.Tilings-- > t31212D = drawTiling t31212 10 10-- | <<diagrams/t3636D.svg#diagram=t3636D&width=300>>t3636::Tilingt3636=mkT[3,6,3,6]wheremkT::[Int]->TilingmkTps=Tiling(mappolyFromSidesps)(\i->mkT$ifevenithenreversepselseps)-- > import Diagrams.TwoD.Tilings-- > t3636D = drawTiling t3636 10 10-- | Create a tiling where every vertex is the same up to rotation and-- translation (but /not/ reflection). Arbitrarily pick one of the-- edges emanating from a vertex and number the edges-- counterclockwise starting with 0 for the chosen edge.semiregular::[Int]-- ^ The number of sides of the polygons-- surrounding a typical vertex,-- counterclockwise starting from edge 0.->[Int]-- ^ The transition list: if the /i/th entry of-- this list is /j/, it indicates that the edge-- labeled /i/ is labeled /j/ with respect to-- the vertex on its other end.->Tilingsemiregularpstrans=mkT0wheremkTi=Tiling(mappolyFromSides(rotips))(\j->mkT$rotitrans!!j)rot::(Numa,Eqa)=>a->[t]->[t]rot0xs=xsrot_[]=[]rotn(x:xs)=rot(n-1)(xs++[x])-- | <<diagrams/t3464D.svg#diagram=t3464D&width=300>>t3464::Tilingt3464=semiregular[4,3,4,6][3,2,1,0]-- > import Diagrams.TwoD.Tilings-- > t3464D = drawTiling t3464 10 10{-
The above is worth a few lines of explanation. There is only one type
of vertex, of degree 4, hence there are four possible states depending
on which edge one entered the vertex on. We can arbitrarily choose
state 0 to be the one in which the surrounding polygons, ccw from the
edge on which the vertex was entered, are 4,3,4,6. The second list
then records the states in which one ends up after following edges 0,
1, 2... (numbered ccw with edge 0 being the one entered on) starting
from state 0. The transitions from other states can be worked out by
appropriate cyclic shifts.
The tilings below are worked out in a similar manner.
-}-- | <<diagrams/t33434D.svg#diagram=t33434D&width=300>>t33434::Tilingt33434=semiregular[3,4,3,4,3][0,2,1,4,3]-- > import Diagrams.TwoD.Tilings-- > t33434D = drawTiling t33434 10 10-- | <<diagrams/t33344D.svg#diagram=t33344D&width=300>>t33344::Tilingt33344=semiregular[4,3,3,3,4][0,4,2,3,1]-- > import Diagrams.TwoD.Tilings-- > t33344D = drawTiling t33344 10 10-- | <<diagrams/t33336LD.svg#diagram=t33336LD&width=300>>t33336L::Tilingt33336L=semiregular[3,3,3,3,6][4,1,3,2,0]-- > import Diagrams.TwoD.Tilings-- > t33336LD = drawTiling t33336L 10 10-- | <<diagrams/t33336RD.svg#diagram=t33336RD&width=300>>t33336R::Tilingt33336R=semiregular[3,3,3,3,6][4,2,1,3,0]-- > import Diagrams.TwoD.Tilings-- > t33336RD = drawTiling t33336R 10 10