Solutions for Mathematica Exercises (© P. Fischer)

Exercise 1: Numbers

Sqrt[2] (* By default, Mathematica stays with exact expressions *)

N[%,100] (* Force a numberical evaluation of the previous (%) line *)

((20!)/45)

((20!)/46)∈ Integers (* We can check whether the result is an integer *)

FactorInteger[20!] (* FactorInteger[...] generates a list of prime factors with multiplicities *)

Sqrt[-4]

F1=(4/5); F2=(5/8);

F1+F2

F1*F2

1/2-1/3

Sqrt[F1]

1-(((Sqrt[2 π 100])((((100/E)))^100))/(100!))//N

1-(((Sqrt[2 π n])((((n/E)))^n))/(n!))/.n->100//N (* more general, replacing n by a fixed value *)

Exercise 2: Lists and Expressions

alist=Table[(n^2),{n,1,10}]

{First[alist],alist[[3]],Last[alist]}

v1={1,2,3};v2={2,3,4};

v1.v2

A={{1,2},{3,4}}

A//MatrixForm

B=Inverse[A]

A.B//MatrixForm

A=3x+5;B=5(x^2)-7;

F=A B//Expand

F//Factor

F/A

%//Simplify

Exercise 3: Manipulations & Replacements

Clear[A];

A=(1+3x)(1+6x)

A//Simplify

A//Expand

%/.x->1+(Sqrt[y])

%//Simplify

%//Factor

B=%/.y->-1

Solve[A==B,x]

Exercise 4: Simple Plotting

f1[k_,x_]:=Sin[k x];

Plot[f1[1,x],{x,0,2π},Frame->True,ImageSize->200,Filling->Axis]

Plot[f1[k,x]/.k->{1,2},{x,0,2π},Frame->True,ImageSize->200,Filling->Axis]

Plot[{Sin[x],Cos[x]},{x,0,4π},Frame->True,ImageSize->200,Filling->Axis]

Exercise 5: Quadratic Equation & more

Part 1

EQ=a (x^2)+ b x + c == 0 (* The equation. Make sure all symbols are unused (blue!) *)

Solutions=Solve[EQ,x] (* This gives a list of solutions as replacement rules *)

EQ/.Solutions (* Check that the solution indeed satisfy EQ *)

%//Simplify

x1=x/.First[Solutions]

x2 = x/.Last[Solutions]

EQ/.x->x1//Simplify

EQ/.x->x2//Simplify

Part 2

EQ3=(Subscript[a, 3]) (x^3)+(Subscript[a, 2]) (x^2)+ (Subscript[a, 1]) x + (Subscript[a, 0]) == 0;

Solve[EQ3,x]//Simplify

EQ4=(Subscript[a, 4]) (x^4)+(Subscript[a, 3]) (x^3)+(Subscript[a, 2]) (x^2)+ (Subscript[a, 1]) x + (Subscript[a, 0]) == 0;

Reduce[EQ4,x]//Simplify

Part 3

Table[1+(x^n),{n,1,10}]

%//Factor

Part 4

RandomReal[{-1,1}]

MyPolynom=Sum[RandomReal[{-1,1}](x^n),{n,0,5}]

Plot[MyPolynom,{x,-5,5},ImageSize->300,Frame->True,PlotRange->{-5,5}]

NSolve[MyPolynom==0,x]

NSolve[{MyPolynom==0&&x∈Reals},x]

(* For fun: Plot a few more polynoms *)
SEVERAL=Table[Sum[RandomReal[{-1,1}](x^n),{n,0,5}],{i,1,4}];
Plot[SEVERAL,{x,-5,5},ImageSize->300,Frame->True,PlotRange->{{-3,3},{-5,5}},PlotStyle->Thick]

Exercise 6: Maximizing the Area of a Rectangle

Clear[a,b,AArea,Periphery,asol,amax,bmax]; (* Make sure these are not used *)

Solve[Periphery == 2 a + 2 b,a] //First(* get side a for a given b and Periphery *)

asol = a/.% (* keep the expression for later *)

AArea=a b /.a->asol (* express the area as a function of b and Periphery *)

sol=Maximize[AArea,b] (* find b for maximal area *)

