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


Messages In This Thread
sexp and slog at a microcalculator - by Kouznetsov - 01/08/2009, 08:51 AM

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



Users browsing this thread: 1 Guest(s)