Feigenbaum Constant

Author

Eric W. Weisstein
May 12, 2006

This notebook downloaded from http://mathworld.wolfram.com/notebooks/Constants/FeigenbaumConstant.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/FeigenbaumConstant.html.

©2006 Wolfram Research, Inc. except for portions noted otherwise

Values

David Broadhurst  22-Mar-1999
http://pi.lacim.uqam.ca/piDATA/feigenbaum.txt
and David Broadhurst, pers. comm., Jan. 31, 2005

δ=FeigenbaumDelta;
α=FeigenbaumAlpha;
(Subscript[μ, ∞])=3.5699456718709449018420051513864989367638369115148323781079755299213628875001367775263210342163;
b=0.8323672369053164248490954462761044873784441510122511788018155377906511490617212992105749673250728489662179493085810218965790968049598522918858610317385675130226238383122671420685183711875363491362035488204184582129489452800819510186963028258245294829711561629282470546369683200759152643838708587083193628242052599240269733846087964194713516126985503411844435686185228769350471197614070499032433715378097841540314810087444324620581291322418748660093231484287518108362885714339826971425164329036443831117236492115534326800169942983343048821389072590779119015925423405580360272114331844081840097934443345396018870714295750813278704117786464474709997338770400454712978444413040958357935342920264246662785116336276526707258743643744031585356826775745194382773017401937414307912783836782859060956573909121951885375872115688323172785750683779382744229491745521125053133105510676942435975669952120600990719081539464225947984827097065535832307466931764739816585060065847908039033441468866332261531378185904579907945405208836635;
c=1.8312589849371314853421733978737816274412980903762379654774116464702962892151819746640269560743153593114467546567643677642999140046668391002275698544479014017974163358630915127209975783903495332439795089089784388681012689908386206416711155926761527416018736089861171393701765742269408842033822369572666411099700243063074578419603204468591474630632221308038982926176279487823840468503251944825401523679859659042762573329854239726864266992525400752698012464069425637914066762344910315114691129152332121994443182515354937395703638814225700372219769860860427113111537951515203634971729459021044810405216758657973411661272874798290488341630337687334160069769294370791242392176707492248174963476186792387132242383409818181455891318434122829260679656866306800025824425947678408371051279370262976429742726741473713533085787371144882449379816288696672329596345137011738421245934;
d=2.6831509004740718014499367586451482510386109205544354930936808684236304461429097021746362983153800003503033942255093904858421173411382853476972765410975066166352464168327067469876911730682490556475241058846697132122168540788487314014805843580000406240806547619113662653733480766696471571244029870479378079995739152121307339065164252213918414373517869031107430085728929019684589487593695673030577920734878406376454729255128864988186843811804643753211349305090620688219288170205359432518573730362812065285731174938870766392292158681479549994872289174241868848121296482815431125794183720113976530733956992276836976718845735691313392850631440703501731079018684652869042923464542058697803679602398600997134611958098397471448076865651668262366735748138514534122953365406381892334481762687754607251768929730673131412568009781912415169247189487376763709719447715817358677632441;
κ=1.3554618047064087438634415359109709760367902710479931781617936681330588190430203712854212477988901157513964820484243139825515307045982912575819072590429333858354557604928286465433412237347613113165734968192554683667914426935420848360809901275260696101461009760416109139003671137088335005617917170895044199359261516487748721159203787954438730220057511651940767626123337890437508096841571580344173874824201726443759630518658616830558599958236051647773614375410088775915709577813521844656309064555792705356477115381390307956778036552973117539385535553124409395297353260081236903741193550335118053205154820062292401345695295087659103653855843543673604182134963423810888814534138500315541531739750936282298728040815436184584628977867171417934601710992578290458231475782444524715640398842764642211990339064314200753889117228668205544605239291441546074631085975481673700466507;

Bifurcation Diagram