bmax = b/.(%//Last) (* remember the solution for b *)

amax = asol/.b->bmax (* get the solution for a *)

amax == bmax (* check that it is a square *)

TEST=Periphery->40;

Plot[AArea/.TEST,{b,0,20},Frame->True,Filling->Axis,GridLines->{{bmax/.TEST},{}}]

Exercise 7: Area of a Circle

Clear[x,y,r,sol];

EQ=(x^2)+(y^2)==(r^2);

y[r_,x_]=y/.Solve[EQ,y]//Last

Plot[y[1,x],{x,-1.0,1.0},PlotRange->{0,1},AspectRatio->1/2,Filling->Axis,Frame->True]

$Assumptions=True;

Integrate[y[r,x],{x,-r,r}] (* this takes very long on my computer *)

$Assumptions=r>0; (* Things get simpler with positive r: *)

Integrate[y[r,x],{x,-r,r}]

Indefinite Integral

sol=Integrate[y[r,x],x] (* general solution *)

sol/.x->0

Plot[sol/.r->1,{x,-1,1},Frame->True,Filling->Axis]

sol/.x->r

Limit[sol,x->r] (* oups, this gives the wrong sign! *)

Limit[sol,x->r,Direction->1] (* we must come from the left! *)

Exercise 8: More Plotting

First Part

SetOptions[Plot,{Frame->True,Filling->Axis}];

$Assumptions={a>0,λ>0};

f[x_]=Sin[a x]Exp[-λ x];

Reduce[f[1]==0,a]//Simplify  (* Find a such that have a zero at x=1 *)

%/.C[1]->0 //Simplify (* pick some constant, solution a=0 excluded by $Assumptions *)

Simplify[(f[k]/.a->π)==0,k∈Integers](* Check that with a->π, all integer x positions are zeros *)

Plot[f[x]/.a->π/.λ->{0,0.5,1},{x,0,10}]

Saw Tooth

g[x_,k_]=((((-1))^k)/k)Sin[k x];

Plot1=Plot[Table[g[x,k],{k,1,4}],{x,-π,3π},ImageSize->400]

f[x_,k_]:=Sum[g[x,j],{j,1,k}];

Plot2=Plot[f[x,5],{x,-π,π},ImageSize->400]

Reverse: Find the Coefficients:

Integrate[-((x )/π)Sin[k x],{x,0,π}]

Simplify[%,k∈Integers]

Exercise 9: Drawig a Weel

Origin={0,0};

wheel=Table[Line[{Origin,{Cos[2 π phi],Sin[2 π phi]}}],{phi,0,1,1/11}];

Show[Graphics[{Thick,Blue,wheel,Circle[Origin,1]}],Frame->True,ImageSize->300]

Exercise 10: Minimal Interconnect Distance of 4 Points, including Manipulate

The corners are at (0,0), (1,0), ... (1,1)

Clear[x,y,l,p0,p1,p2,p3]

We assume that we have a ‘H’ shape which is symmetric. Then there is only one free parameter, the distance of the center point at position x (from the left) and 1-x

l[x_]=(1-2x)+4(Sqrt[((((1/2)))^2)+(x^2)]);(* central part + 4 time the arms *)

{l[(1/2)]==2(Sqrt[2]),l[0]==3} (* Check tow obvious values *)

Minimize[l[x],x]

xmin=x/.Last[%];

xmin//N

Plot[l[x],{x,0,1/2},PlotRange->{2.5,3},Frame->True]

Show[Plot[Evaluate[l[x]],{x,0,1/2},PlotRange->{2.5,3},Frame->True],Graphics[{PointSize[Large],Point[{x,l[x]}]/.x->xmin}]] (* Add a point to where the minimum is *)

angle=2 ArcTan[((1/2)/x)/.x->xmin](360/(2π))(* Show that all angles are equal *)

Do some nice Plotting

p0={0,0};p1={1,0};p2={1,1};p3={0,1};corners=Point[{p0,p1,p2,p3}];(* corner points *)

xl={x,1/2};xr={1-x,1/2}; (* left and right point *)

mygraphic[x_]=Graphics[{
PointSize[Large],
corners,
Line[{p0,xl,p3}],Line[{xl,xr}],Line[{p1,xr,p2}],
Red,
Point[{xl,xr}]}
];

Show[mygraphic[0.1],ImageSize->100] (* See if it works *)

Manipulate[
Show[mygraphic[a],Frame->True,ImageSize->200,PlotRange->{{-0.1,1.1},{-0.1,1.1}}],
{{a,1/4,"dist"},0,(1/2),Appearance->"Labeled"}
]

Manipulate[
Show[
GraphicsRow[
{
mygraphic[a],
Show[{Plot[Evaluate[l[x]],{x,0,1/2},PlotRange->{{0,0.5},{2.5,3}}],Graphics[{PointSize[Large],Red,Point[{x,l[x]}]/.x->a}]}]
}
,ImageSize->500
](* end GraphicsRow *)
] (* end Show *)
,{{a,1/4,"dist"},0,(1/2),Appearance->"Labeled"}
]

Exercise 11: Car lifter

SetOptions[Plot,{AspectRatio->1/GoldenRatio,Frame->True,Filling->Axis}];

Solve[((((h/2)))^2)+((((x/2)))^2)==(l^2),h] (* One edge, half x and half h for a triangle with 90 degrees at the center *)

h[x_]=h/.Last[%]

Plot[h[x]/.l->1,{x,0,2}](* Plot & Check: For x=0, h = 2l, for x=2l, h=0 *)

-h'[x]

Plot[-1/h'[x]/.l->1,{x,0,2},PlotRange->{0,100}]
(* h-force * h-distance = constant = x-force * x-dist = const * x 
-> hforce = const * dx / dh
*)

Make a Graphics of this...

{P1,P2,P3,P4,Pmax}={{0,0},{(x/2),((h[x])/2)},{-(x/2),((h[x])/2)},{0,h[x]},{0,h[0]}}/.l->1; (* corner points *)

G=Graphics[{
Thick
,Line[{P1,P2}],Line[{P2,P4}],Line[{P4,P3}],Line[{P1,P3}] (* four outer lines *)
,Red,Line[{P2,P3}] (* center line *)
(*,Point[Pmax]*) (* top point *) 
},ImageSize->200];

Manipulate[
Show[G/.x->a,PlotRange->{{-1.5,1},{0,2}}],{{a,1,"x"},0,2,Appearance->"Labeled"}
]

Exercise 12: Equal Lengths

Clear[x,y,x1,y1,p1,px,K]; (* for safety *)

$Assumptions=x>0&&y>0&&x1>0&&y1>0&&K>0;

p1={x1,y1}; (* this point is given *)
px={x,y}; (* unknown point: the kink is here *)

L0=Norm[px];//Simplify (* distance from origin to unknown (kink) point *)
L1=Norm[p1-px];//Simplify (* distance from unkown point to given point *)

Solve[L0==L1&&2L0==K,{x,y}]//Last//FullSimplify (* equal lengths && sum == K *)

pp[x1_,y1_,K_]={x,y}/.%

Manipulate[
Graphics[Line[{{0,0},pp[First[pt],Last[pt],3],pt}],PlotRange->2,ImageSize->200]
,{{pt,{0,1}},Locator}
]