Summer Semester, 2010

(10 points)

Define a function that has the following graph:

Plot the function on the interval [-2,2], such that the x-axis be twice long than the y-axis, and color the graph depending on the x-coordinate.

f[x_]=2Abs[Mod[x,1]-0.5];

Plot[f[x],{x,-2,2},AspectRatio->0.5,ColorFunction->(Hue[#1]&)]

(5 points)

Write a function that calculates the p-norm (1≤p<∞) of the vector given in a list. Do not use loops, Table, Sum! Give an example!

(((∑_(i=1)^n)|(Subscript[a, i])((|)^p))^(1/p))

HM[a_?VectorQ,p_/;∞>p≥1]:=
(Apply[Plus,Abs[a]^p])^(1/p)

HM[{a1,a2,a3},3]

(20 points)

Consider the following function:

f(x_,y_):=f(x,y)=((x^2)/2)-0.2 x+(y^2)-0.1 y-(Sqrt[(x^2)+(y^2)])

Find the extremal and saddle points. Use graphical study to find good initial values.

F[x_,y_]:=((x^2)/2)-0.2 x+(y^2)-0.1 y-(Sqrt[(x^2)+(y^2)])

x1=-1.2;x2=1.5;
y1=-0.8; y2=0.8;

Plot3D[F[x,y],{x,x1,x2},{y,y1,y2},AxesLabel->{x,y,z},Mesh->False]

pltcontour=ContourPlot[F[x,y],{x,x1,x2},{y,y1,y2},FrameLabel->{x,y},Contours->30]

ContourPlot[F[x,y],{x,-1,0.1},{y,-0.3,0.3},FrameLabel->{x,y},Contours->50]

ContourPlot[F[x,y],{x,0.8,1.5},{y,-0.3,0.3},FrameLabel->{x,y},Contours->50]

gradcontour=ContourPlot[Evaluate[D[F[x,y],{{x,y}}]=={0,0}],{x,x1,x2},{y,y1,y2},FrameLabel->{x,y}]

Show[pltcontour,gradcontour]

maxinit={{-0.1,0.1}};

max=Table[FindMaximum[F[x,y],{{x,0.2,maxinit[[i,1]]},{y,0.2,maxinit[[i,2]]}}],{i,1,Length[maxinit]}]

mininit={{-0.8,0.1},{1,0.1}};

min=Table[FindMinimum[F[x,y],{{x,0,mininit[[i,1]]},{y,0,mininit[[i,2]]}}],{i,1,Length[mininit]}]

Show[pltcontour,gradcontour,Graphics[Point[Flatten[{x,y}/.{min[[All,2]],max[[All,2]]},1]]]]

Saddle points (based on the figure)

FindRoot[Evaluate[D[F[x,y],{{x,y}}]=={0,0}],{x,-0.2},{y,0.6}]

FindRoot[Evaluate[D[F[x,y],{{x,y}}]=={0,0}],{x,0.1},{y,0.4}]

(15 points)

Consider a family of parametric curves {x(t,c),y(t,c)} that depends on a parameter c (for example {cos(t),sin(c t)}). 
Animate a graph of the curve depending on the parameter c.

Write a function  named StackParametricPlot in Mathematica that plots the frames of the animation in a 3D coordinate system {x,y,c}. Give an example!
The result should look like this:

Extra problem for extra 10 points:

Combine the animation with the 3D graphics!

Show[Table[ParametricPlot3D[{c,Cos[t],Sin[c t]},{t,0,2 π},PlotStyle->Hue[c]],{c,0,2,0.2}],PlotRange->{{0,2},{-1,1},{-1,1}},BoxRatios->{2,1,1},AxesLabel->{c,x,y}]

3D Manipulate

Manipulate[Show[ParametricPlot3D[{cc,Cos[t],Sin[cc t]},{t,0,2 π},PlotStyle->{Hue[cc],Thickness[0.01]}],Table[ParametricPlot3D[{c,Cos[t],Sin[c t]},{t,0,2 π},PlotStyle->Hue[c]],{c,0,2,0.2}],PlotRange->{{0,2},{-1,1},{-1,1}},BoxRatios->{2,1,1},AxesLabel->{c,x,y}],{cc,0,2}]

(25 points)

Consider the following difference equation (Henon's map):

{(Subscript[x, n+1]),(Subscript[y, n+1])}:={(Subscript[y, n])+1-1.4 ((Subscript[x, n])^2),0.3(Subscript[x, n])}

Iterate it from an appropriate initial point, and plot the coordinates with respect to the time, and the trajectory. Use coloring by the time. Create a dynamic application in which the initial point can be changed interactively.

T[{t_,x_,y_}]:={t+1,y+1-1.4 (x^2),0.3x}

sol=NestList[T,{1,1.1,1},1000];

Graphics[sol/.{t_,x_,y_}->{Hue[1/t],Point[{x,y}]}]

(25 points)

Consider the nonlinear van der Pol oscillator:

x'=y, 
y'=(1-(x^2))y-sin(x) .

Find the equilibria. Solve the system for t ϵ [0,30] with several initial values  x(0), y(0)  on the y-axis (x(0)=0).
Plot the vectorfield, the trajectories of the solutions (colored by the time) and the equilibria. Create an animation of the moving points and tangent vectors along the trajectories at (t=0,0.5,1,...10).

pendulum={x'[t]==y[t],y'[t]==(1-x[t]^2)y[t]-Sin[x[t]],x[0]==0,y[0]==y0};

pendfld={y,(1-x^2)y-Sin[x]}

t1=0; t2=10;
x1=-3; x2=3;
y1=-3; y2=3;

Needs["VectorFieldPlots`"]

pfld=VectorFieldPlot[pendfld,{x,x1,x2},{y,y1,y2},Axes->True,ScaleFactor->1]

sol=Table[{x[t],y[t]}/.NDSolve[pendulum,{x[t],y[t]},{t,t1,t2}],{y0,-3,3,0.2}]

ptraj=ParametricPlot[sol,{t,t1,t2},ColorFunction->(Function[{x,y,t},Hue[t]]),ColorFunctionScaling->True]

Show[pfld,ptraj,AspectRatio->Automatic]

Manipulate[
DynamicModule[{pendulum,x,y,t,sol,penfld},pendulum={x'[t]==y[t],y'[t]==(1-x[t]^2)y[t]-Sin[x[t]],x[0]==0,y[0]==y0};
pendfld={y,(1-x^2)y-Sin[x]};
sol={x[t],y[t]}/.NDSolve[pendulum,{x[t],y[t]},{t,0,t2}];
Show[ParametricPlot[sol,{t,0,t2},ColorFunction->(Function[{x,y,t},Hue[t]]),ColorFunctionScaling->True,PlotRange->{{-dx,dx},{-dy,dy}}],VectorFieldPlot[pendfld,{x,-dx,dx},{y,-dy,dy},Axes->True,ScaleFactor->1]]
],{{y0,1}, -dy,dy},{t2,5,20},{{dx,2},0.5,10},{{dy,2},0.5,10},ControlPlacement->Left,Initialization:>(Needs["VectorFieldPlots`"])]

(10 points)

Define a function that has the following graph:

Plot the function on the interval [-3,3], such that the x-axis be three time longer than the y-axis, and color the graph depending on the y-coordinate.

f[x_]=(4Abs[Mod[x,1]-0.5]-1)^2;

Plot[f[x],{x,-3,3},AspectRatio->0.5,ColorFunction->(Hue[#2]&)]

(5 points)

Write a function that calculates the harmonic mean of the p-th power of the elements of a list. Do not use loops, Table, Sum! Give an example!

(n/((1/(|(Subscript[a, 1])((|)^p)))+(1/(|(Subscript[a, 2])((|)^p)))+...+(1/(|(Subscript[a, n])((|)^p)))))

HM[a_?VectorQ,p_/;∞>p≥1]:=Length[a]/(Apply[Plus,1/Abs[a]^p])

HM[{a1,a2,a3},3]

(20 points)

Consider the following function:

f(x_,y_):=(((y^4)+2 y-0.3 y+(x^2)-(Sqrt[(y^4)+(x^2)]))/(e^((x^4)+(y^2)-4)))

Find the extremal and saddle points. Use graphical study to find good initial values.

F[x_,y_]:=(((y^4)+2 y-0.3 y+(x^2)-(Sqrt[(y^4)+(x^2)]))/(E^((x^4)+(y^2)-4)))

x1=-1.2;x2=1.2;
y1=-1.5; y2=1.5;

Plot3D[F[x,y],{x,x1,x2},{y,y1,y2},AxesLabel->{x,y,z},Mesh->False]

pltcontour=ContourPlot[F[x,y],{x,x1,x2},{y,y1,y2},FrameLabel->{x,y},Contours->30]

ContourPlot[F[x,y],{x,-1/3,1/3},{y,-0.6,-0.75},FrameLabel->{x,y},Contours->50]

ContourPlot[F[x,y],{x,-1/2,1/2},{y,0.9,01.2},FrameLabel->{x,y},Contours->50]

gradcontour=ContourPlot[Evaluate[D[F[x,y],{{x,y}}]=={0,0}],{x,x1,x2},{y,y1,y2},FrameLabel->{x,y}]

maxinit={{-0.5,1.1},{0.5,1.1}};

max=Table[FindMaximum[F[x,y],{{x,maxinit[[i,1]]},{y,maxinit[[i,2]]}}],{i,1,Length[maxinit]}]

mininit={{-0.2,-0.6},{0.2,-0.6}};

min=Table[FindMinimum[F[x,y],{{x,0,mininit[[i,1]]},{y,0,mininit[[i,2]]}}],{i,1,Length[mininit]}]

Show[pltcontour,gradcontour,Graphics[Point[Flatten[{x,y}/.{min[[All,2]],max[[All,2]]},1]]]]

Saddle points (based on the figure)

FindRoot[Evaluate[D[F[x,y],{{x,y}}]=={0,0}],{x,0.01},{y,-0.6}]

FindRoot[Evaluate[D[F[x,y],{{x,y}}]=={0,0}],{x,0.01},{y,1.}]

(15 points)

Consider a family of function f(x,c) that depends on a parameter c (for example sin(c x)). Animate a graph of f depending on the parameter c.

Write a function named StackPlot in Mathematica that plots the frames of the animation in one 3D coordinate system {x,y,c}. Give an example!
The result should look like this:

Show[Table[ParametricPlot3D[{c,x,Sin[c x]},{x,0,2 π},PlotStyle->Hue[c]],{c,0,2,0.2}],PlotRange->{{0,2},{0,2Pi},{-1,1}},BoxRatios->{2,1,1},AxesLabel->{c,x,y}]

Extra problem for extra 10 points:

Combine the animation with the 3D graphics!

Manipulate[Show[ParametricPlot3D[{cc,x,Sin[cc x]},{x,0,2 π},PlotStyle->{Hue[cc],Thickness[0.01]}],Table[ParametricPlot3D[{c,x,Sin[c x]},{x,0,2 π},PlotStyle->Hue[c]],{c,0,2,0.2}],PlotRange->{{0,2},{0,2Pi},{-1,1}},BoxRatios->{2,1,1},AxesLabel->{c,x,y}],
{cc,0,2}]

(25 points)

Take the points (Subscript[P, 1]),(Subscript[P, 2]),..., (Subscript[P, k]) randomly ((Subscript[P, i])ϵ (R^2), k >>100). Plot the polygon with the vertices (Subscript[P, i]). Then take a new polygon such that the vertices are the points dividing the edges of the original polygon at ratio 1:2. Iterate this process. Make an animation with the elements of  the iteration.

(25 points)

Consider the nonlinear system of species competing for the same territory:

(Subscript[p, 1])' =0.8(Subscript[p, 1])(1-(Subscript[p, 1])-(Subscript[p, 2]))-0.1(Subscript[p, 1]) + 0.7 (Subscript[p, 1])(Subscript[p, 2]),
(Subscript[p, 2])'= 0.05(Subscript[p, 2])(1-(Subscript[p, 1])-(Subscript[p, 2]))-0.1 (Subscript[p, 2])- 0.7 (Subscript[p, 1])(Subscript[p, 2]), 
where 0≤(Subscript[p, 1]), (Subscript[p, 2]) and (Subscript[p, 1])+(Subscript[p, 2])≤1.

Find the equilibria. Solve the system for t ϵ [0,100] with several initial values x(0), y(0) on the line x(0)+ y(0)=0.9. 
Plot the trajectories of the solutions (colored by the time), the equilibria, and the vector field. Create an animation of the development of the system in the time.

pop={p1'[t]==0.8p1[t](1-p1[t]-p2[t])-0.1p1[t] + 0.7 p1[t] p2[t],p2'[t]==0.05p2[t](1-p1[t]-p2[t])-0.1 p2[t]- 0.7 p1[t]  p2[t],p1[0]==p10,p2[0]==0.9-p10};

popfld={0.8p1(1-p1-p2)-0.1p1 + 0.7 p1 p2,0.05p2(1-p1-p2)-0.1 p2- 0.7 p1 p2}

t1=0; t2=10;
x1=0; x2=1;
y1=0; y2=1;

Needs["VectorFieldPlots`"]

pfld=VectorFieldPlot[popfld,{p1,x1,x2},{p2,y1,y2},Axes->True,ScaleFactor->0.3]

sol=Table[{p1[t],p2[t]}/.NDSolve[pop,{p1[t],p2[t]},{t,t1,t2}],{p10,0,1,0.1}]

ptraj=ParametricPlot[sol,{t,t1,t2},ColorFunction->(Function[{x,y,t},Hue[t]]),ColorFunctionScaling->True]

Show[pfld,ptraj,AspectRatio->Automatic]

Manipulate[
DynamicModule[{pop,p1,p2,t,sol,popfld},pop={p1'[t]==0.8p1[t](1-p1[t]-p2[t])-0.1p1[t] + 0.7 p1[t] p2[t],p2'[t]==0.05p2[t](1-p1[t]-p2[t])-0.1 p2[t]- 0.7 p1[t]  p2[t],p1[0]==p10,p2[0]==0.9-p10};
popfld={0.8p1(1-p1-p2)-0.1p1 + 0.7 p1 p2,0.05p2(1-p1-p2)-0.1 p2- 0.7 p1 p2};
sol={p1[t],p2[t]}/.NDSolve[pop,{p1[t],p2[t]},{t,0,t2}];
Show[ParametricPlot[sol,{t,0,t2},ColorFunction->(Function[{x,y,t},Hue[t]]),ColorFunctionScaling->True,PlotRange->{{0,1},{0,1}}],VectorFieldPlot[popfld,{p1,0,1},{p2,0,1},Axes->True,ScaleFactor->1]]
],{{p10,1}, 0,1},{t2,5,20},ControlPlacement->Left,Initialization:>(Needs["VectorFieldPlots`"])]