バットマン方程式


バットマン方程式というのがあるそうです(Is this Batman equation for real?)。なんでも、この式を満たす(x, y)をプロットするとバットマンのマークになるのだとか。

batman equation

さっそくMathematicaのContourPlotで描こうとしたら、うまくいきませんでした。

仕方がないので、こんな感じにx方向に走査しながら方程式を満たす点を探して、一応描けました。

f[x_, y_] := ((x/7)^2 Sqrt[
      Abs[Abs[x] - 3]/(Abs[x] - 3)] + (y/3)^2 Sqrt[
      Abs[y + (3 Sqrt[33])/7]/(y + (3 Sqrt[33])/7)] - 
    1) (Abs[x/2] - ((3 Sqrt[33] - 7)/112) x^2 - 3 + 
    Sqrt[1 - (Abs[Abs[x] - 2] - 1)^2] - 
    y) (9 Sqrt[
      Abs[(Abs[x] - 1) (Abs[x] - 3/4)]/((1 - Abs[x]) (Abs[x] - 
           3/4))] - 8 Abs[x] - 
    y) (3 Abs[x] + .75 Sqrt[
      Abs[(Abs[x] - 3/4) (Abs[x] - 1/2)]/((3/4 - Abs[x]) (Abs[x] - 
           1/2))] - 
    y) (9/4 Sqrt[Abs[(x - 1/2) (x + 1/2)]/((1/2 - x) (1/2 + x))] - 
    y) ((6 Sqrt[10])/
     7 + (3/2 - Abs[x]/2) Sqrt[
      Abs[Abs[x] - 1]/(Abs[x] - 1)] - (6 Sqrt[10])/14 Sqrt[
      4 - (Abs[x] - 1)^2] - y)

points =
  Flatten[Table[{x, #} & /@ Cases[y /. NSolve[f[x, y] == 0, y], _Real],
    {x, -8, 8, 0.1}], 1];

ListPlot[points]

batman equation1

Mathematicaを持っている人は、pointsの計算の前にDistributeDefinition[f]を実行し、Tableの代わりにをParallelTableを使った方が速いでしょう。

こんなもんかなと思っていたら、Mathematicaできれいに描く方法がPlaying With Mathematicaで紹介されていました(The Batman curve)。パーツに分けてしまえば描けて当然という気もしますが、こっちのほうがきれいですね。

batman equation1

追記:Wolfram Alphaが対応したので、Mathematicaでも簡単に描けるようになりました。

コメントを残す

メールアドレスが公開されることはありません。 * が付いている欄は必須項目です