Thread Rating:
  • 0 Vote(s) - 0 Average
  • 1
  • 2
  • 3
  • 4
  • 5
sexp and slog at a microcalculator
#1
Henryk, I upload the Mahtematica version of the fast sexp and fast slog.
(* It is posted also at *)
(* http://en.citizendium.org/wiki/Tetration...l.jpg/code *)
(* Copyleft 2008-2009 by Dmitrii Kouznetosv*)
(* Please indicate the souce if redistribute *)

<< 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]]]
]]]]

(* Polt of Figure 0 *)
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["plo1.jpg", plo1]
Export["plo1.eps", plo1]
Export["plo1.pdf", plo1]
Export["plo1.svg", plo1]

Export["plo2.jpg", plo2]
Export["plo2.eps", plo2]
Export["plo2.pdf", plo2]
Export["plo2.svg", plo2]

(* end of code. Copyleft 2008-2009 by Dmitrii Kouznetsov *)

       
I include the two pics generated with this code. I would not say that in Mathematica, the algorithm runs so fast as in the C++. In C++, it takes few seconds, to generate an equivalent of plo0 above; the Mathematica takes few minutes. Anyway, the algorithm is simple and can run even at microcalculators. It would be interesting to compare the results to other algorithms.

The superexponential seems to be more precise than slog; I made sexp of 3 pieces, while the slog is "one piece". If there are any way to see, wether any other algorithm is more precise?
Reply


Possibly Related Threads...
Thread Author Replies Views Last Post
  Revisting my accelerated slog solution using Abel matrix inversion jaydfox 21 6,124 02/09/2019, 02:25 PM
Last Post: sheldonison
  fast accurate Kneser sexp algorithm sheldonison 38 69,936 01/14/2016, 05:05 AM
Last Post: sheldonison
  A note on computation of the slog Gottfried 6 9,134 07/12/2010, 10:24 AM
Last Post: Gottfried
  Improving convergence of Andrew's slog jaydfox 19 24,199 07/02/2010, 06:59 AM
Last Post: bo198214
  regular sexp: curve near h=-2 (h=-2 + eps*I) Gottfried 2 5,649 03/10/2010, 07:52 AM
Last Post: Gottfried
  intuitive slog base sqrt(2) developed between 2 and 4 bo198214 1 3,409 09/10/2009, 06:47 PM
Last Post: bo198214
  regular sexp:different fixpoints Gottfried 6 11,078 08/11/2009, 06:47 PM
Last Post: jaydfox
  sexp(strip) is winding around the fixed points Kouznetsov 8 12,182 06/29/2009, 10:05 AM
Last Post: bo198214
  SAGE code implementing slog with acceleration jaydfox 4 6,780 10/22/2007, 12:59 AM
Last Post: jaydfox
  Dissecting Andrew's slog solution jaydfox 15 17,008 09/20/2007, 05:53 AM
Last Post: jaydfox



Users browsing this thread: 1 Guest(s)