Zadanie 1

Sposób 1 (wg. ChatGPT4 lub WolframGPT)

Fold[Sqrt[1+#1 #2]&,x,Range[2,12]//Reverse]

Fold[Sqrt[1+#1 #2]&,3.0`128,Range[2,112]//Reverse]

Plot[Fold[Sqrt[1+#1 #2]&,x,Range[2,12]//Reverse],{x,0,12},PlotRange->{0,All}]

Sposób 2 (generacja kodu)

num=13

(Table[" Sqrt[1+"<>ToString[k],{k,2,num}]//StringJoin)<>Table["]",num-1]

ToExpression[%]

N[%]

Sposób 3 (przepisać i obliczyć)

(Sqrt[1+2 (Sqrt[1+3 (Sqrt[1+4 (Sqrt[1+5 (Sqrt[1+6 (Sqrt[1+7 (Sqrt[1+8 (Sqrt[1+9 (Sqrt[1+10 (Sqrt[1+11 (Sqrt[1+12 (Sqrt[14])])])])])])])])])])])])//N

Zadanie 2

Sposób 1 (eliminacja kwantyfikatorów)

ForAll[x,λ x^6-(λ+7)x^2+λ!=0] (* Równanie nie ma rozwiązania dla wszystkich x *)

Resolve[%,Reals]

ToRadicals[%]

!Exists[x,λ x^6-(λ+7)x^2+λ==0] (* Równoważny zapis: nie istnieje x spełniające równanie, sprowadza sie do poprzedniego *)

Sposób 2 (Solve)

Solve[λ x^6-(λ+7)x^2+λ==0,x,Reals] (* Rozwiązanie *)

x/.% (* Wyciągnięcie x z rozwiązań *)

Last/@% (* Pobieramy ostatnie elementy, czyli same warunki istnienia *)

%/.List->Or (* Zamieniamy listę warunków List na ich alternatywę logiczną Or. Tu akurat wszystkie warunki są takie same, ale nie musi tak być.  *)

FullSimplify[Not[%]] (* Nas interesuje kiedy NIE MA rozwiązań, czyli wynik należy zaprzeczyć *)

LogicalExpand[%]

Zadanie 3

Sposób 1 (numerycznie)

zNUM=ArcCos[E^ArcTanh[2]]//N

ReIm[zNUM]

AbsArg[zNUM]

Sposób 2 (symbolicznie)

z=ArcCos[E^ArcTanh[2]]//TrigToExp (* Konwersja do postaci prostszej dla Mma *)

w=ComplexExpand[z] (* Sprowadzenie do postaci kanonicznej *)

N[%]

AbsArg[w]//FullSimplify

N[%]

ListPlot[
{ReIm[z]},PlotRange->2{{-1,1},{-1,1}},AspectRatio->1,
AxesLabel->{Re,Im},
Epilog->{
Arrow[{{0,0},ReIm[z]}],Text["z=(π/2)+I Log[2+(Sqrt[3])]",ReIm[z],{0.5,-1}],Circle[{0,0},{1,1},{0,Arg[z]}],
Text["Arg z", ReIm[Sqrt[z]/2]],
Rotate[Text["|z|",ReIm[z/2],{1,-1}],Arg[z]]

}]

Zadanie 4

ForAll[ϵ,ϵ>0,Exists[k,k>1,ForAll[n,n>3,Implies[n>2k, g-12ϵ-1<3/4/(n-2)-7/4/(n+2)<g+19ϵ-1]]]]

Resolve[%,Reals]

Zadanie 5

σ=Quantity[8,"kg/m^2"] (* Gęstość powierzchniowa *)

r=ImplicitRegion[Pi^2-y^2>Abs[x],{x,y}]

Region[r]

Integrate[1,{x,y}∈r]

Area[r]

S=Quantity[Area[r]//N,"m^2"]

m=σ S

Obwód

obwNum=Perimeter[r] (* Sposób 1 *)

CylindricalDecomposition[{x,y}∈r,{y,x}]

obwSym=2*ArcLength[{y,Pi^2-y^2},{y,-Pi,Pi}] (* Sposób 2 *)

{obwNum/obwSym,obwNum-obwSym} (* Sprawdzenie czy 2 metody liczenia obwodu daj ten sam wynik *)

Maksymalne/minimalne wartości x,y

Minimize[x,{x,y}∈r]

xMIN=%[[1]]

xMAX=Maximize[x,{x,y}∈r][[1]]

yMIN=Minimize[y,{x,y}∈r][[1]]

yMAX=Maximize[y,{x,y}∈r][[1]]

RegionPlot[{x,y}∈r,{x,xMIN,xMAX},{y,yMIN,yMAX}] (* Sprawdzenie graficzne MIN/MAX*)

Momenty bezwładności

I1=σ Quantity[Integrate[Norm[{0,yMAX}-{x,y}]^2,{x,y}∈r],"m^4"]//N (* Moment obrotowy wzg. czubka *)

I1 =σ  Quantity[Integrate[x^2+y^2,{x,y}∈r],"m^4"]+m Quantity[yMAX,"m"]^2 (* Jak wyżej, liczone z twierdzenia Steinera *)

I2=σ Quantity[Integrate[Abs[yMAX-y]^2,{x,y}∈r],"m^4"]//N (* Moment wachlujący  wzg. czubka *)

Obliczenie okresu drgań

RegionCentroid[r] (* Spr. czy na pewno środek ciężkości jest w punkcie {0,0}. Wynik jest ,,oczywisty'' z powodu symetrii figury geometrycznej. *)

d=Quantity[yMAX,"m"]//N

g=Quantity[1,"StandardAccelerationOfGravity"]

T1=2Pi Sqrt[I1/(m g d)]//UnitConvert

T2=2Pi Sqrt[I2/(m g d)]//UnitConvert

2Pi Sqrt[d/g]//UnitConvert (* Test ,,chłopskiego rozumu'' czyli okres wahadła matematycznego.  *)

Zadanie 6

Sposób 1 (rozpisanie na składowe)

a={ax,ay,az}

b={bx,by,bz}

c={cx,cy,cz}

d={dx,dy,dz}

lewaStrona=a.Cross[b,c]d//Simplify (* UWAGA: Simplify, Expand czy FullSimplify NIE SĄ równoważne, spróbuj sam *)

prawaStrona = a.d Cross[b,c]+ b.d Cross[c,a]+ c.d Cross[a,b]//Simplify (* UWAGA: Simplify, Expand czy FullSimplify NIE SĄ równoważne, spróbuj sam *)

lewaStrona-prawaStrona  (* Jeżeli lewa i prawa strona są równoważne, to po odjęciu musi wyjść ZERO *)

Simplify[%]

lewaStrona/prawaStrona  (* Jeżeli lewa i prawa strona są równoważne, to po podzieleniu musi wyjść 1 *)

Simplify[%]

lewaStrona==prawaStrona

Simplify[%]

lewaStrona===prawaStrona (* TYLKO jeżeli lewa i prawa strona są IDENTYCZNE, czyli zapisane w tej samej kolejności === daje True. *)

Sposób 2 (użycie TensorExpand, nie działa... )

Clear[a,b,c,d]

$Assumptions=a∈Vectors[3,Reals]&&b∈Vectors[3,Reals]&&c∈Vectors[3,Reals]&&d∈Vectors[3,Reals]

$Assumptions

a.Cross[b,c]d-a.d Cross[b,c]- b.d Cross[c,a]- c.d Cross[a,b]//TensorExpand (* Nie działa, zgłoszone do Wolframa jako BUG *)

Cross[a,Cross[b,c]]-b a.c + c a.b//TensorExpand

Cross[a,a]//TensorExpand

Cross[a,Cross[b,c]]+Cross[b,Cross[c,a]]+Cross[c,Cross[a,b]]//TensorExpand

Zadanie 7

(* Zawsze zaczynamy od MAŁEGO n ! Np: n=12 *)

NestList[1+1/#&,x,12] (* Złożenie funkcji na pierwszy rzut oka nie daje nic sensownego *)

Simplify[%] (* Po uproszczeniu okazuje się, że wynikiem jest funkcja homograficzna *)

First/@Numerator/@%//Rest (* Współczynniki mogą niektórym wydawać się znane, widać że się powtarzają w liczniku i mianowniku *)

FindSequenceFunction[%] (* Mma pozwala na odgadnięcie wzoru na n-ty wyraz ciągu *)

Fibonacci[12] (* Sprawdzamy *)

num=111 (* Teraz możemy odważyć się nieco podnieść n *)

Nest[1+1/#&,x,num]//Simplify

(Fibonacci[num]+Fibonacci[num+1]x)/(Fibonacci[num-1]+Fibonacci[num]x)

%-%% (* Jak widać odgadnięty wzór działa *)

num=Cosh[3 ArcCosh[8]]//FullSimplify (* Obliczamy docelowy n *)

Inactive[(Fibonacci[num]+Fibonacci[num+1]x)/(Fibonacci[num-1]+Fibonacci[num]x)] (* To jest sensowna odpowiedź. *)

Activate[%] (* To matematycznie ścisły, ale mało użyteczny wynik. Jako fizycy drążymy temat dalej...  *)

N[%] (* Próba obliczenia wartości numerycznej. Mma z uporem maniaka nie skraca oczywistego dla nas czynnika (10^422) ! W odpowiedzi wypadałoby go po prostu pominąć. *)

Plot[%,{x,-12,12}] (* Prónujemy graficznie. Wynik jest ewidentnie funkcją stałą *)

%%/.x->11 (* Skoro wynik jest stały, można do uzyskać wstawiając dowolny x *)

(* Wynik znowu wydaje się znajomy. Wklejamy go do narzędzia odgadującego https://th.if.uj.edu.pl/~odrzywolek/WASM/ lub używamy Wolfram Alpha *)

(* Wynik to ewidentnie GoldenRatio, złoty podział. Sprawdzamy *)

Clear[num]

Limit[(Fibonacci[num]+Fibonacci[num+1]x)/(Fibonacci[num-1]+Fibonacci[num]x),num->Infinity]

FullSimplify[%]

GoldenRatio//FunctionExpand

Zadanie 8

(* Aby upewnić się, że wszystko robimy dobrze, warto zacząć od odtworzenia szkolnych wzorów na rzut ukośny *)

rozwREF=DSolve[{
m x''[t]==0, (* F=ma, składowa pozioma *)
m h''[t]==-m g,(* F=ma, składowa pionowa *)
x[0]==0, (* Położenie w chwili t=0 *)
h[0]==0,
x'[0]==V0 Cos[α], (* Składowe prędkości w chwili t=0 *)
h'[0]==V0 Sin[α]
},
{x,h}, (* Szukane funkcje *)
t (* To po czym różniczkujemy, często czas *)
]//First

{X,H}  = {x[t],h[t]}/.rozwREF//Expand (* Idiom Mma wyciągający prawą stronę listy rozwiązań  *)

T=t/.Solve[H==0,t]//Last (* Czas lotu *)

Tmax=t/.Solve[D[H,t]==0,t][[1]] (* Moment osiągnięcia maksymalnej wysokości (maksimum f. h(t) ) *)

Hmax=H/.t->Tmax (* Maksymalna wysokość *)

Xmax=X/.t->T//Simplify (* Zasięg rzutu *)

g0=Quantity[1,"StandardAccelerationOfGravity"]//UnitConvert//QuantityMagnitude

N[g0]

wykresREF=Block[{g=g0,V0=6000,α=1},ParametricPlot[{X,H},{t,0,T},Epilog->Point[{X/.t->Tmax,Hmax}]]] (* Przykładowa trajektoria *)

(* Po odtworzeniu prostszego znanego wyniku, możemy przystąpić do właściwego zadania *)

Sposób 1 (analityczny)

rozwSYMB=DSolve[{
m x''[t]==0, (* F=ma, składowa pozioma *)
m h''[t]==-m g (1-2 h[t]/R),(* F=ma, składowa pionowa *)
x[0]==0, (* Położenie w chwili t=0 *)
h[0]==0,
x'[0]==V0 Cos[α], (* Składowe prędkości w chwili t=0 *)
h'[0]==V0 Sin[α]
},
{x,h}, (* Szukane funkcje *)
t (* To po czym różniczkujemy, często czas *)
]//First

{X1,H1}  = {x[t],h[t]}/.rozwSYMB//Simplify (* Idiom Mma wyciągający prawą stronę listy rozwiązań  *)

T1=t/.Solve[H1==0,t,Reals]//Last (* Czas lotu *)

Tmax1=t/.Solve[D[H1,t]==0,t,Reals][[1]] (* Moment osiągnięcia maksymalnej wysokości (maksimum f. h(t) ) *)

Hmax1=H1/.t->Tmax1//FullSimplify (* Maksymalna wysokość *)

Xmax1=X1/.t->T1//Simplify (* Zasięg rzutu *)

wykres=Block[{g=g0,V0=6000,α=1,R=6378000},ParametricPlot[{{X1,H1}},{t,0,T1},PlotStyle->{{Red,DotDashed}},Epilog->Point[{X1/.t->Tmax1,Hmax1}]]] (* Przykładowa trajektoria *)

Show[wykres,wykresREF]

(* Opdowiedzi *)
First/@{T1,Hmax1,Xmax1}

%/.{g->Quantity[1,"StandardAccelerationOfGravity"],R->Quantity[1,"EarthAuthalicRadius"],V0->Quantity[6,"km/s"],α->Quantity[1,"Radians"]}//N//UnitConvert

Quantity[1,"EarthAuthalicRadius"]//UnitConvert (* Ciekawostka, wzór na promień Ziemi *)

N[%]

Sposób 2 (numeryczny)

(* Główne różnice w porównaniu do rozwiązania symbolicznego:

1) Konieczność zdefiniowania z góry parametrów i warunków początkowych
   2) Konieczność podania z góry czasu lotu: tu przydaje się szkolne rozwiązanie
   3) Zamiana DSolve na NDSolve

*)

rozwNUM= 
Block[{g=g0,R=6371000,V0=6000,m=1,α=1},
NDSolve[{
m x''[t]==0, (* F=ma, składowa pozioma *)
m h''[t]==-m g (1-2 h[t]/R),(* F=ma, składowa pionowa *)
x[0]==0, (* Położenie w chwili t=0 *)
h[0]==0,
x'[0]==V0 Cos[α], (* Składowe prędkości w chwili t=0 *)
h'[0]==V0 Sin[α]
},
{x,h}, (* Szukane funkcje *)
{t,0,2T} (* To po czym różniczkujemy, często czas *)
]//First]

{X2,H2}={x[t],h[t]}/.rozwNUM

TREF=Block[{g=g0,R=6371000,V0=6000,m=1,α=1},T]//N (* Przybliżony czas lotu wg. szkolnych wzorów. Bez tego algorytmy numeryczne nie wystartują. *)

T2=t/.FindRoot[H2==0,{t,TREF}] (* Czas lotu *)

Hmax2=Maximize[{H2,0<t<TREF},t][[1]](* Maksymalna wysokość *)

Xmax2=X2/.t->T2 (* Zasięg *)

wykresNUM=Block[{g=g0,V0=6000,α=1,R=6378000},ParametricPlot[{{X2,H2}},{t,0,T1},PlotStyle->{{Blue,Dotted}},Epilog->Point[{X1/.t->Tmax1,Hmax1}]]]

Block[{g=g0,R=6371000,V0=6000,m=1,α=1},{{"Szkolny","Symboliczny","Numeryczny"},{T,T1,T2},{Hmax,Hmax1,Hmax2},{Xmax, Xmax1,Xmax2}}] //N//TableForm(* Porównanie wyniku szkolnego, analitycznego i numerycznego *)

Zadanie 9

A =1/Partition[ Range[2,50],7]

B=Range[0,42,7]

LinearSolve[A,B] (* Sposób 1 *)

Inverse[A].B (* Sposób 2 *)

X = Table["x"<>ToString[ii]//ToExpression,{ii,1,7}]

Solve[A.X==B,X] (* Sposób 3 *)

Det[MatrixExp[N@A]]

Exp[Tr[A]]

%/%%

Zadanie 10

Import["https://raw.githubusercontent.com/VA00/SymbolicRegressionPackage/master/SymbolicRegression.m"]
ZadanieNOF2024[] (* Maszyna losująca wybrała funkcję *)

1/Sinh[x] (* Tłumaczenie z amerykańskiego na polski *)

Sqrt[3/"Sinh"[x]]

F = Sqrt[3]*Sqrt[Csch[x]];

Plot[F,{x,-12,12}] (* Zaczynamy od wstępnego wykresu funkcji. Widać, że istnieje ona dla x>0 *)

FunctionDomain[F,x] (* Sprawdzamy hipotezę wynikającą z wykresu *)

FunctionRange[F,x,y] (* F. jest pod pierwiastkiem , powinna być dodatnia *)

LogLogPlot[F,{x,0.00001,100}] (* Skoro wszystko jest dodatnie, rozsądne jest użycie wykresu Log-Log *)

Limit[F,x->0,Direction->"FromAbove"] (* Na wykresie Log-Log można odnieść wrażenie, że f. nie dąży do nieskończoności w zerze. A jednak dąży ...*)

Limit[F,x->Infinity]

$Assumptions=x>0 (* Dalej możemy zakładać, że x>0 *)

Solve[D[F,x]==0&&x>0,x,Reals] (* Ekstremów na podstawie wykresu nie spodziewamy się *)

Solve[D[F,x,x]==0&&x>0,x,Reals] (* Punktów przegięcia też nie *)

ArcCurvature[F,x]//Simplify (* Ale wydaje się, że jednak jest jakieś charakterystyczne miejsce, punkt ,,przełamania'' pomiędzy 1 a 10. Spróbujemy go zdefiniować jako maksimum krzywizny *)

Solve[D[%,x]==0&&x>0,x,Reals] (* Faktycznie, jest taki punkt. Zadany rozwiązaniem r. 10 stopnia... *)

xC = x/.%[[1]]

xC//N

yC=F/.x->xC//FullSimplify

LogLogPlot[F,{x,0.001,100},Epilog->Point[Log@{xC,yC}],GridLines->Automatic]  (* Jakoś mi to nie wygląda na maksimum krzywizny *)

Plot[F,{x,0,10},Epilog->Point[{xC,yC}],PlotRange->{0,10}] (* Tu już nieco lepiej *)

ArcCurvature[Log@{x,F},x] (* Teraz szukamy krzywizny wykresu Log-Log *)

xC2=x/.Solve[D[%,x]==0&&x>0,x,Reals][[1]]

yC2=F/.x->xC2//FullSimplify

LogLogPlot[F,{x,0.001,100},Epilog->{Point[Log@{xC,yC}],Point[Log@{xC2,yC2}]},GridLines->Automatic]  (* Dalej mi to nie wygląda na maksimum krzywizny *)

D[F,x,x]/Sqrt[1+D[F,x]^2]^3//Simplify (* Spr. ze wzorem z Wikipedii https://en.wikipedia.org/wiki/Curvature#Graph_of_a_function *)

Solve[D[%,x]==0&&x>0,x,Reals] (* Wychodzi to samo *)

LogLogPlot[F,{x,0.01,100},Epilog->{Point[Log@{xC,yC}],Point[Log@{xC2,yC2}]},GridLines->Automatic,PlotRange->{0.01,100},AspectRatio->1] (* Po przeskalowaniu wykresu i zachowaniu proporcji 1:1 wykres faktycznie ma maksimum krzywizny w dobrym miejscu *)

Series[F,{x,0,3}] (* Wykres wykazuje zachowanie potęgowe dla x->0 oraz x-> Infinity. Sprawdźmy to *)

Asymptotic[F,x->Infinity] (* Z tego nic nie wynika*)

Series[F,{x,Infinity,4}] (* Tak jeszcze gorzej... *)

(*F//TrigToExp*) (* U mnie to polecenie wyłącza Kernel. Odkomentowanie na własne ryzyko. W wersji 14 problem zniknął.  *)

w1=LogLogPlot[{F,Legended[((Sqrt[3])/(Sqrt[x])),"((Sqrt[3])/(Sqrt[x]))"],Legended[Sqrt[6]Exp[-x/2],"\!\(TraditionalForm\`\*SqrtBox[\(6\)]\\ \(exp(\(-\*FractionBox[\(x\), \(2\)]\))\)\)"]},{x,0.001,1000},Epilog->{PointSize[Large],Point[Log@{xC,yC}],Point[Log@{xC2,yC2}],Point[Log[{10,10}]],Text["  - Maksimum krzywizny",Log[{10,10}],{-1,0}]},GridLines->Automatic,PlotRange->{0.01,100},AspectRatio->1,PlotStyle->{Black,{Red,Dashed},{Green,DotDashed}},PlotLabel->"Wykres funkcji F(x) =  \!\(\*SqrtBox[FractionBox[\(3\), \(sinh\\ x\)]]\)"]

w2=Plot[{F,((Sqrt[3])/(Sqrt[x])),Sqrt[6]Exp[-x/2]},{x,xC/2,2xC2},Epilog->{PointSize[Large],Point[{xC,yC}],Point[{xC2,yC2}],{Blue,Point[{Log[2],2}],Point[{Log[3],3/2}]},Text["  (ln2, 2)",{Log[2],2},{-1,-1}],Text["  (ln3, 3/2)",{Log[3],3/2},{-1,-1}]},GridLines->Automatic,PlotRange->Automatic,AspectRatio->1,PlotStyle->{Black,{Red,Dashed},{Green,DotDashed}},PlotLabel->"Powiększenie rejonu maksymalnej krzywizny\n i przejścia od trybu potęgowego do wykładniczego"]

G=F/.x->Log[z]

FindInstance[G==y,{z,y},Integers,3] (* Próba znalezienia wartości całowitych *)

InterpolatingPolynomial[{{Log[2],2},{Log[3],3/2}},x]//FullSimplify

final={Show[w1,ImageSize->400],Show[w2,ImageSize->400]}

Export[NotebookDirectory[]<>"wykres.png",Rasterize[final,RasterSize->3840,ImageResolution->600]]