Is all about math Weblog

One of the new features of Mathematica 6.0 and above is that it allows you to create a new type of Mathematica notebook called a Mathematica Demonstration.

A Mathematica Demonstration usually consists of some sort of animation that can be manipulated thru some windows controls on the notebook. This is created using some new Mathematica 6.0 code.

The main part of the code is contained within

Manipulate[]

The Manipulate command resembles the Animate [] command of prior Mathematica versions. The main differences is that with Manipulate you may be able to use all the control types while with the Animate[] you may control one or multiple parameters with slider control.

When I got Mathematica I wanted to try my hands at creating a new Demonstration and I decided to create a demonstration on Fermat’s Theorem on Stationary Points.
This is a very beautiful theorem that states

If c is a local extremum in the interval (a,b) and f is differentiable at c, then f’(c)=0.

There is a very simple geometric interpretation of this theorem. As we know the first derivative of a function f could be interpreted as the slope of the tangent line thru the point (c,f(c)) if such derivative exist.  When the slope of the tangent line is zero  f’(c)=0.

My basic idea for the demo was to build a line segment tangent to a point c and I could vary the position of the point c and the line segment tangent  will get redraw.

I wanted to build the segment so that the length from (c,f(c)) to each of the ends of the segments was the same or that (c,f(c)) was the mid point of the segment. To accomplish this I figure the derivative of f at a point c and then computed the equation of the tangent line to f at c and then found the intersection of that line with a unit circle center on (c,f(c)). So the resulting Mathematica code looks like this nightmare!

Manipulate[
Plot[2 Sin[x] + x, {x, 0, 2 Pi},
Epilog -> {{Line[{{(
2 c + 4 c Cos[c] + 4 c Cos[c]^2 -
Sqrt[2] Sqrt[1 + 2 Cos[c] + 2 Cos[c]^2])/(
2 (1 + 2 Cos[c] + 2 Cos[c]^2)), (2 Cos[c] + 1) ((
2 c + 4 c Cos[c] + 4 c Cos[c]^2 -
Sqrt[2] Sqrt[1 + 2 Cos[c] + 2 Cos[c]^2])/(
2 (1 + 2 Cos[c] + 2 Cos[c]^2))) + 2 Sin[c] +
c - (2 Cos[c] + 1) c}, {(
2 c + 4 c Cos[c] + 4 c Cos[c]^2 +
Sqrt[2] Sqrt[1 + 2 Cos[c] + 2 Cos[c]^2])/(
2 (1 + 2 Cos[c] + 2 Cos[c]^2)), (2 Cos[c] + 1) ((
2 c + 4 c Cos[c] + 4 c Cos[c]^2 +
Sqrt[2] Sqrt[1 + 2 Cos[c] + 2 Cos[c]^2])/(
2 (1 + 2 Cos[c] + 2 Cos[c]^2))) + 2 Sin[c] +
c - (2 Cos[c] + 1) c}}]}, {Darker@Red, PointSize[0.015],
Point[{c, 2 Sin[c] + c}]}},
PlotLabel ->
Style[StringJoin["slope: " , ToString[N[2 Cos[c] + 1]]], 12],
AspectRatio -> Automatic, ImageSize -> {500, 400},
AxesLabel -> {Row[{Style["x", Italic], ” value”}],
TraditionalForm[2 Sin[x] + x]}], {{c, 2.08979, “value c”}, 0,
2 Pi}]

I have decided to simplify the code a bit to make the code more readable.

f[x_] = 2 (Sin[x]) + x;
d[x_] = D[f[x], x];
r = 1.5;
p1 := x /. Solve[(x -
c)^2 + ((d[c]) x + (f[c] - (d[c]) c) - (f[c]) )^2 == r^2,
x][[1]];
f1[c_] = p1;
p2 := x /. Solve[(x -
c)^2 + ((d[c]) x + (f[c] - (d[c]) c) - (f[c]) )^2 == r^2,
x][[2]];
f2[c_] = p2;
SetOptions[Plot,
Ticks -> {{-1, 0, 1, 2, 3, 4, 5, 6, 7}, {-1, 1, 2, 3, 4, 5, 6, 7}},
PlotRangePadding -> 1.5, AspectRatio -> Automatic,
Background -> Black, ImageSize -> {640, 480}, AxesLabel -> {x, y},
AxesStyle -> Directive[20, Thick, Orange]];
Manipulate[
Show[Plot[f[x], {x, -1, 2 Pi},
Epilog -> {
Inset[
Style[StringJoin["value:", ToString[N[c]]], Yellow, 20], {2, 7},
Alignment -> Center],
Inset[
Style[StringJoin["Slope:" , ToString[N[d[c], 5]]], Yellow,
20], {2.5, 6.5}],
If[lin, {Thick, Dashed, Green, Line[{{c, 0}, {c, f[c]}}]}, {}],
If[lin && der, {Thick, Dashed, Green,
Line[{{c, 0}, {c, d[c]}}]}, {}],
If[circle, {White, Circle[{c, f[c]}, r]}, {}], {Thick, Yellow,
Line[{{f1[c], (d[c]) (f1[c]) + f[c] - (d[c]) c}, {f2[
c], (d[c]) (f2[c]) + f[c] - (d[c]) c}}]},
If[der, {Red, PointSize[0.02], Point[{c, d[c]}]}, {}],
{Red, PointSize[0.02], Point[{c, f[c]}]}}
,
(*PlotLabel->Style[StringJoin["value:",ToString[N[c]],” “,
“Slope:” ,ToString[N[d[c],5]]],Yellow,20],*)
PlotStyle -> Directive[Red, Thick]
], If[der,
Plot[d[x], {x, -1.001, c}, PlotStyle -> Directive[Blue, Thick]
], {}
]
], {{c, (2 \[Pi])/3, “Value c”}, -1, 2 Pi,
0.001}, {{circle, False, “Show Circle”}, {False, True}}, {{der,
True, “Show Derivative”}, {False, True}},
{{lin, True, “Show line”}, {False, True}}]

And I also added three check boxes to be able to see the graph of the derivative of the function f(x) and also to be able to see the circle.

The original mathematica demonstration I created is at Wolfram demonstration.