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
  fast accurate Kneser sexp algorithm sheldonison 40 133,922 07/03/2022, 06:38 AM
Last Post: JmsNxn
  Revisting my accelerated slog solution using Abel matrix inversion jaydfox 22 41,129 05/16/2021, 11:51 AM
Last Post: Gottfried
  A note on computation of the slog Gottfried 6 17,844 07/12/2010, 10:24 AM
Last Post: Gottfried
  Improving convergence of Andrew's slog jaydfox 19 47,894 07/02/2010, 06:59 AM
Last Post: bo198214
  regular sexp: curve near h=-2 (h=-2 + eps*I) Gottfried 2 10,461 03/10/2010, 07:52 AM
Last Post: Gottfried
  intuitive slog base sqrt(2) developed between 2 and 4 bo198214 1 6,749 09/10/2009, 06:47 PM
Last Post: bo198214
  regular sexp:different fixpoints Gottfried 6 21,163 08/11/2009, 06:47 PM
Last Post: jaydfox
  sexp(strip) is winding around the fixed points Kouznetsov 8 23,887 06/29/2009, 10:05 AM
Last Post: bo198214
  SAGE code implementing slog with acceleration jaydfox 4 12,577 10/22/2007, 12:59 AM
Last Post: jaydfox
  Dissecting Andrew's slog solution jaydfox 15 33,390 09/20/2007, 05:53 AM
Last Post: jaydfox



Users browsing this thread: 1 Guest(s)