Clean Tile Problem

(*Constants*)

$EstimatedPostingDate={2007,8,20,15};

(*Math*)

χ=((Sqrt[3])/2);
ξ=(1/2);

floorSide=5;

θmin=π/4;
θ0=2π/5;

hexVertices=Module[{θ},Table[{Cos[θ],Sin[θ]},{θ,0,2π,π/3}]];

hexCenters=
Module[
{x,y},
Join[
Table[{-3,y},{y,-2χ,2χ,2χ}],
Table[{-1-ξ,y},{y,-3χ,3χ,2χ}],
Table[{0,y},{y,-4χ,4χ,2χ}],
Table[{1+ξ,y},{y,-3χ,3χ,2χ}],
Table[{3,y},{y,-2χ,2χ,2χ}]
]
];

floorSide=5;

(*coinControl=Animator;*)
coinControl=Trigger;

(*Controls*)

symbolSize=25{1,1};

sym[Square]:=Graphics[{FaceForm[Gray],Polygon[{{0,0},{1,0},{1,1},{0,1}}]},ImageSize->symbolSize]
sym[Triangle]:=Graphics[{FaceForm[Gray],Polygon[{{0,0},{1,0},{ξ,χ}}]},ImageSize->symbolSize]
sym[Hexagon]:=Graphics[{FaceForm[Gray],Polygon[{{0,0},{1,0},{1+ξ,χ},{1,2χ},{0,2χ},{-ξ,χ}}]},ImageSize->symbolSize]
sym[Rhombus]:=Graphics[{FaceForm[Gray],Polygon[{{0,0},{1,0},{1+Cos[θ0],Sin[θ0]},{Cos[θ0],Sin[θ0]}}]},ImageSize->symbolSize]

shapeLabel[shapeLabelType_,shape_]:=
Switch[
shapeLabelType,
Text,ToString[shape],
Graphics,sym[shape]
]

(*Simulation*)

(*Lattice Reductions*)

RhombusReduce[θ_][xy:{_,_}]:=
With[
{vv={{1,0},{Cos[θ],Sin[θ]}}},
xy-Floor[LinearSolve[Transpose[vv],xy]].vv
]

TriangleReduce[xy:{_,_}]:=Module[{xyr=RhombusReduce[π/3][xy]},With[{p={1,0},u={-ξ,χ}},If[!inTriangle[1][xyr],2 (p-u u.(p-xyr))-xyr,xyr]]]

HexagonReduce[{x_,y_}]:=
Module[
{xr,yr},
{xr,yr}=Abs[{Mod[x,3],Mod[y,2χ,-χ]}];
If[xr>3/2,xr=3-xr];
If[yr>2χ(1-xr),{xr,yr}=Reflect[{1,0},{ξ,-χ}][{xr,yr}]];
(*yr=Abs[yr];*)
(*If[yr>2χ xr,{xr,yr}=Reflect[{0,0},{ξ,χ}][{xr,yr}]];*)
{xr,yr}
]

(*Distances*)

ddistance[{d1_,d2_}]:=Sqrt[(4/3)((d1^2)+(d2^2)+d1 d2)]
hdistance[{d1_,d2_}]:=Sqrt[(4/3)((d1^2)+(d2^2)-d1 d2)]
vdistance[θ_][{d1_,d2_}]:=((d1^2)+(d2^2)+2 d1 d2 Cos[θ]) ((Csc[θ])^2)

TriangleDistances[xy:{_,_}]:=Module[{xyr=TriangleReduce[xy]},{{0,1}.(xyr-{0,0}),{χ,-ξ}.(xyr-{0,0}),{-χ,-ξ}.(xyr-{1,0})}]

HexagonDistances[xy:{_,_}]:=Module[{xyr=HexagonReduce[xy]},χ-Abs[{{0,1}.xyr,{χ,ξ}.xyr,{-χ,ξ}.xyr}]]

rhombusVertices[θ_]:={{0,0},{1,0},{1+Cos[θ],Sin[θ]},{Cos[θ],Sin[θ]}}