Feigenbaum=Compile[{{μ,_Real}},({μ,#}&)/@Union[
Drop[NestList[(1-μ  #^2)&,.2,500],400]
]
];

f=Table[Feigenbaum[μ],{μ,0.,2.,.0001}];//Timing

ListPlot[Flatten[f,1],
PlotStyle->{Red,AbsolutePointSize[.001]},Frame->True,
FrameLabel->{μ,x},
PlotLabel->(Subscript[x, n])==1-μ,
BaseStyle->FontFamily->"Times"]

Bifurcations

Discriminant[p_?PolynomialQ,x_]:=With[{m=Exponent[p,x]},Cancel[((-1)^(1/2m(m-1))Resultant[p,D[p,x],x])/Coefficient[p,x,m]^(2m-1)]
]

f:=1-μ #^2&

2-Fold

Factor[Nest[f,x,2]-x]

f2=Factor[Cancel[(Nest[f,x,2]-x)/(f[x]-x)]]

d2=Discriminant[f2,x]

Solve[d2==0,μ]

3-Fold

f3=Cancel[(Nest[f,x,3]-x)/(f[x]-x)]

d3=Discriminant[f3,x]

Reduce[Numerator[d3]==0&&μ>0,μ]

4-Cycle

f4=Cancel[(Nest[f,x,4]-x)/(Nest[f,x,2]-x)]

d4=Discriminant[f4,x];

{#,N[#]}&[Last/@List@@Reduce[Numerator[d4]==0&&μ>0,μ]]

5-Cycle

f5=Factor[(Nest[f,x,5]-x)/(f[x]-x)];

d5=Discriminant[f5,x];

{#,N[#]}&[Last/@List@@Reduce[Numerator[d5]==0&&μ>0,μ]]

8-Cycle

f8=Cancel[(Nest[f,x,8]-x)/(Nest[f,x,4]-x)];

d8=Discriminant[f8,x];//Timing

{#,N[#]}&[Last/@List@@Reduce[Numerator[d8]==0&&μ>0,μ]]

Numeric

vals={#[[1,1]],Union[Last/@#,SameTest->Equal]}&/@f;//Timing

vals={#[[1,1]],Union[Rationalize[SetPrecision[Last/@#,2],.1]]//N}&/@f;//Timing

pos=Table[Flatten[Position[Length[Last[#]]&/@vals,_?(#>=2^n&),{1},10]],{n,4}]

vals[[#]]&/@pos

Plot

Show[Table[With[{n=2^k},
ContourPlot[Nest[(1-c #^2)&,x,n]-x,{c,0,2},{x,-1,1},PlotPoints->400,Contours->{0},ContourShading->False,ContourStyle->{{Hue[(k-1)/4.],Thickness[0.0001]}},DisplayFunction->Identity]],{k,3,1,-1}],DisplayFunction->$DisplayFunction,AspectRatio->1/GoldenRatio,
FrameLabel->TraditionalForm/@{μ,x},
PlotLabel->TraditionalForm[HoldForm[Superscript[f,n][x]]]
]

<<NumericalMath`

r[n_,i_:1,opts___]:=NMinimize[{c,Cancel[(Nest[(1-c #^2)&,x,2n]-x)/(Nest[(1-c #^2)&,x,n]-x)]==0&&-1<=x<=1&&0.7<=c<=1.5},{c,x},Method->{"SimulatedAnnealing","RandomSeed"->i},
opts,WorkingPrecision->20][[1]]

bi=Table[r[2^n],{n,0,4}]

r[32]

r[32,MaxIterations->20,WorkingPrecision->25]

Values

(#2-#1)/(#3-#2)&@@@Partition[bi,3,1]

α

a=1/α;
Solve[1-a==((1-a^2)/((1-a^2(1-a))^2)),α]

N[%]

Numeric Computation

(1+(∑_(i=1)^n)(Subscript[g, i]))(1+(∑_(i=1)^n)(Subscript[g, i])((Abs[(Subscript[x, j])])^(z i)))-1-(∑_(i=1)^n)(Subscript[g, i])((Abs[1+(∑_(i=1)^n)(Subscript[g, i])((Abs[(1+(∑_(i=1)^n)(Subscript[g, i]))(Subscript[x, j])])^(z i))])^(z i))==0

With[{n=5,z=2},
gs=Array[g,n];
x[i_]:=(i/n)^(1/z);
gsum=(1+Plus@@gs);
t=Table[gsum(1+Sum[g[i]Abs[x[j]]^(z i),{i,n}])-1-Sum[g[i]Abs[1+Sum[g[i]Abs[gsum x[j]]^(z i),{i,n}]]^(z i),{i,n}]==0,{j,n}]
]