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 *)

Sqrt[-4]

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

F1+F2

F1*F2

Sqrt[F1]

((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 *)

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

1-(((Sqrt[2 π n])((((n/E)))^n))/(n!))/.n->{5,10,50,100}//N (* more general, replacing n by a fixed value, see later *)

Exercise 2: Lists and Expressions

Exercise 2A:

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

G=F//Expand

G//Factor

G/A(* When F is expanded, the fraction cannot be simplified so easily *)

G/A //Simplify

Exercise 2B: Large Matrix

A=Table[Table[RandomInteger[10],10],10];

A//MatrixForm

B=Inverse[A];B//MatrixForm

A.B//MatrixForm

Exercise 2C: ‘Nearly an Integer’

DecimalForm@N[(E^(π(Sqrt[50]))),50]

FractionalPart@% (* FractionalPart gives the digits after the comma *)

FractionalPart@N[Table[(E^(π(Sqrt[k]))),{k,50,60}],100] (* For k=58, the expression is very close to an integer *)

FractionalPart@N[Table[(E^(π(Sqrt[k]))),{k,160,170}],100] (* For k=163, the expression is very close to an integer *)

ListPlot[N[1-FractionalPart@Table[(E^(π(Sqrt[k]))),{k,0,200}],100] 
,PlotStyle->PointSize[Large],Frame->True,PlotRange->{-0.0001,0.0001}]

Select[N[1-FractionalPart@Table[(E^(π(Sqrt[k]))),{k,0,200}],100],#<0.00005&]

Exercise 3: Solving Equations

Am Tisch sitzen die 3 Freunde Andy, Bob, Conny
- Conny ist 2 Jahre älter als Andy
- Conny ist doppelt so alt wie Bob
- Zusammen sind sie 38 Jahre alt

Clear[A,B,C]; (* Expressions have been used before... *)

Solve[A+B+C==38&&2B==C&&C==A+2,{A,B,C}]//First (* unique solution *)

Solve[A+B+C==38&&2B==C&&C>A,{A,B,C}] (* With 'C>A' only a range *)

Reduce[A+B+C==38&&2B==C&&C>A,{A,B}] (* Reduce gives a 'nicer' result (but content is the same) *)

Reduce[A+B+C==38&&2B==C&&C>A&&A>0&&B>0&&C>0,{A,B}] (* Asking for positive ages restricts C even more *)

Exercise 4: Misc

Sum[(1/(i^2)),{i,1,∞}]

Approx=Sum[(1/(i^2)),{i,1,100}]

(Sqrt[6 Approx])//N

((%)/π)

Table[Sin[α],{α,0,π,(π/4)}]

Table[i,{i,1,10}]

L=Range[10] (* This is the same. Quite useful *)

CalculateSquare[x_]:=(x^2);

L//CalculateSquare (* Postfix *)

CalculateSquare[L] (* Call function an 'thread' though list *)

CalculateSquare @ L (* Prefix, 'threading' automatically *)

CalculateSquare /@ L (* Prefix, explicit Map[] *)

((#)^2)& @ L (* Using pure function '((#)^2)&' *)

Range[10]

# # & /@ % (* Very cryptic *)

Exercise 5: Botema’s Theorem

Manipulate[Module[{p1,p2,m},p1=EuclideanDistance[ptA,ptB] Normalize[(RotationTransform[(π/2),{0,0}][ptB-ptA])]+ptA;p2=EuclideanDistance[ptB,ptC] Normalize[(RotationTransform[-(π/2),{0,0}][ptB-ptC])]+ptC;m=Mean[{p1,p2}];Graphics[{Thickness[0.015],ColorData["HTML","OrangeRed"],Line[{ptA,ptB,ptC,ptA}],PointSize[0.035],ColorData["HTML","SlateBlue"],ConstructSquare[ptA,ptB],ConstructSquare[ptB,ptC],ColorData["HTML","Green"],Point[{p1,p2,m}],Line[{p1,p2}],Black,Text[Style["A","Label",20],ptA+{0,.35}],Text[Style["B","Label",20],ptB+{0,.35}],Text[Style["C","Label",20],ptC+{0,.35}],Text[Style["R","Label",20],p1+{0,.35}],Text[Style["M","Label",20],m+{0,.35}],Text[Style["S","Label",20],p2+{0,.35}]},ImageSize->{450,400},PlotRange->{{-6,6},{-6,6}}]],
{{ptA,{-1.3,-2}},{-4,-4},{4,4},Locator},
{{ptB,{0.425,0.38}},{-4,-4},{4,4},Locator},
{{ptC,{1.3,-2}},{-4,-4},{4,4},Locator},Initialization:>(ConstructSquare[p1_,p2_]:=Module[{a=EuclideanDistance[p1,p2] Normalize[(RotationTransform[(π/2),{0,0}][p2-p1])]+p1,b=EuclideanDistance[p1,p2] Normalize[(RotationTransform[-(π/2),{0,0}][p1-p2])]+p2},{Line[{p1,a}],Line[{p2,b}],Line[{a,b}]}]),AutorunSequencing->2]

Cross[{1,0,0},{0,0,1}](* Test Crosss Procuct *)

PA={ax,ay,0};PB={bx,by,0};PC={cx,cy,0}; (* define 3 Points *)

PR=PA+Cross[{0,0,1},PB-PA]

PS=PC+Cross[PB-PC,{0,0,1}]

((PR+PS)/2) (* Result is independent of bx and by!! *)

%/.{ax->0,ay->0,cx->1,cy->0}

Exercise 6: Simple Plotting

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

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

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

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

Exercise 7: Solving Equations

f1[x_]:=3x+2;f2[x_]=2(((x-2))^2);

Plot[{f1[x],f2[x]},{x,0,6},Frame->True]

Sol=Solve[f1[x]==f2[x],x]

pp={x,f1[x]}/.Sol (* we get a list of two points from the two solutions *)

pp//N (* Check the points *)

Plot[{f1[x],f2[x]},{x,0,5},Frame->True,Epilog->{Red,PointSize[0.03],Point[pp]},ImageSize->300]

f1[x_]:=x+4;
f2[x_]:=3(x^3)-2(x^2)-x+5;

Plot[{f1[x],f2[x]},{x,-2,2},Frame->True,ImageSize->300,PlotRange->{0,10}]

Sol=Solve[f1[x]==f2[x],x]//Simplify

%//N

f1[x_]:=x+4;
f2[x_]:=2(x^3)-2(x^2)-x+5; (* Strange: With this similar function, Mathematica gets problems... *)

Plot[{f1[x],f2[x]},{x,-2,2},Frame->True,ImageSize->300,PlotRange->{0,10}]

Sol=Solve[f1[x]==f2[x],x]//FullSimplify (* The solutions are expressed as general 'Roots' *)

pp={x,f1[x]}/.Sol

Plot[{f1[x],f2[x]},{x,-2,2},Frame->True,Epilog->{PointSize[0.03],Point[pp]},ImageSize->300,PlotRange->{0,10}]

Exercise 8: Real World Problem: Chip

myCond={S->3,ϵ->(10^(-5))};

Apixel=(W^2);Adiode=(((W-2S))^2);

Npix=(A/Apixel);

pbad=Adiode ϵ;

Aactive=Npix(1-pbad)Adiode;

ff=(Aactive/A)//Simplify

{1==ff/.{ϵ->0,S->0},0==ff/.{W->2S}}(* check some trivial cases *)

ffnum=ff/.myCond;

Plot[ffnum,{W,-200,200},PlotRange->{0,10}] (* The overall function is quite complicated *)

Plot[ffnum,{W,2S/.myCond,200},PlotRange->{-0.1,1}] (* This is the televant Part ! *)

NMaximize[{ffnum,W>6},W]//N

D[ffnum,W]//Simplify (* let us try to find the maximum 'by hand' with the derivative *)

NSolve[%==0,W] (* we get 4 solutions! The function is quite complex... *)

Exercise 9: 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] (* Numerically, this is no problem *)

NSolve[{MyPolynom==0&&x∈Reals},x] (* Only real solutions *)

(* 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 10: 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 11: A real world problem

A silicon wafer of 200mm diameter contains two types of microchips: Chips ‘A’ with a size of 5x5 (mm^2) and Chips ‘B’ with 3x3 (mm^2). The relative amount of chips can be chosen by you. Let us assume that chips ‘A’ cover an area fraction α of the wafer (0<=α<=1).
The vendor produces (Subscript[N, wafer])=12 wafers . This ‘batch’ is split in two flavors:  A fraction β  (i.e. β  (Subscript[N, wafer]) wafers) is produced such that chips ‘A’ can be used, the remaining wafer are for Chips ‘B’.
You need 10000 chips ‘A’, not more.
How do you chose α and β so that you get as many chips ‘B’ as possible?

Clear[NumberofWafers,Wafersize,LostFraction,ChipArea];

PARAMETERS={
NumberOfWafers->12,
WaferArea->π ((((200/2)))^2),
ChipAArea->3 3,
ChipBArea->5 5,
NChipA->10000
}; (* define a replacement rule to later exchange variables by values *)

$Assumptions=WaferArea>0&&NChipA>0&&NumberOfWafers>0&&ChipAArea>0&&ChipBArea>0;

NA=β NumberOfWafers ((α WaferArea)/ChipAArea);
NB=(1-β) NumberOfWafers (((1-α) WaferArea)/ChipBArea);

{NA,NB}/.PARAMETERS

Plot3D[{NA,NB,10000}/.PARAMETERS,{α,0,1},{β,0,1},PlotRange->{0,12000}]

βsol=Solve[NA==NChipA,β]//First (* This β guarantees NChipA chips for all cases *)

Plot[NB/.βsol/.NChipA->{5000,10000}/.PARAMETERS, (* This is the number of Chips 'B' for the β which guarantees the correct number of chips 'A' *)
{α,0,1},Frame->True,PlotRange->{0,8000},Filling->Axis]

D[NB/.βsol,α]//Simplify (* Get the derivative of the above function *)

Solve[%==0,α] (* find the α which maximizes it *)

αmax=α/.Last[%] (* assign the positive solution *)

βmax=β/.βsol/.α->αmax (* and get the corresponding β. Surprisingly, it's the same as αmax *)

αmax/.PARAMETERS//N (* get the numerical value for our particular parameter set *)

{NA,NB}/.α->αmax/.β->βmax//Simplify (* and get the number of chips in general *)

%/.PARAMETERS//N (* and the numerical value, our result *)

Exercise 12: Integral

f[x_]=(A/(1+(x^2)))

Plot[f[x]/.A->1,{x,-3,3}]

AI=Integrate[f[z],{z,-∞,∞}]

Solve[AI==1,A]

Anorm=A/.First[%]

Stamm[x_]=Integrate[f[z],{z,-∞,x}]

Plot[{f[x],Stamm[x]}/.A->Anorm,{x,-3,3}]

More General:

f[x_]=(A/(1+α (x^2)))

Integrate[f[z],{z,-∞,∞}]

Simplify[%==1,α>0]

Solve[%,A]

f[x_]=f[x]/.First[%]

Plot[Evaluate@(f[x]/.α->{0.2,1,5}),{x,-3,3},PlotRange->{0,0.7}]

Exercise 13: 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; (* No information about r. Could be a complex n umber *)

Integrate[y[r,x],{x,-r,r}] (* this takes very long on my computer, but finally gives the correct result *)

$Assumptions=r>0; (* Tell Mathematica that r is positive (and thus real) *)

Integrate[y[r,x],{x,-r,r}] (* much faster now *)

Indefinite Integral

sol=Integrate[y[r,x],x] (* general solution. This is very quick! *)

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

sol/.x->r

Limit[sol,x->r] (* oups, this does not work *)

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

Exercise 14: 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[Evaluate[f[x]/.a->π/.λ->{0,0.5,1}],{x,0,10},Filling->None]

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]

Manipulate[ (* See later for 'Manipulate' *)
Plot[f[x,k],{x,-π,π},ImageSize->400,PlotRange->{-2,2}]
,{{k,1},1,15,1}]

Reverse: Find the Fourier Coefficients for the saw tooth function ‘-x’:

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

Simplify[%,k∈Integers]

Exercise 15: 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 16: 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->{0,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->200] (* 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[ (* The same with the previous plot *)
Show[
GraphicsRow[
{
mygraphic[a]
,Show[{Plot[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"}
]