SSブログ

Mathematicaで平面幾何学を扱う [日常のあれやこれや]

僕のちょんぼが各所に迷惑をかけていて、特に金型加工成形の現場からの信頼を減退させることになっている。損害額も今の会社にとっては結構痛手なのでなるべく回収できる方法を考えている。

そのせいで僕の通常業務は完全に停止しているけど、待ち時間も多いのでつい遊んでしまう。先日Mathematica12.0の新しい機能のGeometricSceneに気がついた。暇つぶしにはいい....

GeometricSceneのドキュメントを読んでも「シーン」の語が無定義で使われて、なんのことだかわからないけど、これはようするにユークリッドの平面幾何学の論理をMathematica上で表現するためのものらしい。具体的な例をあげたほうがわかりやすい。たとえば
GeometricScene[{a, b, c, d}, {Triangle[{a, b, c}], Line[{a, d}]}]
は点がa,b,c,dの4つあって、a,b,cを頂点とする三角形と、dとaとを結ぶ線分を表す。これだけではピンとこないけど、具体的に図形として表示する手段が用意されていて上の式を評価した後に
RandomInstance[%]
とすると
triangleandline.png
と絵を描いてくれる。座標を指定しないと適当に描く。自分の欲しい絵にならなかったら評価し直すなり、RandomInstanceの2つ目の引数に$n$を与えると$n$個の違った描き方をリストにする。乱数のタネを与えることや、あとで書くけど座標を明示的に与えて制約することもできる。

これだけだと、だからどうした、と言う感じだけど、例えばもう少し複雑な例としてラングレーの問題を書くと
langley = 
 GeometricScene[{a, b, c, d, e}, {Triangle[{a, b, c}], 
   EuclideanDistance[a, b] == EuclideanDistance[a, c], 
   Element[Point[d],  Line[{a, c}]], Element[Point[e], Line[{a, b}]],
    PlanarAngle[{b, a, c}] == 20 Degree, Triangle[{b, c, e}], 
   PlanarAngle[{b, c, e}] == 50 Degree, Triangle[{b, c, d}], 
   PlanarAngle[{c, b, d}] == 60 Degree, Triangle[{b, d, e}]}];
となる。EuclideanDistanceは2点間の距離で、PlanarAngleは角度である。またElementは「要素として属する」と言う意味で、この例では点が線分上にあるということを表す。Mathematicaに入力する時は「$\in$」の記号を使うほうが読みやすい。aが点であるとを明示的にPoint[a]と書いたけどこれはいらないようである。これを
RandomInstance[langley]
として絵に描いてみると
0928langley.png
となる。点の座標はランダムに選ばれるので、Wikipediaにあるような絵にするなら2つ目のカッコの中に
b == {-1, 0}, c == {1, 0}
と条件を追加するか、あるいは点の列挙中に
{a, b -> {-1, 0}, c -> {1, 0}, d, e}
などと縛りを入れれて描けばいい。ただし、制約が多すぎたり、逆に制約が少なすぎてなんとでもなるようなとき、絵を描くのに時間がかかることがある(場合によってはカーネルがクラッシュする。新しい機能なので十分煮詰まってないらしい)。また制約に矛盾がある場合(たとえば三角形の3つの角度を与えてその合計が$\pi$になっていないとか)、それが検出できなくて返ってこなくなることがある。検出できてもエラーになるわけではなくて、無評価で返されるようである。

ラングレーの問題はこの∠bdeの角度を求めるというものだけど、このためには
FindGeometricConjectures[langley]
とすると推論で得られた条件を絵と一緒に表示する。
0928langleysolutions.png
この問題は「伝説の難問」と言われるようだけど、ここでは30°の正解が得られている。MathematicaではConjecture(推論、推測)と控えめな言い方になってる(この方面の専門用語らしい)けど、与えられた条件から直接演繹可能な、自明な条件が列挙される。これ以外にも満足する条件が上のポップアップリストになって、ポップアップで選択された条件が下の絵にハイライトされる。条件式として欲しいなら
FindGeometricConjectures[langley]["Conclusions"]
とすると
{GeometricAssertion[{Triangle[{c, a, e}], Triangle[{d, b, e}]}, "Similar"],
 EuclideanDistance[b, e] == EuclideanDistance[b, c], 
 EuclideanDistance[a, d] == EuclideanDistance[b, d], 
 EuclideanDistance[a, c] == EuclideanDistance[b, a], 
 Inactive[PlanarAngle][{c, e, d}] == Inactive[PlanarAngle][{d, c, b}] == 
        Inactive[PlanarAngle][{e, b, c}], 
 Inactive[PlanarAngle][{a, e, d}] == Inactive[PlanarAngle][{b, c, e}] == 
        Inactive[PlanarAngle][{b, e, c}], 
 Inactive[PlanarAngle][{b, d, e}] == 
        Inactive[PlanarAngle][{d, c, e}] == 30 \[Degree], 
 Inactive[PlanarAngle][{d, a, e}] == Inactive[PlanarAngle][{e, b, d}],
        Inactive[PlanarAngle][{a, e, c}] == Inactive[PlanarAngle][{b, e, d}], 
 Inactive[PlanarAngle][{c, b, d}] == 60 \[Degree], 
 EuclideanDistance[b, a] == EuclideanDistance[b, d] + EuclideanDistance[d, c], 
 EuclideanDistance[a, c] == EuclideanDistance[b, d] + EuclideanDistance[d, c], 
 EuclideanDistance[b, a] == EuclideanDistance[a, d] + EuclideanDistance[d, c], 
 EuclideanDistance[a, c] == EuclideanDistance[b, e] + EuclideanDistance[e, a], 
 EuclideanDistance[b, a] == EuclideanDistance[b, c] + EuclideanDistance[e, a], 
 EuclideanDistance[a, c] == EuclideanDistance[b, c] + EuclideanDistance[e, a]}
