　　　　On a Thread of the Web: アインシュタインモノタイル

2023年3月27日月曜日

アインシュタインモノタイル

ある図形で平面を埋めるのが，平面充填問題（tiling/tessellation）だ。

正三角形，正方形，正六角形で充填できることは簡単にわかる。平行四辺形や2つ組み合わせると平行四辺形になる任意の三角形も同様だ。任意の四角形を2つ組み合わせると。平行六辺形になって，これで敷き詰めることもできる。四角形の内角の和が360度なので一点の回りに各角が集まるようにすれば充填できそうな気もする。たぶん。

自明でないものとして，五角形がある。五角形による平面充填は15のパターンに限られていることが証明されているらしい。ここまでの例はすべて並進対称性＝周期性を持つ場合になっている。非周期的な充填の例としては，二種類の菱形から構成されるペンローズ・タイルが有名だ。磁石付きペンローズ・タイルの玩具をどこかの博物館でお土産で買ってきたことがある。

最近，1種類の多角形だけで非周期的な平面充填ができるものが見つかった。これはEinstein Problem と呼ばれる未解決問題だった。なお，物理学者のアインシュタインではなく，ドイツ語のアイン（Ein）＝１つの，シュタイン（Stein）＝石からきている。まだ論文は査読中らしいが，1つの解が存在していることが分かる。

GPT-4を使ってPythonでこの図形を出力するプログラムを作成した。それらしい結果がでたが，間違っている。これに手を加えるのは面倒だったので，Mathematicaに翻訳してもらって背景のパターンを求めた。それに手を加えた結果が次の通りである。

(*ベクトルaとbを定義します。*)
w = 7; o = {0, 0};
a = {1, 0}; b = {1/2, Sqrt[3]/2};
c = {3/4, Sqrt[3]/4}; d = {0, Sqrt[3]/2};
e = {3/2, Sqrt[3]/2}; f = {0, Sqrt[3]};
gl0 = Table[
Graphics[{Gray, Dotted, Line[{k*d - w*a, k*d + w*a}]}], {k, -w, w}];
gl1 = Table[
Graphics[{Gray, Dotted, Line[{w*b + k*a, -w*b + k*a}]}], {k, -w, w}];
gl2 = Table[
Graphics[{Gray, Dotted, Line[{-w*b + (w + k)*a, w*b + (k - w)*a }]}], {k, -w, w}];
gr0 = Table[
Graphics[{Gray, Dotted, Line[{{k*3/4, -w}, {k*3/4, w}}]}], {k, -w, w}];
gr1 = Table[
Graphics[{Gray, Dotted, Line[{w*(d - c) + k*d, -w*(d - c) + k*d}]}], {k, -w, w}];
gr2 = Table[
Graphics[{Gray, Dotted, Line[{w*c + k*d, -w*c + k*d}]}], {k, -w, w}];

(*drawPoint関数を定義します。この関数は、整数m,nと色を引数に取り、
ベクトルv=m*a+n*bを計算して描画します。*)
drawPoint[x_, y_, c_, m_, n_] :=
Graphics[{PointSize[0.01], c, Point[m*x + n*y]}]

(*乱数を使ってm,nの組を生成し、点を描画する例です。*)
drawRandomPoints[x_, y_, cl_, de_, np_] :=
Module[{m, n, points},(*乱数でmとnの値を生成します。*)
m = RandomInteger[{-de, de}, np];
n = RandomInteger[{-de, de}, np];
(*点を描画します。*)
points = Table[drawPoint[x, y, cl, m[[i]], n[[i]]], {i, np}];
(*プロットを表示します。*)
Show[points, Axes -> True, PlotRange -> {{-de, de}, {-de, de}},
AspectRatio -> 1]]

(*例として、ランダムな点を描画します。*)
g1 = drawRandomPoints[a, b, Red, 7, 1000];
g2 = drawRandomPoints[c, d, Blue, 7, 1000];
g3 = drawRandomPoints[e, f, Green, 4, 400];
gp = Graphics[{LightRed, EdgeForm[Gray],
Polygon[{o, d, d + a/2, d + (a + b)/2, c + (a + b)/2,
c + (a + b)/2 - d, c + a + b/2 - d, c + 3 a/2 a - d, 3 a/2 - d,
3 a/2 - c, 3 a/2 - c - b/2, a/2 - c - b/2, -a/2 - b/2, o}]}];
Show[gp, gl0, gl1, gl2, gr0, gr1, gr2, g1, g2, g3, PlotRange -> {{-6, 6}, {-6, 6}}]