RhombusDistances[θ_][xy:{_,_}]:=
Module[
{x,y},
{x,y}=RhombusReduce[θ][xy];
{
Abs[{Mod[x-y Cot[θ],1,-1/2],Mod[y,Sin[θ],-Sin[θ]/2]}],
Min[Map[EuclideanDistance[{x,y},#]&,rhombusVertices[θ]]]
}
]

(*Reflection*)

Reflect[p:{_,_},u:{_,_}][xy:{_,_}]:=
With[{un=Normalize[u]},2(p-un(un.(p-xy)))-xy]

(*Region Tests*)

inTriangle[l_][{x_,y_}]:=
y>0 && y<2χ x&&y<2χ(l-x)

inHexagon[l_][{x_,y_}]:=Abs[y]<χ l && Abs[y]<2χ(l-Abs[x])
inHexagon[l_,cent_][xy_]:=inHexagon[l][xy-cent]

onHexagonTable[xy_]:=
Or@@Prepend[
Map[inHexagon[1,#][xy]&,hexCenters[[{1,3,8,12,17,19}]]],
inHexagon[4][xy]
]

(*maxRadius*)

maxRadius[Square]=1/2;
maxRadius[Triangle]=χ/3;
maxRadius[Hexagon]=χ;
maxRadius[Rhombus[θ_]]:=Sin[θ]/2;

(*nTiles*)

nTiles[Square,ρ_][xy:{_,_}]:=
Module[
{dxy=Map[Abs[Round[#]-#]&,xy]},
Which[
Xor[First[dxy]<ρ,Last[dxy]<ρ],2,
Norm[dxy]<ρ,4,
And[First[dxy]<ρ,Last[dxy]<ρ],3,
True,1
]
]

nTiles[Triangle,ρ_][xy:{_,_}]:=
Module[
{dxy=TriangleDistances[xy]},
Which[
Count[dxy,_?(#>ρ&)]==3,1,
Count[dxy,_?(#>ρ&)]==2,2,
Or @@ Thread[Map[ddistance,Subsets[dxy,{2}]]<ρ],6,
χ-Max[dxy]<ρ,4,
True,3
]
]

nTileValues[Square]=Range[4];
nTileValues[Triangle]={1,2,3,4,6};
nTileValues[Hexagon]=Range[4];
nTileValues[Rhombus[_]]:=Range[4]
nTileValues[Rhombus]=Range[4];

nTiles[Hexagon,ρ_?(#≤1/2&)][xy:{_,_}]:=
Count[HexagonDistances[xy],_?(#<ρ&)]+1

nTiles[Hexagon,ρ_?(#>1/2&)][xy:{_,_}]:=
Module[
{dxy=HexagonDistances[xy]},
Switch[
Count[dxy,_?(#<ρ&)],
0,1,
1,2,
_,If[Count[Map[hdistance,Subsets[dxy,{2}]],_?(#<ρ&)]<2,3,4]
]
]

nTiles[Rhombus[θ_],ρ_][xy:{_,_}]:=
Module[
{dxyv=RhombusDistances[θ][xy]},
x=First[First[dxyv]];
y=Last[First[dxyv]];
Which[Xor[x<ρ,y<ρ],2,Last[dxyv]<ρ,4,And[x<ρ,y<ρ],3,True,1]
]

(*Statistics*)

nTileProbability[Square,1][ρ_]:=(((1-2ρ))^2)
nTileProbability[Square,2][ρ_]:=4ρ(1-2ρ)
nTileProbability[Square,3][ρ_]:=(4-π)(ρ^2)
nTileProbability[Square,4][ρ_]:=π (ρ^2)

nTileProbability[Triangle,6][ρ_]:=((1/2) π (ρ^2))/(χ/2);
nTileProbability[Triangle,1][ρ_]:=((χ-3 ρ)^2/(2 χ))/(χ/2);
nTileProbability[Triangle,2][ρ_]:=(3/2 ρ (2-(5 ρ)/χ))/(χ/2);
nTileProbability[Triangle,3][ρ_]:=((1/2)*(ρ^2/χ)*3)/(χ/2);
nTileProbability[Triangle,4][ρ_]:=((1/2)*(ρ^2/χ)*3-(1/2) π (ρ^2))/(χ/2);

nTileProbability[Hexagon,4][ρ_?(#≤1/2&)]:=0
nTileProbability[Hexagon,4][ρ_?(#>1/2&)]:=(-(3/2) (Sqrt[-1+4 (ρ^2)])+6 (ρ^2) ArcCos[(1/(2 ρ))])/(3χ)
nTileProbability[Hexagon,3][ρ_?(#≤χ/2&)]:=6(ρ^2)/χ/(3χ)
nTileProbability[Hexagon,3][ρ_?(#>χ/2&)]:=1-2nTileProbability[Hexagon,1][ρ]-nTileProbability[Hexagon,4][ρ]
nTileProbability[Hexagon,2][ρ_?(#≤χ/2&)]:=6(1-3/2 ρ/χ)ρ/(3χ)
nTileProbability[Hexagon,2][ρ_?(#>χ/2&)]:=nTileProbability[Hexagon,1][ρ]
nTileProbability[Hexagon,1][ρ_]:=(3(χ-ρ)(1-ρ/χ))/(3χ)

nTileProbability[Rhombus[θ_],1][ρ_]:=(((1-2 ρ Csc[θ]))^2)
nTileProbability[Rhombus[θ_],2][ρ_]:=4 ρ Csc[θ] (1-2 ρ Csc[θ])
nTileProbability[Rhombus[θ_],3][ρ_]:=(4  Csc[θ]-π )(ρ^2)Csc[θ]
nTileProbability[Rhombus[θ_],4][ρ_]:=π (ρ^2)Csc[θ]
nTileProbability[Rhombus,_][_]:=0

(*Statistical Tabulation*)

(*runningTouchingTilesTab//Clear*)
runningTouchingTilesTab[ntl_List,nttl_List]:=
FoldList[
Function[{l,n},MapAt[Function[#+1],l,n]],
Table[0,{Max[ntl]}],
nttl
][[All,ntl]]//Rest

(*Random Positions*)

randomPosition[Square,l_]:=RandomReal[{0,l},{2}]

randomPosition[Triangle,l_]:=
Module[
{xy=randomPosition[Square,l]},
While[Not[inTriangle[l][xy]],xy=randomPosition[Square,l]];
xy
]

randomPosition[Hexagon,1]:=
Module[
{xy=randomPosition[Square,2]-{1,1}},
While[Not[inHexagon[1][xy]],xy=randomPosition[Square,2]-{1,1}];
xy
]

randomPosition[Hexagon,l:{{_,_}..}]:=
randomPosition[Hexagon,1]+RandomChoice[l]

randomPosition[Rhombus[θ_],l_]:=With[{y=RandomReal[{0,l Sin[θ]}]},{x=y Cot[θ]+RandomReal[{0,l}],y}]

(*Graphics*)

(*Polygons*)

Hexagon[cent_]:=Polygon[Map[cent+#&,hexVertices,{1}]]

(*Parameters*)

coinOpacity=0.5;

(*Grids*)

shapeGrid[Square][l_]:=SquareGrid[l];
shapeGrid[Triangle][l_]:=TriangleGrid[l];
shapeGrid[Rhombus[θ_]][l_]:=RhombusGrid[θ,l];
shapeGrid[Hexagon][___]:=HexagonGrid[]

SquareGrid[l_]:=
{
Line[{{#,0},{#,l}}]&/@Range[0,l],
Line[{{0,#},{l,#}}]&/@Range[0,l]
}

BorderedSquareGrid[x_,y_]:=
{
Line[{{#,-1},{#,y+1}}]&/@Range[-1,x+1],
Line[{{-1,#},{x+1,#}}]&/@Range[-1,y+1]
}

(*Use χ:*)

TriangleGrid[l_]:=
{
Table[Line[{{z/2,χ z},{l-z/2,χ z}}],{z,0,l}],
Table[Line[{{z,0},{((l+z)/2),χ(l-z)}}],{z,0,l}],
Table[Line[{{z,0},{(z/2),χ z}}],{z,0,l}]
}

RhombusGrid[θ_,l_]:=
With[
{s=Sin[θ],c=Cos[θ]},
{
Table[Line[{{c z,s z},{l+c z,s z}}],{z,0,l}],
Table[Line[{{z,0},{z+c l,s l}}],{z,0,l}]
}
]

HexagonGrid[___]:={FaceForm[White],EdgeForm[Black],Map[Hexagon,hexCenters]}

(*Plot Range Values*)

plotRangeValue[shape:(Square|Triangle),fl_]:=
With[
{ρmax=maxRadius[shape]},
Table[{-ρmax,fl+ρmax},{2}]
]

plotRangeValue[Hexagon,_]:=
With[
{ρmax=maxRadius[Hexagon]},
{(4+ρmax){-1,1},(5χ+ρmax){-1,1}}
]

plotRangeValue[Rhombus[θ_],_]:=
With[
{ρmax=maxRadius[Rhombus[θ]]},
{{-ρmax,floorSide(1+Cot[θ])+ρmax},{-ρmax,floorSide Sin[θ]+ρmax}}
]

(*Coin Colors*)

coinColor[1]=Red;
coinColor[2]=Orange;
coinColor[3]=Blue;
coinColor[4]=Green;
coinColor[6]=Purple;

(*Coins*)

Coin[ρ_][color_,xy:{_,_}]:={Opacity[coinOpacity,color],Disk[xy,ρ]}

(*TabularDisplay*)

TabularDisplay[shape_,totals_,radius_]:=
Grid[
Prepend[
Table[
Map[
Text@Style[#,FontColor->coinColor[nTileValues[shape][[m]]],11]&,
{
nTileValues[shape][[m]],
If[AtomQ[totals],0,totals[[m]]],
NumberForm[
If[AtomQ[totals],0,N[totals[[m]]/Total[totals]]],{2,2},ExponentFunction->(Null&)
],
NumberForm[nTileProbability[shape,nTileValues[shape][[m]]][radius]//N,{2,2},ExponentFunction->(Null&)]
}
],
{m,Length[nTileValues[shape]]}],
Map[
Text@Style[#,TextAlignment->Center,11]&,
{"number of tiles touched","observed count","observed proportion","theoretical probability"}
]
],
Frame->All,
Alignment->{Automatic,{Center,Right}},
ItemSize->5
]

(*Histogram Display*)

$UseHisto=True;

HistogramDisplay[_,_?AtomQ,_]:=Graphics[{},ImageSize->125]

HistogramDisplay[shape_,totals_,radius_]:=
Module[
{barFun,total=Total[totals],barWidth=0.4,barSep=0.05},
barFun[v_,{p_}]:=
Module[
{
n=nTileValues[shape][[p]],
prob
},
{
prob=N[nTileProbability[shape,n][radius]];
coinColor[n],
Rectangle[{p,0},{p+barWidth,N[v/total]}],
Text[Style[NumberForm[N[v/total],{3,2},ExponentFunction->(Null&)],7],{p+barWidth/2,N[v/total]},{0,-1}],
Text[Style[n,9],{p+barWidth+barSep/2,0},{0,1}],
Gray,
Rectangle[{p+barWidth+barSep,0},{p+2barWidth, prob}],
Text[Style[NumberForm[prob,{3,2},ExponentFunction->(Null&)],7],{p+3/2 barWidth+barSep,prob},{0,-1}]
}
];
Graphics[
MapIndexed[
barFun,
totals
],
AspectRatio->1/GoldenRatio,
ImageSize->200,
PlotRange->{Automatic,{-0.1,Max[Table[nTileProbability[shape,nn][radius],{nn,nTileValues[shape]}]]+0.2}}
]
]

Manipulate[
shape=ishape;
If[MatchQ[shape,Rhombus|Rhombus[_]],shape=Rhombus[θ]];
If[AbsoluteTime[]>AbsoluteTime[$EstimatedPostingDate],n=0];
(* needed to pick up coins when shape is changed - but prevents coins from appearing in Thumbnail & Snapshots *)
n=Min[n,nCoins]; (* needed to stop pink graphs at times before $EstimatedPostingDate *)
coinPositionList=
Table[
Switch[
shape,
Hexagon,randomPosition[Hexagon,hexCenters],
_,randomPosition[shape,floorSide]
],
{nCoins}
];
radius=Min[maxRadius[shape],radius];
table=shapeGrid[shape][floorSide];
nTouchingTilesList=Map[nTiles[shape,radius],coinPositionList];
coinList=Table[
Coin[radius][coinColor[nTouchingTilesList[[i]]],coinPositionList[[i]]],
{i,nCoins}
];
runTab=runningTouchingTilesTab[nTileValues[shape],nTouchingTilesList];
Pane[
Column[
{
Row[
{
Text@Style["drop coins  ",TextAlignment->Left],
coinControl[
Dynamic[n,TrackedSymbols->{n,shape,radius,nCoins}],
{0,nCoins,1},
AnimationRate->2,
DisplayAllSteps->True,
AnimationRepetitions->1,
BaseStyle->"VerticalSlider"
]
}
],
Grid[{
{
Graphics[
Dynamic[If[n>0,{table,Take[coinList,n]},{table}]],
PlotRange->plotRangeValue[shape,floorSide],
ImageSize->{220,220},AspectRatio->Automatic
],
Column[
{
Dynamic[TabularDisplay[shape,runTab[[n]],radius]],
If[$UseHisto,Dynamic[HistogramDisplay[shape,runTab[[n]],radius]]]
},
Alignment->{Center,Baseline}
]
}
}
]
},
Alignment->{Center,Center}
],ImageSize->{550,300}],
{{shapeLabelType,Graphics,"shape labels"},{Text->ToString[Text],Graphics->ToString[Graphics]},ControlType->RadioButton},
{
{ishape,Square,"tile shape"},Map[#:>Dynamic[shapeLabel[shapeLabelType,#]]&,{Square,Triangle,Hexagon,Rhombus}],
ControlType->SetterBar
},
{{shape,ishape},ControlType->None},
{{radius,maxRadius[Square]/2,"coin size"},0,maxRadius[shape]},
{{nCoins,50,"number of coins"},1,150,1},
{{θ,θ0,"vertex angle"},θmin,π/2,Enabled:>MatchQ[ishape,Rhombus|Rhombus[_]]},
{i,ControlType->None},
{coinPositionList,ControlType->None},
{{table,shapeGrid[Square][floorSide]},ControlType->None},
{{nTouchingTilesList,{}},ControlType->None},
{{coinList,{}},ControlType->None},
{{runTab,List},ControlType->None},
{{n,0},ControlType->None},
TrackedSymbols->{ishape,radius,nCoins,θ},
SaveDefinitions->True,AutorunSequencing->{4}
]

CAPTION

Buffon studied the clean tile game for various tilings, in which players bet on how many tiles are partly covered by a thrown coin. Assume that the coin is not too big to fit on a single tile. In this simulation, the observed frequencies of the number of touched tiles are compared with the theoretical values.

THIS NOTEBOOK IS THE SOURCE CODE FROM

"Clean Tile Problem" from the Wolfram Demonstrations Project
 http://demonstrations.wolfram.com/CleanTileProblem/

Contributed by: Jacqueline D. Wandzura and Stephen M. Wandzura

Based on work by: Eric W. Weisstein

A full-function Wolfram Mathematica system (Version 6 or higher) is required to edit this notebook.
GET WOLFRAM MATHEMATICA »

© Wolfram Demonstrations Project & Contributors   |   Terms of Use   |   Make a new version of this Demonstration »