と返ってくる。これら以外に言えることはないのかはよくわからない。ちなみに、Inactiveはその関数を評価しない、というラッパ関数。PlanarAngleは引数を評価して簡約できるとその結果を返してしまう(30°と決まればそれと置き換えてしまう)ので評価を止めるためのもの。言うなればMathematicaの都合で勝手にくっついているもので、はっきり言えば煩わしい。

ユークリッド幾何学に出てくる「平行」や「合同」や「2直線の交点」なんかの条件は、例えば
GeometricAssertion[{AngleBisector[{c, a, b}],
        AngleBisector[{a, b, c}]}, {"Concurrent", d}]
などとGeometricAssertionの式として書くことができる。この例は∠cabの2等分線(AngleBisector)と∠abcの2等分線とが交差していて、その交点がdだという表明になる。他の表現可能な条件についてはドキュメントの詳細にある("Similar"を「似ている」と訳しているけど、これは「相似」のこと。ちなみに、僕は中学のころ数学の因数分解かなにかを黒板でやらされて、先生に「間違ってる。正解はこう」と指摘されたとき「似てる」と言ったら「数学は正しいか間違ってるかで、似てるなんてことはない」と怒られた)。

ところで、GeometricAssertionに渡す具体的な条件(さっきの例では"Concurrent")は、例によって文字列で指定することになって、綴りや大文字小文字に気をつけないと欲しい条件にならないどころか、エラーにもならないので注意が必要である。式を入力して無評価で帰ってきた場合はどこかにエラーがあると思ってほぼ間違いない。これに限らず、最近Mathematicaに追加された機能では思った結果が得られないとき、なにが違うのか、どこにエラーがあるのか、それともMathematica本体のバグなのかわからないことが多い。デバグの観点からは非常に不便である。Wolframはどう考えているのか。



まあ、それはいいとして、これを使って小中学校の図形問題を表してみる。まず簡単なものから、ここの最初にある証明問題
p1 = GeometricScene[{a, b, c, d, e}, {InfiniteLine[{a, e}], 
    Line[{a, b}], Line[{b, d}], Line[{d, e}], 
    Element[c, Line[{a, e}]], Element[c, Line[{b, d}]], 
    EuclideanDistance[b, c] == EuclideanDistance[d, c], 
    EuclideanDistance[a, c] == EuclideanDistance[e, c]}];
RandomInstance[p1]
FindGeometricConjectures[p1]
p1solution.png
で、解が得られた。

もう少し難しいここの応用問題
o1 = GeometricScene[{a, b, c, d, e, g, f, o}, {Triangle[{a, b, g}], 
    Triangle[{d, b, e}], CircleThrough[{a, b, c, d, e}, o], 
    EuclideanDistance[b, a] == EuclideanDistance[b, d], 
    GeometricAssertion[{Line[{a, e}], Line[{d, c}]}, "Parallel"], 
    GeometricAssertion[{Line[{a, e}], Line[{b, d}]}, {"Concurrent", 
      f}], GeometricAssertion[{Line[{a, e}], 
      Line[{b, c}]}, {"Concurrent", g}]}];
と書けて(CircleThroughはリストの点がoを中心にした円の上にあることを表明する)、三角形の合同は
FindGeometricConjectures[o1]
osol.png
で得られる。ある問題からそのGeometricSceneオブジェクトを構築するのは、慣れてくればそれほど難しくはなくなる。GeometricAssertionの書き方はドキュメントを見ながらでないと無理だけど。

またもう少し難しそうな相似を証明する問題では
i7 = GeometricScene[{a, b, c, d, e, f, g, h}, {Polygon[{a, b, c, d}], 
    GeometricAssertion[{Line[{a, d}], Line[{b, c}]}, "Parallel"], 
    GeometricAssertion[{Line[{a, b}], Line[{d, c}]}, "Parallel"], 
    GeometricAssertion[{AngleBisector[{b, a, d}], 
      Line[{b, c}]}, {"Concurrent", e}], 
    GeometricAssertion[{AngleBisector[{a, d, c}], 
      Line[{b, c}]}, {"Concurrent", f}], 
    GeometricAssertion[{AngleBisector[{a, d, c}], 
      AngleBisector[{b, a, d}]}, {"Concurrent", g}], 
    GeometricAssertion[{AngleBisector[{b, a, d}], 
      HalfLine[{d, c}]}, {"Concurrent", h}]}];
