Név: Anonymous

1. dolgozat
Számítógéppel segített matematikai modellezés
 "J"  változat
2012. november 12, kedd

Oldd meg a következő feladatokat. Készíts szép notebook-ot, figyelj a korrekt strukturált megoldásokra, válaszolj a kérdésekre.

1. feladat (15 pont)

a) Készítsd el az alábbi táblázat elsô 20 sorát! 

a j-edik sorban a j-edik természetes szám áll, utána a j-edik “hatos/szexi prímtrió” áll, azaz olyan rendezett hármas, melyre (p és p+6, p+12 prím, de p+18 összetett), a 2. sor:

({{2, 17  23  29}})

SexyQ[p_]:=PrimeQ[p+6]∧PrimeQ[p+12]∧¬PrimeQ[p+18]

ST=Select[Table[Prime[n],{n,160}],SexyQ]

Length[%]

TableForm[Table[{Style[n,Red],ST[[n]],ST[[n]]+6,ST[[n]]+12},{n,20}]]

b) Adj meg  a k-tökéletes számokat 100000-ig (1≤k≤5), azaz olyan n természetes számokat generálj, melyre  ((σ(n) = k*n) ∧ (n<10^5), σ-osztók összege). Találsz-e 4-, ill. 5-perfekt számot? Ha igen, add meg az osztóik öszegét is!

