折り紙で３次方程式（２）

折り紙で３次方程式（１）からの続き

Mathematicaで折り紙の3次方程式問題をplotする関数を書いてみた。

最初に，Plot[{-x - 3, x + 1, 2 x, (x + 2)^2/4,   Sqrt[8 (x)] - 1, -Sqrt[8 (x)] - 1}, {x, -8, 8},  AspectRatio -> Automatic, PlotRange -> {-8, 8}]　こんな風に問題ごとにプロットしてみた。係数を混同していてなかなか正解にたどりつかなかったが，どうにか安定して答えがでてきた。ただし，接線の方程式は目の子であてはめている。

係数，a,b,c,dを与えて，焦点，準線，放物線，接線をすべて描画するように改善したものが次のコードである。最終ステップで，三次方程式を解いた解が3つリストとして出てくるので，これを実数の個数によって場合分けして描画するのはさぞ面倒だろうと心配していたのだが，リストの成分表示からリストに直しただけで求めていた結果が得られてしまった。虚数解が入ってきても何の問題もなくスキップしてくれた。やはりMathematicaは賢い。

そのコードは次のようなものである。

fold3[a_, b_, c_, d_] := 

{g0 = Graphics[{Point[{b, a}], Point[{d, c}], 

      Line[{{-10, -a}, {10, -a}}], Line[{{-d, -10}, {-d, 10}}]}, 

     Axes -> True]; 

 g1 = Plot[{(x - b)^2/(4*a), Sqrt[4 d x] + c, -Sqrt[4 d x] + c},

    {x, -10, 10}, PlotRange -> {-10, 10}, AspectRatio -> Automatic]; 

 sol = Solve[a t^3 + b t^2 + c t + d == 0, t]; 

 t1 = t /. sol; 

 s1 = -( a t1*t1 + b t1);

 g2 = Plot[t1 x + s1, {x, -10, 10}, PlotRange -> {-10, 10}, 

     AspectRatio -> Automatic, PlotStyle -> Red];

 Show[g0, g1, g2]}[[1]]

この関数で，fold3[1, 2, -2, -1]，fold3[1, 1, 1, 1]，fold3[1, 0, -1, 0.0001] を実行した結果を以下に示す。傾きが0の場合は，極限値として得られることになる。

図：fold3の実行結果