と書くことができて、
i7sol.png
として問題以外の解も含めて得られる。

しかし例えばこれみたいな対称性の高い問題
s2 = GeometricScene[{a, b, c, d, p, q, r, s, x, y, z, w},
   {Polygon[{a, b, c, d}], 
    GeometricAssertion[Polygon[{a, b, c, d}], "Regular"], 
    p == Midpoint[{a, b}], q == Midpoint[{b, c}], 
    r == Midpoint[{c, d}], s == Midpoint[{d, a}], 
    GeometricAssertion[{Line[{a, r}], Line[{b, s}]}, {"Concurrent", 
      x}], GeometricAssertion[{Line[{b, s}], 
      Line[{c, p}]}, {"Concurrent", y}], 
    GeometricAssertion[{Line[{c, p}], Line[{d, q}]}, {"Concurrent", 
      z}], GeometricAssertion[{Line[{d, q}], 
      Line[{a, r}]}, {"Concurrent", w}], 
    Area[Polygon[{a, b, c, d}]] == 100}];
symmetric.png
では対称性を無視して、ぞろぞろ似たような解がいっぱいでてきて煩わしい。さらにこういう「面積を求めなさい」というような、長さ面積やその比といった角度以外の計量に関する結論には弱い。

計量に関しては、ドキュメントにはないけどGeometricSceneの第1引数にパラメータを与えることができるらしくて、それを
GeometricScene[{{a, b, c},{p}},....
   Area[Triangle[{a, b, c}]] == p,...
のように必要な値に指定しておいて
RandomInstance[%]["Quantities"]
とすると、与えたパラメータの数値が得られる。ただし、これは絵を描くための数値解で、厳密解にはなっていない。同じように複数のパラメータを与えて、その間の関係、例えば長さの比などを求めようとしてもうまくいかない。FindGeometricConjecturesの推論の一部として得られるようになるのが望ましい。

そして当然、過程が示されないので証明問題には使えない(またちなみに、昔僕は中学の時の証明問題に「だって、あたりまえだから」と答えて怒られた。どんな問題だか忘れたけど、その時の僕と同じ姿勢である)。

証明問題にはFindGeometricConjectures[_]["Conclusions"]の返す条件をひとつひとつ見ていって「この角が同じだからこの三角形は合同で..」などと追っていけばたどり着ける。でもそれなら普通に考えるのと大して変わらない、とは言える。でも条件をずらっと並べて詳しく見ていくと、教科書によくある補助線なんかを使わなくても結論にたどり着けるような気がしてくる。関数評価の結果として条件間の関係を整理してくれれば役にたつかもしれない。

このGeometricSceneがどう言う問題に威力を発揮できるかと言うと、例えば、たくさんの図形が重なって並んでいて「これこれの三角形と相似な三角形をすべてあげなさい」というような問題には有効だろう。人間には「見逃す」ということがあるけどMathematicaにその心配はない。

ところで、与えられた条件を満足しながら自由度のあるところはランダムにして図形を描く、というのは案外難しい。複数の条件を課すことで平行移動と回転以外の自由度がなくなったり、わずかな違いで矛盾したりするけど、それを解析しないといけない。僕はその辺に詳しくないのでよくわからないけど、連立方程式のように汎用的な手段があるんだろうか。

Mathematica11でFindEquationalProof関数で公理系から等式を証明することができるようになった。限定的な自動証明で、GeometricSceneも同じメカニズムを使っていると思われるが、FindEquationalProofと違って絵として見た目が得られるのでずっと面白く遊ぶことができる。先週僕は待ち時間があるとネットから図形問題を拾ってきてはこれでずっと遊んでいた。

とはいえ、これらはこないだの多体問題の数値解と同じで、現実の問題には役に立たないと言う意味で、完全におもちゃである。しかしこっちのほうにはこの先の展開が考えられる。ひょっとするとWolframはこれをもっと練り上げてMathematicaのどこかに応用する遠大な計画があるのかもしれない。というか、そうならMathematicaでDeep LearningやブロックチェーンやUnity通信をやるのに比べたら、ずっと面白そうな気がする。

今日あげた例はすべてRaspberry PiのMathematica 12.0で常識的な範囲の時間(何分も待たされることはない、せいぜい数十秒)で実行できることは確認した。中学の子供に図形の宿題を教えてくれと言われてはぐらかしているお父さんお母さんのうち、Raspberry Piで遊んでいるひとは試しにやってみて欲しい。いや、あまり役には立たないかもしれないけど、退屈な図形問題におもちゃで遊ぶ要素を追加できるような気がする。僕もうちの子供達が今の半分の年齢なら、一緒に遊んでみたかった。

「倍遅い」という言葉が思い浮かんだけど、日本語としてはおかしいな。
nice!(0)  コメント(0) 

nice! 0

コメント 0

コメントを書く

お名前:
URL:
コメント:
画像認証:
下の画像に表示されている文字を入力してください。

この広告は前回の更新から一定期間経過したブログに表示されています。更新すると自動で解除されます。