大人の塗り絵:塗り分けに五色必要な地図(1975年のエイプリルフール)


4102184619四色あれば,地図上の隣り合う領域の色が同じにならないように塗り分けられるという「四色定理」は,1800年代後半に予想され,1976年にコンピュータを使って「証明」された。

定理が「証明」される前の1975年に,マーチン・ガードナーが塗り分けに五色必要だとして発表した次の絵が話題になったという。(参考:Martin Gardner's April Fool's Map

これはエイプリルフールのネタだったのだが,四色で塗り分けたという手紙が数百通届いたらしい。(ロビン・ウィルソン『四色問題』(新潮社, 2013)p.38)

この大人の塗り絵をやってみたい。

0387753664Mathematica in Action で,塗り分ける方法が紹介されているのだが,http://extras.springer.com/からダウンロードできるコードは,最近のMathematicaでは動かない。(Mathematicaの言語仕様は後方互換性を保持しながら進化しているのだが,外部パッケージが本体に取り込まれた場合は,大抵うまくいかない。)

そこで,簡易版を作る。領域の境界線が垂直または水平の2pxの黒い実線の場合にのみ対応するという意味で「簡易」である。

Importで画像を読み込み,MorphologicalComponentsで領域に分割する(Colorize[matrix]で描画)。

四色で塗り分ける。(参考:ヨーロッパの地図の4色を求める

色を1組の真偽値で表し,色が同じでないという条件を連言標準形で記述することで,高速化している。

細かい注意:上の結果は周りが海に囲まれていても大丈夫なように,条件を追加して求めたもので,このコードの結果とはちょっと違うものになっている。

最後の描画はColorize[matrix, ColorRules -> cTable]でもいいのだが,この関数にはバグがあり,Mathematica 10.4.1では正しく動作しない。(製造元には報告済み。Ver.11で修正された。

Mathematicaのサジェスチョンバーはオフにすべき(10.4)(10.4.1で修正)


10.4.1で直ったようです。

Mathematica 9で導入されたサジェスチョンバーのせいで計算結果がおかしくなることがあるようです。テクニカルサポートにバグを報告したら,その回答として教えてもらいました。

例1:以下のコードを1行ずつ実行するとMathematicaが落ちます。

m = SparseArray[{{0, 1, 0}, {1, 0, 1}, {0, 0, 0}}];

n = Map[With[{s = Total[#]}, If[s == 0, #, #/s]] &, Normal[m]];

n.n

例2:以下のコードを1行ずつ実行するとコンテキストが勝手に変わってしまいます。

Context[]

f = Solve[{2 x + y == p, x - 2 y == q}, {x, y}][[1]];

x + y ≤ 4 /. f

Context[]

せっかくフロントエンドとカーネルを分けているのにどうしてこんなことになるのか不思議ですが,文句を言っても計算結果は変わらないので,以下の資料に従って,サジェスチョンバーはオフにしておきましょう。

入力予測インターフェースの機能をオフにする方法

MathematicaのMaxValueとMinValueのバグ(11.2で解決)


11.2で解決

Mathematica 10.1, 10.2, 10.3, 10.4.1, 11.1.1

Mathematicaの最大化MaxValueと最小化MinValueには,簡約のためのSimplifyの中では使えないというバグがあります(製造元には報告済みです)。

例として,0 <= t <= 1, 0 <= p <= 2 Pi, 0 <= q <= 2 Piという制約のもとで,f = Abs[t Sin[p] Sin[q]]という関数の最大値と最小値を求めます。

f = Abs[t Sin[p] Sin[q]];
cond = And[0 <= t <= 1, 0 <= p <= 2 Pi, 0 <= q <= 2 Pi];

当たりを付けるために,まずは数値的に求めます。

{NMaxValue[{f, cond}, {t, p, q}], NMinValue[{f, cond}, {t, p, q}]}

結果が{1., 0.}になることに,特に問題はないでしょう。

解析的に求めようとすると,うまく行きません。(11.2ではうまく行きます。)

MaxValue[{f, cond}, {t, p, q}]
(*結果は割愛。入力がそのまま返される*)

こういう関数の最大・最小は,そのままではうまくいかないとしたものです。残念ですが,これはしょうがない。

しかし,Simplifyの中で使うと計算が進むことがあります。制約条件を仮定して結果を整理することを試みます。

Simplify[MaxValue[{f, cond}, {t, p, q}], cond]

得られる結果は「∞」,もちろん間違いです。MinValueの場合も同様で,「-∞」という間違った結果が得られます。

Simplifyの仮定(外側のcond)が,MaxValueの制約(内側のcond)を簡約しているのが一因だと思います。そういうことがあるのは,次の例でわかります。

Simplify[MaxValue[{1/x^2, 0 < x}, x, Integers], 0 < x]

結果はMaxValue[{x^(-2), True}, x, Integers]になります(11.2では正しい結果「1」が得られます)。制約がTrueになっていますが,これはいけません。

Tweet-a-Programではちょっと違うことが起きているみたいです(こういうのは初めて見ました)。

他に原因があるかどうかはよくわかりません。

MaximizeMinimaizeでは,この問題は発生しません。一般に,MaximizeMinimizeMaxValueMinValueより遅いということになっているのですが,速さよりは正確さが大事なので,こちらを使った方がいいのかもしれません。

MathematicaのSolveとReduceのバグ(10.2で修正)


10.2で修正されました。

Mathematica 10, 10.1のSolveとReduceには,ベクトルや行列が等しくないという条件を正しく扱えないという,かなり深刻なバグがあります。(製造元には報告済みです。)

例として,
x^2+y^2 == 1かつy == 1/Sqrt[2]
という方程式を
{x, y} != {-1/Sqrt[2], 1/Sqrt[2]}
という条件のもとで解きます。

Solve[And[
  x^2 + y^2 == 1,
  y == 1/Sqrt[2],
  {x, y} != {-1/Sqrt[2], 1/Sqrt[2]}],
 {x, y}]

Mathematica 9.0.1では
{x -> 1/Sqrt[2], y -> 1/Sqrt[2]}
という正しい解が得られます。

Mathematica 10.1では
解なし
という間違った結果になります。

いろいろ試してみると,Solveの中に書いた
{x, y} != {-1/Sqrt[2], 1/Sqrt[2]}
という条件が,
x != -1/Sqrt[2] || y != 1/Sqrt[2]
ではなく,
x != -1/Sqrt[2] && y != 1/Sqrt[2]
と解釈されているようです。

Reduceでも同じ問題が起こります。

Reduce[{x, y} != {0, 0}, {x, y}]

Mathematica 9.0では
x!=0 || y!=0
という正しい解が得られます。

Mathematica 10.1では
x!=0 && y!=0
という間違った解が得られます。

というわけで,Mathematica 10.1では,SolveやReduceの中に,ベクトルや行列が等しくないという条件は書けません。とりあえずの解決策は,Or[x != 0, y != 0]のように成分ごとに書くことですが,これでは2次元限定ですし,そもそもMathematicaで成分を書いたら負けな気がするので,「例えば,Mathematica 10.1を避ける」でも仕方ないでしょう。

製造元のウェブサイトには,「世界で最も信頼できる最新技術計算システム」とありますが,それはないと思います。

MathematicaのNMinimize, NMinValueのバグ


Ver.11で修正されました。

Mathematica 9.0, 10.0, 10.1, 10.2, 10.3, 10.4.1 for Microsoft Windows (64-bit)と10.0.0 for Linux ARM (32-bit)でのことです。

a2 + c2 == 1, b2 + d2 == 1という条件の下で、次のような関数の最小値を求めたいとします。

Mathematicaには最大・最小を求めるためのさまざまな関数が用意されていますが、NMinimizeMinimizeNMinValueMinValueは、頭にNをつけるかどうかで、数値的な方法と解析的な方法を切り替えられて便利です。最小値とその時の各変数の値を知りたいときは[N]Minimize、最小値だけを知りたいときは[N]MinValueを使います。

しかし、ちょっとうまくいかない例に遭遇しました(UMMでも試せます)。バグが修正されたバージョンを受け取るために、プレミアユーザになっています。

問題その1

f1 = Sqrt[
 1 + 4 Sqrt[3] b c d + d^2 - 5 c^2 (-1 + d^2) + 
  2 a (-Sqrt[2] b d + Sqrt[6] c (-1 + d^2))];

NMinimize[{f1, a^2 + c^2 == 1 && b^2 + d^2 == 1}, {a, b, c, d}]

このように実行すると、

関数の値4.35271 +1.45672\ Iは{a,b,c,d} = {0.79784,1.52261,-0.444508,0.634251}において実数ではありません.

という警告とともに結果{1.22618, {a -> -0.82781, b -> 0.492467, c -> 0.224354, d -> -0.333602}}が返ります。このとき、a2 + c2は約0.74、b2 + d2は約0.35なので、与えた制約条件から大きくずれています。

問題その2

f2の最小値を求めようとしたときにも問題が起こります。

f2 = Sqrt[
  1 - 4 Sqrt[3] b c d + d^2 - 5 c^2 (-1 + d^2) + 
   2 a (-Sqrt[2] b d - Sqrt[6] c (-1 + d^2))];

NMinimize[{f2, a^2 + c^2 == 1 && b^2 + d^2 == 1}, {a, b, c, d}]

このように実行しても、入力がそのまま返ってくるだけで、まとも(?)な結果が得られません(間違った答えが返ってくるよりはましかもしれません)。

この問題は、WolframAlphaでも起こります(2015年5月17日確認)。

f1に関しては間違った結果が返ってきます(下はNMinValueの場合。NMinimizeでも同様)。

f2に関しては、珍しいことに、WolframAlphaは完全に沈黙します(下はNMinValueの場合。NMinimizeは違う結果になります)。

MathematicaからWolframAlphaに問い合わせたときはまた違う結果で、f2は解釈できないとのことでした。ほとんど同じf1は解釈できたので、そんなことはないと思うのですが。

そもそも、こういう関数の最小値を何の工夫もせずに得ようとするのが間違いなのかもしれませんが、あえて工夫をしないのにも理由があるのです。それについては別の機会に書きます。