Midterm test 1(13 Oct. 2014)

Write clean, short, dense, general programs. Provide multiple solutions if possible.

1. Draw a house much nicer than the one attached using graphical primitives and directives. Show the two houses in a row.

GraphicsRow[{Graphics[{Red,Polygon[{{-2,0},{0,1},{2,0}}],
Pink, Polygon[{{0,1},{2,0},{6,1},{4,2}}],
Green,Rectangle[{-2,-4},{2,0}], 
Yellow, Rectangle[{-.5,-4},{.5,-2}],
Brown,Polygon[{{2,0},{6,1},{6,-3},{2,-4}}],
Green,Polygon[{{2.5,-.75},{3.5,-.5},{3.5,-2},{2.5,-2.25}}],
Green,Polygon[{{4.5,-.25},{5.5,0},{5.5,-1.5},{4.5,-1.75}}]
}],Import["house.jpg"]}]

Manipulate[Graphics[Table[{EdgeForm[Thick],Red,Opacity[0.5],Rectangle[{0,0},{1,1}],Rectangle[{0.4,0},{0.6,0.5}],Polygon[{{1,1},{2,1.5},{2,0.5},{1,0}}],Polygon[{{1.5,1},{1.7,1.1},{1.7,0.9},{1.5,0.8}}],Polygon[{{1.1,0.8},{1.3,0.9},{1.3,0.7},{1.1,0.6}}],Polygon[{{0,1},{0.5,1.4},{1,1}}],Polygon[{{0.5,1.4},{1.5,1.8},{2,1.5},{1,1}}],

Rectangle[{0+m,0},{1+m,1}],Rectangle[{0.4+m,0},{0.6+m,0.5}],Polygon[{{1+m,1},{2+m,1.5},{2+m,0.5},{1+m,0}}],Polygon[{{1.5+m,1},{1.7+m,1.1},{1.7+m,0.9},{1.5+m,0.8}}],Polygon[{{1.1+m,0.8},{1.3+m,0.9},{1.3+m,0.7},{1.1+m,0.6}}],Polygon[{{0+m,1},{0.5+m,1.4},{1+m,1}}],Polygon[{{0.5+m,1.4},{1.5+m,1.8},{2+m,1.5},{1+m,1}}]
},{1}]],"How far away from your neighbor would you like to live? Define a distance in meter!",{m,0,10,1}]

2. How many three-element subsets have the set Range[1,Prime[9],2]?

Length[Subsets[Range[1,Prime[9],2],{3}]]

Binomial[Length[l=Range[1,Prime[9],2]],3]

First@Dimensions[Subsets[l, {3}]]

Generally

how[p_,k_]:=Length[Subsets[Range[1,Prime[p],2],{k}]]

how[9,3]

3. Calculate the divergence of the function (x,y,z)↦((x^2)y,(z/x),y-z tan(x+y)). What can you say about the domain of the function?

f[x_,y_,z_]:={(x^2)y,z/x,y-z Tan[x+y]}

Total@Diagonal@D[f[x,y,z],{{x,y,z}}]

