(* ::Package:: *)

(*: Title:  PenroseTiles *)
(*: Author: Bryan Clair, Lyman P. Hurd *)
(*: Copyright: ? *)
(*: Package Version: 2.0 *)
(*: Mathematica Version: 7.0 *)
(*: Summary: 
	This package includes functions for manipulating patterns
	of Penrose dart and kite tiles.
*)
(*:Keywords: aperiodic, tiling, penrose
*)
(*:Discussion: *)
(*:Context: PenroseTiles` *)
(*:Source: 
	This was origianlly written by Lyman P. Hurd with this disclaimer:
	A similar package was shown to the author by William Thurston 
	around 1988.  The work here bears an unknown degree of similarity 
	since it derives from memory and experimentation.
    Hurd's original package is available on the internet from Wolfram.
    Bryan Clair rewrote the package based on Hurd's version.  Probably 25-50% of
    the remaining code is due to Hurd.
*)
(*:History:
   Version 2.0 Bryan Clair, 2011
   Version 1.0 Lyman Hurd, 1994
*)
BeginPackage["PenroseTiles`"]

Deflate::usage =
 	"Deflate[list] takes a collection of acute and obtuse triangles forming Penrose tiles and yields a larger deflated list.Deflate[list,n] deflates the list n times."

PenroseGraphics::usage =
	"PenroseGraphics[list] converts a list of triangles to an object of type Graphics with customizable Face, Edge, and Markings settings."
Options[PenroseGraphics] = {
	Faces->True,
    Markings->True,
	Edges->True,
    KiteColor->GrayLevel[.95],
    DartColor->GrayLevel[.85],
    EdgeStyle->Thick,
    MarkingStyle->{Blue,Orange}
    }

PenroseFaceGraphics::usage = 
	"PenroseFaceGraphics[list] converts a list of triangles to an object of type Graphics in which tiles are represented by pairs of polygons."
Options[PenroseFaceGraphics] = {
    KiteColor->GrayLevel[.95],
    DartColor->GrayLevel[.85]
    }
KiteColor::usage
	"KiteColor is an option for PenroseFaceGraphics indicating the color of the acute triangles which form kite tiles."
DartColor::usage
	"DartColor is an option for PenroseFaceGraphics indicating the color of the obtuse triangles which form dart tiles."

PenroseEdgeGraphics::usage = 
	"PenroseEdgeGraphics[list] converts a list of triangles to an object of type Graphics in which tiles are represented by their outlines."
Options[PenroseEdgeGraphics] = {
    EdgeStyle->Thick
    }
EdgeStyle::usage
	"EdgeStyle is an option for PenroseEdgeGraphics for the style of edges."

PenroseMarkingsGraphics::usage = 
	"PenroseMarkingsGraphics[list] converts a list of triangles to an object of type Graphics in which only the curved markings are shown."
Options[PenroseMarkingsGraphics] = {
    MarkingStyle->{Blue,Orange}
    }
MarkingStyle::usage
	"MarkingColor is an option for PenroseMarkingsGraphics. It is a list of two styles (or lists of styles) to use for the two marking curves."

AcuteTriangle::usage = 
	"AcuteTriangle is the baseline acute triangle."
ObtuseTriangle::usage = 
	"ObtuseTriangle is the baseline obtuse triangle."

a::usage = 
	"a[x,y,z] represents an acute isoceles triangle."
o::usage = 
	"o[x,y,z] represents an obtuse isoceles triangle."

PRotate::usage =
    "Rotate a Penrose list object by the given angle."
PTranslate::usage =
    "Translate a Penrose list object by the given {dx,dy}."

Kite::usage =
	"Kite tile."
Dart::usage =
	"Dart tile."

Sun::usage =
	"Sun configuration of five kites."
Star::usage =
	"Star configuration of five darts." 
Ace::usage =
    "Ace configuration of two kites and one dart."
Deuce::usage =
	"Deuce configuration of two kites and two darts."
King::usage =
	"King configuration of three darts and two kites."
Jack::usage =
	"Jack configuration of three kites and two darts."
Queen::usage =
	"Queen configuration of four kites and one dart."

Begin["`Private`"]
(*
Both Penrose tiles will be considered to be a union of two
triangles.  A kite will be represented by two acute triangles, and the
dart by two obtuse triangles.
Internally, we will represent these triangles by a[x,y,z] or
o[x,y,z]  where x,y, and z are ordered pairs of real numbers.
Both kinds of triangles are isoceles with angles 72, 72, 36 and 36,
36, 108 degrees respectively.

The deflation operator takes each acute triangle to two acute
triangles and an obtuse.  Obtuse triangles are taken to one triangle
of each type.  The triangles are not the tiles themselves but each
forms half of a tile (two acutes make a kite and two obtuses make a
dart).
The tile shapes are recovered by drawing two of the sides of each
triangle (thus technically a[x,y,z] and o[x,y,z] represent
oriented triangles).
*) 
C1=N[GoldenRatio-1]
C2=N[2-GoldenRatio] (* note C2 = (1-C1) *)
(* The deflation operator. *)
Deflate[a[x_, y_, z_]] := 
	With[{d = (C1 x + C2 y), 
	e = (C1 y + C2 z)},
	{a[d, z, x], 
	a[d, z, e], 
	o[y, e, d]}]
 
Deflate[o[x_, y_, z_]] := 
	With[{d = C2 x + C1 z}, 
	{o[z, d, y], 
	a[y, x, d]}]
 
Deflate[x_List] := Apply[Join,Deflate /@ x]
Deflate[x_, n_] := Nest[Deflate, x, n]

(* Display routines *)
PenroseGraphics[t_,opts:OptionsPattern[]]:=
   Graphics[{
	If[OptionValue[Faces],
      PenroseFaceGraphics[t,FilterRules[{opts},Options[PenroseFaceGraphics]]][[1]],
	  {}],
	If[OptionValue[Markings],
      PenroseMarkingsGraphics[t,FilterRules[{opts},Options[PenroseMarkingsGraphics]]][[1]],
      {}],
	If[OptionValue[Edges],
      PenroseEdgeGraphics[t,FilterRules[{opts},Options[PenroseEdgeGraphics]]][[1]],
      {}]
  }]

PenroseEdgeGraphics[t_,OptionsPattern[]] :=
   Graphics[Flatten[{OptionValue[EdgeStyle],
    t /. {a[x_, y_, z_] -> Line[{y, z, x}], o[x_, y_, z_] -> Line[{y, z, x}]}
   }]]

PenroseMarkingsGraphics[t_,OptionsPattern[]] := Graphics[
	      Flatten/@ Transpose[{OptionValue[MarkingStyle],markings[t]}]
       ]

PenroseFaceGraphics[t_,OptionsPattern[]] :=
  Graphics[{
    Flatten[{OptionValue[KiteColor],EdgeForm[OptionValue[KiteColor]],
      Select[Flatten[t],Head[#]==a&] /. 
         a[x_, y_, z_] -> {Polygon[{y, z, x}],Line[{y, z, x}]}
    }],
    Flatten[{OptionValue[DartColor],EdgeForm[OptionValue[DartColor]],
      Select[Flatten[t],Head[#]==o&] /.
         o[x_, y_, z_] -> {Polygon[{y, z, x}],Line[{y, z, x}]}
    }]
  }]

(* markings builds a pair (m1,m2} where m1, m2 are lists of
   circular arcs that define the two marking curves *)
markings[t_]:= {
  	t /. {a[x_, y_, z_] :> agraph1[x,y,z], o[x_, y_, z_] :> ograph1[x,y,z]},
      t /. {a[x_, y_, z_] :> agraph2[x,y,z], o[x_, y_, z_] :> ograph2[x,y,z]}
      }
agraph1[x_,y_,z_] :=With[{r=N[Apply[Plus,(x-z)^2]^(1/2)]},
   Circle[x,r N[1/GoldenRatio], angles[{x,z},{x,y}]]
   ]
agraph2[x_,y_,z_] :=With[{r=N[Apply[Plus,(x-z)^2]^(1/2)]},
   Circle[y,r,angles[{y,x},{y,z}]]
   ]
ograph1[x_,y_,z_] := With[{r=N[Apply[Plus,(x-z)^2]^(1/2)]},
   Circle[y,r N[1/GoldenRatio^3],angles[{y,z},{y,x}]]
   ]
ograph2[x_,y_,z_] := With[{r=N[Apply[Plus,(x-z)^2]^(1/2)]},
   Circle[x,r N[1/GoldenRatio^2],angles[{x,y},{x,z}]]
   ]
angles[{a_,b_},{c_,d_}] :=
  With[{v1=b-a,v2=d-c},
    shortway[ ArcTan @@ v1,
     ArcTan @@ v2]]
shortway[theta1_,theta2_]:=With[{t2=
  Max[N[theta1],N[theta2]],
  t1=Min[N[theta1],N[theta2]]},
  If[Abs[N[(t2-t1)]]<N[Pi],
   {t1,t2}// N,
   {t2,t1+2Pi}//N]]

(* Functions for maipulatings patterns *)
PRotate[shape_,\[Theta]_]:=Map[RotationMatrix[\[Theta]].#&,shape,{2}]
PTranslate[shape_,{dx_,dy_}]:=Map[{dx,dy}+#&,shape,{2}]

(* Some basic patterns *)
AcuteTriangle = {a[{0,0},{GoldenRatio Cos[72 Degree],
	GoldenRatio Sin[72 Degree]},{1,0}]} // N
 
ObtuseTriangle = {o[{1,0},{C1 Cos[36 Degree],C1 Sin[36 Degree]},{0,0}]} // N

Kite={a[{1,0},{0,0},{Cos[Pi/5],Sin[Pi/5]}],
      a[{1,0},{0,0},{Cos[-Pi/5],Sin[-Pi/5]}]}//N

Dart={o[{0,0},{1/GoldenRatio,0}, {Cos[Pi/5],Sin[Pi/5]}],
      o[{0,0},{1/GoldenRatio,0}, {Cos[-Pi/5],Sin[-Pi/5]}]}//N

Sun = Flatten[Table[PRotate[Kite,i*2 Pi/5],{i,0,4}]]

Star = Flatten[Table[PRotate[Dart,2 i Pi/5],{i,0,4}]]

Ace = Join[PRotate[Kite,Pi/5],PRotate[Kite,-Pi/5],
           PTranslate[PRotate[Dart,Pi],{GoldenRatio,0}]]

Deuce = Join[PTranslate[Join[PRotate[Dart,4Pi/5],PRotate[Dart,-4Pi/5]],{1,0}],
          PTranslate[PRotate[Kite,2Pi/5],{Cos[7 Pi/5],Sin[7 Pi/5]}],
          PTranslate[PRotate[Kite,8 Pi/5],{Cos[3 Pi/5],Sin[3 Pi/5]}]]

King = Flatten[{Table[PRotate[Dart,2 i Pi/5],{i,-1,1}],
          PTranslate[PRotate[Kite,3 Pi/5],{Cos[7 Pi/5],Sin[7 Pi/5]}],
          PTranslate[PRotate[Kite,7 Pi/5],{Cos[3 Pi/5],Sin[3 Pi/5]}]
         }]

Queen = Join[Dart,
             PTranslate[Join[PRotate[Kite,Pi/5],PRotate[Kite,-Pi/5]],{-1,0}],
             PTranslate[PRotate[Kite,Pi],{Cos[Pi/5],Sin[Pi/5]}],
             PTranslate[PRotate[Kite,Pi],{Cos[-Pi/5],Sin[-Pi/5]}]]

Jack = Join[PRotate[Kite,4Pi/5],PRotate[Kite,-4Pi/5],
             PTranslate[PRotate[Kite,Pi],{1,0}],
             PTranslate[PRotate[Dart,Pi/5],{Cos[7Pi/5],Sin[7Pi/5]}],
             PTranslate[PRotate[Dart,-Pi/5],{Cos[-7Pi/5],Sin[-7Pi/5]}]]
End[]
EndPackage[]

