Table[Select[Table[j,{j,(10^5)}],Plus@@Divisors[#]==k#&],{k,5}]

2  4-perfekt szám van 10^5-ig, nincs 5-perfekt.

DivisorSigma[1,30240]

DivisorSigma[1,32760]

c) Add meg az f(x)=arctg(x) fgv.  nulla körüli, k-adik (Subscript[T, k])(x)Taylor polinomjait (0≤k≤10) . Adj ez alapján képletet (Subscript[T, n])(x)-re! (n∈ℕ) Ábrázold a polinomokat a [-2,2] intervallumon egy ábrán f-fel!

T=Table[Normal[Series[ArcTan[x],{x,0,k}]],{k,0,10}]

TableForm[T]

Plot[Evaluate[Join[{ArcTan[x]},T]],{x,-2,2},PlotStyle->Join[{{Red}},Table[{Black},{11}]]]

Képlet: (Subscript[T, 2n+1])(x)=((∑_(k=0)^n)(((-1))^k)(x^(2k+1))/(2k+1))

2. feladat (10 pont)

Ábrázold a

g(x)=x (ln^2)|x|

függvényt a [-10,10] intervallumon. Mi az értelmezési tartomány?
Add meg  -∞-ben a limeszt!
 
 Add meg a lokális  szélsôértékeket, színezz (új ábrán) az elsô derivált elôjele szerint!
 Ábrázold együtt g és a g’ függvényeket is. 
 Hogyan kell az elsô ábrát módosítani, hogy lokális szélsôértékek vizuálisan is szemléltethetôk legyenek?
 Jelöld a lokális minimumokat il. maximumokat az ábrán is.
 
 Add meg a limeszeket a további kritikus pontokban.

g[x_]=x Log[Abs[x]]^2

Plot[g[x],{x,-10,10}]

ET=ℝ\{0}

Limit[g[x],x->-∞]

Solve[D[g[x],x]==0,x]

Reduce[D[g[x],x]==0,x,Reals]

g2[x_]:=Piecewise[{{0,x==0},{x Log[x]^2,x>0},{x Log[-x]^2,True}}]

x/.Solve[D[g2[x],x]==0,x]

lelist=x/.Solve[D[g2[x],x]==0,x]

Plot[g2[x],{x,-2,2},ColorFunction->(If[(Evaluate[D[g2[x],x]]/.x->#1)>0,Red,Blue]&),ColorFunctionScaling->False,Epilog->{PointSize[.02],Green,Map[Point[{#,g2[#]}]&,lelist]}]

Plot[Evaluate[{g2[x],D[g2[x],x]}],{x,-2,2},ColorFunction->(If[(Evaluate[D[g2[x],x]]/.x->#1)>0,Red,Blue]&),ColorFunctionScaling->False,Epilog->{PointSize[.02],Green,Map[Point[{#,g2[#]}]&,lelist]}]

Limit[g[x],x->0,Direction->1]

Limit[g[x],x->0,Direction->-1]

3. feladat (15 pont)

A numerikus matematikában az (Subscript[l, j])(x)=(∏_(k=1,k≠j)^n)(x-(Subscript[x, k]))/((Subscript[x, j])-(Subscript[x, k])) polinomot az XL = {(Subscript[x, 1]),(Subscript[x, 2]) ..., (Subscript[x, n])} alappontrendszerhez (elemek pár. kül.) tartozó j-edik interpolációs alappolinomnak nevezik.

a) Add meg azt a függvényt, aminek bemenô paramétere az XL lista és a j index és elôállítja (Subscript[l, j])-t.
b) Add meg az  (Subscript[l, 1]),(Subscript[l, 2]),(Subscript[l, 3]) polinomot, ha XL={1, 2, 3}.
c) Add meg a 2(Subscript[l, 1])+5(Subscript[l, 2])+10(Subscript[l, 3]) polinomot és mutasd meg, hogy grafikonja áthalad a {1, 2}, {2, 5}, {3, 10} pontokon!

Készíts interaktív ábrát, melyben 2 csúszka segítségével ábrázolod az   2(Subscript[l, 1])-(Subscript[l, 2])+2(Subscript[l, 3]) függvénycsaládot, ahol XL={x1,x2=0, x3} x1≠x3, x1,x3∈[-1,1])

Tippek: Sum, Product, Manipulate

BaseInt[j_,XL_List]:=Product[(x-XL[[k]])/(XL[[j]]-XL[[k]]),{k,1,j-1}] Product[(x-XL[[k]])/(XL[[j]]-XL[[k]]),{k,j+1,Length[XL]}]

BaseInt[1,{1,2,3}]

Table[BaseInt[j,{1,2,3}],{j,3}]

LI=2*BaseInt[1,{1,2,3}]+5*BaseInt[2,{1,2,3}]+10*BaseInt[3,{1,2,3}]

Plot[LI,{x,0,4},Epilog->{Red,PointSize[.02],Point[{{1,2},{2,5},{3,10}}]}]

Manipulate[Plot[2*BaseInt[1,{x1,0,x3}]-BaseInt[2,{x1,0,x3}]+2*BaseInt[3,{x1,0,x3}],{x,-1,1},PlotRange->{{-1.1,1.1},{-6,6}}],{{x1,-1},-1,1,.1},{{x3,1},-1,1}]

Manipulate[Plot[2*BaseInt[1,{x1,0,x3}]-BaseInt[2,{x1,0,x3}]+2*BaseInt[3,{x1,0,x3}],{x,-1,1},PlotRange->{{-1.1,1.1},{-6,6}},Epilog->{Red,PointSize[.02],Point[{{x1,2},{0,-1},{x3,2}}]}],{{x1,-1},-1,1,.1},{{x3,1},-1,1}]

4. feladat (15 pont)

Egy szabályos pénzérmét dobálunk.  Addig dobáljuk, míg fej nem lesz. Legyen a valószínûségi változónk a dobások száma (1,2,3,...) . Mi  a valószínûsége, hogy páros sok dobás után ér véget a dobássorozat?
Készíts kísérletet, melyben a relatív gyakorisággal közelíted a valószínûséget. Végezz 10^3 kísérletet. Vesd össze az értéket a teoretikus valószínûséggel!

*Ha marad idôd, cseréld az érmét (szabályos) kockára és addig dobj, míg 6-ost nem kapsz. Tedd fel ugyanazokat a kérdéseket és végezz ugyanolyan szimulációt, mint az érme esetén!

Tipp: Random[Integer,{0,1}]

Random[Integer,{0,1}]

M=1000;

Fej->0
Írás->1

CoinThCounter[s_Integer]:=If[Random[Integer,{0,1}]==0,s,CoinThCounter[s+1]]

Take[Table[CoinThCounter[1],{M}],10]

TT=Table[Mod[CoinThCounter[1]+1,2],{M}];

N[Plus@@TT/M]

1-%

Válasz: p=1/3 mivel geometriai eloszlásról van szó

p=1/2

Sum[p(((1-p))^(2k-1)),{k,1,∞}]

CoinThCounterExt[s_Integer,L_List]:=If[Random[Integer,{0,1}]==0,{s,Append[L,0]},CoinThCounterExt[s+1,Append[L,1]]]

TableForm[Table[CoinThCounterExt[1,{}],{10}]]

*kocka:

DiceThCounter[s_Integer]:=If[Random[Integer,{1,6}]==6,s,DiceThCounter[s+1]]

TTT=Table[Mod[DiceThCounter[1]+1,2],{(10^5)}];

N[Plus@@TTT/(10^5)]

p=1/6

Sum[p(((1-p))^(2k-1)),{k,1,∞}]

N[%]