Inner[D[#1,#2]&,f[x,y,z],{x,y,z},Plus]

Div[f[x,y,z],{x,y,z}]

FunctionDomain[f[x,y,z],{x,y,z}]

4. Calculate the first ten Fibonacci numbers using at least three methods.

fib1=Table[Fibonacci[n],{n,100}]

fib2=Fibonacci[x]/.x->Range[1,100,1]

ClearAll[x,y];fib3=Fibonacci[y,x]/.{x->1, y->Range[1,100,1]}

Check the two-variable function Fibonacci.

f[0]=0;f[1]=1;
f[x_]:=f[x]=f[x-1]+f[x-2]

fib4=f[2000]

fib5=Array[f,100]

fib6=LinearRecurrence[{1,1},{1,1},100]

fib7[y_]=Module[{x=0},NestList[x+(x=#)&,1,y-1]]/.y->100

x=1;y=5;fib8=NestList[x+(x=#)&,1,y-1]

nl=NestList[{{1,1},{1,0}}.#&,{0,1},5]

fnl=First/@nl

fib9=Rest@fnl

fib10=Union@Flatten[nl]

fib11=RSolve[{a[n]==a[n-1]+a[n-2],a[0]==1,a[1]==1},a[n],n]

ClearAll[x,n];fib12=SeriesCoefficient[(x/(1-x-(x^2))),{x,0,n}]

ClearAll[x,n];fib120=SeriesCoefficient[(1/(1-x-(x^2))),{x,0,n}]

How to simplify so as to show that these are positive integers?

F[str_]:=StringReplace[str,{"a"->"b","b"->"ab"}]
NestList[F,"a",10];
StringLength/@%

Module[{LIST:={},i:=1},While[i<11,AppendTo[LIST,Fibonacci[i]];i++];"Fibonacci"->LIST]

fib99[n_]:=Module[{i=0, lista={0,1}},While[i< n-2, {lista, i}={Append[lista,lista[[-1]]+lista[[-2]]], i=i+1}]; lista]

fib99[10]

By using FoldList:

x=0;
FoldList[x+(x=#)&,1,Range[1,10]]

By using a Do cycle:

i1=0;
i2=1;
F={};
Do[AppendTo[F,is=i1+i2];
i1=i2;
i2=is,{10}]
F

f[n_]:= (∑_(k=0)^((n-1)/2))Binomial[n-k-1,k]

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

Fibonacci/@Range[10]

Try to understand most of these solutions.

Table[Fibonacci[n],{n,10}] (* First Method*)

fib1[n_]:=Block[{res},If[n<2,res=n,res=fib1[n-1]+fib1[n-2]];Return[res]];
ListOfFib1={};
For[i=1,i≤10,i++,ListOfFib1=AppendTo[ListOfFib1,fib1[i]]] ; (* Second Method*)

fib2[n_]:=Block[{jj},
ii=1;
jj=0;
k=0;
t=0;
For[k=1,k≤n,k++,
t=ii+jj;
ii=jj;
jj=t;
];
Return[jj]
]
ListOfFib2={};
For[i=1,i≤10,i++,ListOfFib2=AppendTo[ListOfFib2,fib2[i]]] ; (* Third Method*)
Print[ListOfFib1]

fib2 = Table[(((GoldenRatio^n)-Cos[π n] (GoldenRatio^(-n)))/(Sqrt[5.])),{n,1,10}]

Fib2=Nest[Append[#, #[[Length[#]]]+#[[Length[#]-1]]]&, {1, 1}, 8]

5. Contruct a list of the off-diagonal elements of the matrix (({{-c-e, a, b}, {c, -a-f, d}, {e, f, -b-d}})).

ClearAll[A,a,b,c,d,e,f];A=(({{-c-e, a, b}, {c, -a-f, d}, {e, f, -b-d}}));Diagonal[A]

Complement[Flatten[A],Diagonal[A]]

off[aa_]:=Complement[Flatten[aa],Diagonal[aa]]

n=3;Table[A[[i,n+1-i]],{i,1,n}]

M={{-c-e, a, b},{c, -a-f, d},{e,f,-b-d}};

Complement[Apply[Join,M-DiagonalMatrix[Diagonal[M]]],{0}]

MatrixAA={{-c-e,a,b},{c,-a-f,d},{e,f,-b-d}};
ListOfOffDiagonal={};
For[i=1,i≤3,i++,
For[j=1,j≤3,j++,
If[i≠j,ListOfOffDiadonal=AppendTo[ListOfOffDiagonal,MatrixAA[[i,j]]]]
]
]
Print[ListOfOffDiagonal]

6. Calculate the volume of the unit sphere exactly and approximately.

2Integrate[(Sqrt[1-(x^2)-(y^2)]),{x,0,1},{y,0,(Sqrt[1-(x^2)])}]

Integrate[1*r,{phi,0,2*Pi},{r,0,1},{z,-(1-r^2)^(1/2),(1-r^2)^(1/2)}]

Integrate[Boole[x^2+y^2+z^2≤1],{x,-1,1},{y,-1,1}, {z, -1, 1}]

Integrate[r^2 Sin[θ],{r,0,1},{θ, 0, π},{ϕ, 0, 2 π}]

NIntegrate[Boole[x^2+y^2+z^2≤1],{x,-1,1},{y,-1,1}, {z, -1, 1}]

RegionMeasure[Ball[]]

Volume[Ball[]]

r=1;
Pi*Integrate[r^2-x^2,{x,-r,r}];
N[%]

a=0;
b=1;
suruseg=10;
lepes=b/suruseg;
VVolume[x_]:=2*Pi*(1-x^2);
terfogat=0;
For[i=1,i<(b/lepes+lepes),i++,terfogat=terfogat+lepes*(VVolume[a]+VVolume[a+lepes])/2;
a=a+lepes;]
N[terfogat]
terfogat=0;

Approximation with cylinder slices (adapted Wolfram demonstration project found online):

cylinderslice[center_,thick_]:=Module[{rad},rad=Sqrt[1-center^2];Cylinder[{{0,0,center-thick},{0,0,center+thick}},rad]]

Manipulate[Module[{thickn},thickn=1/slices;Graphics3D[{{Sphere[{0,0,0}]},Table[cylinderslice[i,thickn],{i,-1+thickn,1-thickn,2thickn}]}]],{slices,5,20,5}]

The volume of each slice can be expressed as V = 2*Pi^2 *h, summed up over all slices, an approximation of the volume of a sphere can be obtained .

Jacobian

J[r_,φ_]:=Outer[D,{r Sin[φ] Cos[θ],r Sin[φ] Sin[θ],r Cos[φ]},{r,φ,θ}]

r

ClearAll[r]

Integrate[1*Det[J[r,φ]],{r,0,1},{φ,0,π},{θ,0,2π}]

Manipulate[Total[2 Table[π ((((Sqrt[1-(zi^2)])))^2) (1/nstep),{zi,Range[1/nstep,1,1/nstep]}]]//N,{nstep,1,100,1}]

ListPlot[Table[{nstep,Total[2 Table[π ((((Sqrt[1-(zi^2)])))^2) (1/nstep),{zi,Range[1/nstep,1,1/nstep]}]]//N},{nstep,1,20,1}],AxesStyle->Arrowheads[0.04],AxesLabel->{"Number of substeps","(Subscript[V, sphere])"},Prolog->{Dashed,Thick,Line[{{0,4(π/3)},{20,4(π/3)}}]},PlotRange->All,AxesOrigin->{0,0}]

f[x_]:=(Sqrt[1-x^2])

Plot[f[x],{x,-1,1}]

sphere=Pi*(∫_(-1)^1)(f[x])^2\[DifferentialD]x

7. Solve the linear equation below by more than one methods.

(({{1, 2, -3}, {-4, 5, 6}, {-7, 8, 9}})).(({{x}, {y}, {z}}))=(({{-1}, {-2}, {-5}}))

ClearAll[A,b];A=(({{1, 2, -3}, {-4, 5, 6}, {-7, 8, 9}}));b=(({{-1}, {-2}, {-5}}));

(A^(-1)).b does not give the solution.

(A^(-1)).b

Inverse[A].b

Solve[A.(({{x}, {y}, {z}}))==b,{x,y,z}]

A.(({{x}, {y}, {z}}))/.%

LinearSolve[A,b]

By using Gauss elimination:

Ps=Table[Append[P[[i]],s[[i]]],{i,1,3}]

sol=RowReduce[Ps]

Table[sol[[i,4]],{i,1,3}]

Det[A]

.b

3rd method, numerical solution using Newton-Raphson iteration (with damping)

f[{x_,y_,z_}]:=MX7.{x,y,z}-l7

Jacobif=Outer[D,f[x,y,z],{x,y,z}]

Outer[D,f[x,y,z],{x,y,z}]==MX7

α=0.2;
TableForm[NestList[α#+(1-α)(#-Inverse[Jacobif].f[#])&,{500,250,320},15],TableHeadings->{Range[16],{"x","y","z"}}]

All the problems are five points worth, you have to earn 10 points, 25 is considered to be 100 %.

Homeworks

1. Solve the logistic equation symbolically and numerically, and make different useful figures about it.

2. The same for a 2D equation (Lotka-Volterra, Brusselator etc.) or a second order equation (harmonic oscillator, pendulum unapproximated etc.)

3. Study the functions *Image* and show a picture using Manipulate in such a way that a larger and large part becomes visible.

4. Given a list like this:

l={a,d,s,f,d,a,s,a,d,f,d,f,g,d,a,f,g}

how would you calculate the mnumber of occurances of all the elements in the list?

5. How do you calculate div, grad, curl (rot), Hessian, Jacobian with and without using the built-in functions?

6. What does the function

power[x_,n_,base_]:=Fold[(((#1)^2)#2)&,1,(x^(IntegerDigits[n,base]))]

calculate when base=2? What happens when base=3?

7. Write a function  which applies a list of functions to a list of arguments in all possible ways.