Tetration/Code/DerivativesReal
Jump to navigation
Jump to search
(* Matematica code generating the plot *) (* http://en.citizendium.org/wiki/Image:TetrationDerivativesReal.jpg *) (* of defivatives of tetration along the real axis *) (* Copyleft 2009 by Dmitrii Kouznetsov *)
<< Graphics`ImplicitPlot`
c[x_, y_, z_] = RGBColor[x, y, z];
Zc = 0.31813150520476413531 - 1.33723570143068940890 I
Zo = Conjugate[Zc] a2 = N[1/2/(Zo - 1), 20] a3 = (a2 + 1/6)/(Zo*Zo - 1) a4 = (a2/2 + a2*a2/2 + a3 + 1/24)/(Zo*Zo*Zo - 1) a5 = (a2*a2/2 + a2/6 + a2*a3 + a3/2 + a4 + 1/120)/(Zo*Zo*Zo*Zo - 1)
R = 1.0779614375278 - .9465409639479I b0 = 0.1223 - 0.02370I
e = Exp[Zo*z + R] Li = 2*Pi*I fima[z_] = Zo + e*(1 + e*(a2 + e*(a3 + e*(a4 + e*a5))) + b0*Exp[Li*z]);
FIMA[z_] := If[Im[z] < 4 + .2379Re[z], Exp[FIMA[z - 1]], fima[z]]
matai = {
0.37090658903228507226 + (1.33682167078891400713*I)
, 0.03660096537598455518 + (0.13922215389950498565*I)
, -0.16888431840641535131 + (0.09718533619629270148*I)
, -0.12681315048680869007 + (-0.11831628767028627702*I)
, 0.04235809310323926380 + (-0.10520930088320722129*I)
, 0.05848306393563178218 + (-0.00810224524496080435*I)
, 0.02340031665294847393 + (0.01807777011820375229*I)
, 0.00344260984701375092 + (0.01815103755635914459*I)
, -0.00803695814441672193 + (0.00917428467034995393*I)
, -0.00704695528168774229 + (-0.00093958506727472686*I)
, -0.00184617963095305509 + (-0.00322342583181676459*I)
, 0.00054064885443097391 + (-0.00189672061015605498*I)
, 0.00102243648088806748 + (-0.00055968657179243165*I)
, 0.00064714396398048754 + (0.00025980661935827123*I)
, 0.00010444455593372213 + (0.00037199472598828116*I)
, -0.00011178535404343476 + (0.00016786687552190863*I)
, -0.00010630158710808594 + (0.00002072200033125881*I)
, -0.00005078098819110608 + (-0.00003575913005741248*I)
, -0.00000314742998690270 + (-0.00003523185937587781*I)
, 0.00001347661344130504 + (-0.00001333034137448205*I)
, 0.00000980239082395275 + (0.00000047607184151673*I)
, 0.00000355493475454698 + (0.00000389816212201278*I)
, -0.00000021552652645735 + (0.00000296273413237997*I)
, -0.00000131673903627820 + (0.00000097381354534333*I)
, -0.00000083401960806066 + (-0.00000018663858711081*I)
, -0.00000022869610981361 + (-0.00000037497716770031*I)
, 0.00000005372584613379 + (-0.00000023060136585176*I)
, 0.00000011406656653786 + (-0.00000006569510293486*I)
, 0.00000006663595460757 + (0.00000002326630571343*I)
, 0.00000001396786846375 + (0.00000003315118300198*I)
, -0.00000000684890556421 + (0.00000001713041981611*I)
, -0.00000000916619598268 + (0.00000000403886083652*I)
, -0.00000000502933384276 + (-0.00000000222121299478*I)
, -0.00000000084484352792 + (-0.00000000273668661113*I)
, 0.00000000070086729861 + (-0.00000000124687683156*I)
, 0.00000000070558101710 + (-0.00000000021962577544*I)
, 0.00000000035900951951 + (0.00000000018774741308*I)
, 0.00000000005248658571 + (0.00000000021201177126*I)
, -0.00000000006264758835 + (0.00000000009059171879*I)
, -0.00000000005333473585 + (0.00000000001006078866*I)
, -0.00000000002432138144 + (-0.00000000001506937008*I)
, -0.00000000000331880379 + (-0.00000000001544700067*I)
, 0.00000000000501652570 + (-0.00000000000658967459*I)
, 0.00000000000401214135 + (-0.00000000000036708383*I)
, 0.00000000000158629111 + (0.00000000000119885992*I)
, 0.00000000000019668766 + (0.00000000000106532662*I)
, -0.00000000000036355730 + (0.00000000000047229527*I)
, -0.00000000000029920206 + (0.00000000000001251827*I)
, -0.00000000000010305550 + (-0.00000000000009571381*I)
, -0.00000000000000910369 + (-0.00000000000007087680*I)
, 0.00000000000002418310 + (-0.00000000000003240337*I)
};
z3 = z - 3I; z32 = z3/2;
tai[z_] = Sum[Extract[matai, n + 1]*z32^n, {n, 0, 50}];
TAI[z_] := If[Re[z] < -.5, Log[TAI[z + 1]], If[Re[z] > .5, Exp[TAI[z - 1]], tai[z]]]
matao = {
0.30685281944005469058, 1.18353470251664338875
, 1.58593285160678321155, 1.36629265207672068172
, 1.36264601823980036066, 1.21734246689515424045
, 1.10981816083559525765, 0.96674692974769849130
, 0.84089872598668435888, 0.71353210966804747617
, 0.60168548504001373445, 0.49928574281440518678
, 0.41140086629121763728, 0.33506195665178500898
, 0.27104779243942234146, 0.21728554054610033086
, 0.17311050207880035456, 0.13690016038526570119
, 0.10765949732729711286, 0.08413804539743192923
, 0.06542450487497340761, 0.05060001212013485322
, 0.03895655493977817629, 0.02985084640296329153
, 0.02277908979501017117, 0.01730960309240666892
, 0.01310389615589767874, 0.00988251130733762764
, 0.00742735935367278347, 0.00556296426263720549
, 0.00415334478103463346, 0.00309116153137843543
, 0.00229387529664008653, 0.00169729976398295653
, 0.00125245885041635465, 0.00092172809095368547
, 0.00067661152429638357, 0.00049544127485341987
, 0.00036192128589181518, 0.00026376927786672476
, 0.00019180840045267570, 0.00013917553105723647
, 0.00010077412023867018, 0.00007281884753121133
, 0.00005251474516228446, 0.00003779882770351268
, 0.00002715594536867241, 0.00001947408515177282
, 0.00001394059355016322, 0.00000996213949015693
, 0.00000710713872292710, 0.00000506199803708578
, 0.00000359960968975399, 0.00000255569149787694
, 0.00000181175810338313, 0.00000128245831538430
, 0.00000090647322737496, 0.00000063980422418981
, 0.00000045095738191441, 0.00000031741772125007
, 0.00000022312521183625, 0.00000015663840476155
, 0.00000010982301013230, 0.00000007690305934973
, 0.00000005378502675604, 0.00000003757126131521
, 0.00000002621429405247, 0.00000001826909956818
, 0.00000001271754463425, 0.00000000884310192977
, 0.00000000614230041407, 0.00000000426177146865
, 0.00000000295386817285, 0.00000000204522503591
, 0.00000000141464900426, 0.00000000097750884878
, 0.00000000067478454029, 0.00000000046535930671
, 0.00000000032062550784, 0.00000000022069891976
, 0.00000000015177557961, 0.00000000010428189463
, 0.00000000007158597119, 0.00000000004909806710
, 0.00000000003364531769, 0.00000000002303635851
, 0.00000000001575933679, 0.00000000001077213757
, 0.00000000000735717912, 0.00000000000502077719
, 0.00000000000342362421, 0.00000000000233271256
, 0.00000000000158818623, 0.00000000000108046566
, 0.00000000000073450488, 0.00000000000049894945
, 0.00000000000033868911, 0.00000000000022973789
, 0.00000000000015572383, 0.00000000000010548054
, 0.00000000000007139840, 0.00000000000004829557
, 0.00000000000003264619, 0.00000000000002205299
, 0.00000000000001488731, 0.00000000000001004347
, 0.00000000000000677124, 0.00000000000000456225
};
maclo[z_] = Sum[Extract[matao, n + 1]*(z/2.)^n, {n, 0, 100}] + Log[z + 2]
MACLO[z_] :=
If[Re[z] < -.5, Log[MACLO[z + 1]],
If[Re[z] > .5, Exp[MACLO[z - 1]],
maclo[z]
]]
SEXP[z_] := If[Im[z] > 4.5 , FIMA[z],
If[Im[z] > 1.5, TAI[z],
If[Im[z] > -1.5, MACLO[z],
If[Im[z] > -4.5, Conjugate[TAI[Conjugate[z]]],
Conjugate[FIMA[Conjugate[z]]]
]]]]
r = Re[SEXP[x + I*y]];
f = Im[SEXP[x + I*y]];
plo0 = ImplicitPlot[{r == Re[Zo], f == Im[Zo],
r == -1.8, r == -1.6, r == -1.4, r == -1.2,
r == -.8, r == -.6, r == -.4, r == -.2,
r == 1.8, r == 1.6, r == 1.4, r == 1.2,
r == .8, r == .6, r == .4, r == .2,
f == -1.8, f == -1.6, f == -1.4, f == -1.2,
f == -.8, f == -.6, f == -.4, f == -.2,
f == 1.8, f == 1.6, f == 1.4, f == 1.2,
f == .8, f == .6, f == .4, f == .2,
r == -3, r == -2, r == -1, r == 0,
r == 1, r == 2, r == 3,
f == -3, f == -2, f == -1,
f == 0, f == 1, f == 2, f == 3
}, {x, -2.1, 2.1}, {y, -.3, 5.5}, PlotStyle -> {
c[1, 0, 1], c[0, 1, 0],
c[1, 0, 0], c[1, 0, 0], c[1, 0, 0], c[1, 0, 0],
c[1, 0, 0], c[1, 0, 0], c[1, 0, 0], c[1, 0, 0],
c[0, 0, 1], c[0, 0, 1], c[0, 0, 1], c[0, 0, 1],
c[0, 0, 1], c[0, 0, 1], c[0, 0, 1], c[0, 0, 1],
c[0, 1, 0], c[0, 1, 0], c[0, 1, 0], c[0, 1, 0],
c[0, 1, 0], c[0, 1, 0], c[0, 1, 0], c[0, 1, 0],
c[0, 1, 0], c[0, 1, 0], c[0, 1, 0], c[0, 1, 0],
c[0, 1, 0], c[0, 1, 0], c[0, 1, 0], c[0, 1, 0],
c[0, 0, 0], c[0, 0, 0], c[0, 0, 0], c[0, 0, 0],
c[0, 0, 0], c[0, 0, 0], c[0, 0, 0],
c[1, 0, 0], c[1, 0, 0], c[1, 0, 0], c[1, 0, 1],
c[0, 0, 1], c[0, 0, 1], c[0, 0, 1],
}, PlotPoints -> 100, PlotRange -> {{-2.1, 2.1}, {-.3, 5.5}}
{SEXP[-1], SEXP[0], SEXP[1]}
plo1 = Plot[{SEXP[x], SEXP'[x], SEXP[x]}, {x, -1.9, 1.2},
GridLines -> {{-2, -1, 1}, {-2, -1, 1, 2, 3}}, AspectRatio -> Automatic,
PlotRange -> {{-2, 1.2}, {-2.1, 3.1}},
PlotStyle -> {c[0, 0, 0], c[1, 0, 0], c[0, .7, 0], c[0, 0, 1],
c[.5, 0, .7]}];
plo2 = Plot[{SEXP'[x], SEXP[x], SEXP[x], SEXP'[x]}, {x, -1.9, 1.2},
GridLines -> {{-2, -1.5, -1, -.5, .5, 1}, {-2, -1, 1, 2, 3}},
AspectRatio -> Automatic, PlotRange -> {{-2, 1.2}, {-2.1, 3.1}},
PlotStyle -> {c[1, 0, 0], c[0, .7, 0], c[0, 0, 1], c[.5, 0, .7]}];
{SEXP[0], SEXP'[0], SEXP[0], SEXP[0], SEXP'[0], SEXP[0]}
Export["plo0.jpg", plo0] Export["plo0.eps", plo0] Export["plo0.pdf", plo0] Export["plo0.svg", plo0]
Export["plo0.jpg", plo1] Export["plo0.eps", plo1] Export["plo0.pdf", plo1] Export["plo0.svg", plo1]
Export["plo0.jpg", plo2] Export["plo0.eps", plo2] Export["plo0.pdf", plo2] Export["plo0.svg", plo2]
(*end of generator of plot of derivative of tetration *)