|
%I #10 Jun 23 2020 05:55:48
%S 7,7,6,4,2,3,7,1,3,7,1,4,8,3,2,4,2,5,9,8,5,6,9,8,2,0,6,2,6,0,0,9,0,3,
%T 6,4,2,3,6,4,3,2,1,7,3,7,9,8,2,7,1,0,6,7,5,9,1,2,0,1,9,9,6,9,9,5,0,7,
%U 3,6,6,0,0,8,8,4,8,1,0,5,1,1,4,3,7,8,0,2,2,1,6,4,1,3,6,2,3,9,6
%N Decimal expansion of the maximal curvature of y = Gamma(x), for x>0.
%C Each branch of y = Gamma(x) has a point of maximal curvature (MC), at which the osculating circle has minimal radius (R). The branch in Quadrant I has MC at (x, Gamma(x)), where x = 0.9757... and R = 0.77642... Details for 4 branches (shown by 1st Mathematica program):
%C For the branch -3 < x < -2:
%C MC at x=-2.6209004043183225054792567933147...
%C R = 0.1025411250345462193237149178953328755...
%C For the branch -2 < x < -1:
%C MC at x=-1.57452893040224357315540638154037...
%C R = 0.043652981140784797188517226949156690045...
%C For the branch -1 < x < 0:
%C MC at x=-0.50414409519766396393374935693160...
%C R = 0.0315571147317663900987190484592293666...
%C For the branch 0 < x:
%C MC at x=0.97574729311153379112462151102264...
%C R = 0.7764237137148324259856982062600903642...
%H Eric Weisstein's World of Mathematics, <a href="http://mathworld.wolfram.com/GammaFunction.html">Gamma Function</a>
%t (* FIRST program *)
%t g[x_] := Gamma[x]; p[k_, x_] := PolyGamma[k, x]
%t solns = Map[#[[1]][[1]] &, GatherBy[Map[{#[[2]], Rationalize[#[[2]], 10^-30]} &,
%t Select[Table[{nn, #, Accuracy[#]} &[x /. FindRoot[
%t 0 == (2 g[x]^2 p[0, x]^5 + 3 p[0, x] p[1, x] (-1 + g[x]^2 p[1, x]) +
%t p[0, x]^3 (-1 + 3 g[x]^2 p[1, x]) - (1 + g[x]^2 p[0, x]^2) p[2, x]), {x, nn},
%t WorkingPrecision -> 100]], {nn, -2.8, 2.5, .101}], #[[3]] > 40 &]], #[[2]] &]]
%t {coords, rads} = Chop[Transpose[Map[{{(-p[0, x] + x p[0, x]^2 - g[x]^2 p[0, x]^3 +
%t x p[1, x])/(p[0, x]^2 + p[1, x]), (1 + g[x]^2 (2 p[0, x]^2 + p[1, x]))/(g[x] (p[0, x]^2 + p[1, x]))}, Sqrt[(1 + g[x]^2 p[0, x]^2)^3/(g[x]^2 (p[0, x]^2 + p[1, x])^2)]} /. x -> # &, solns]]]
%t Show[Plot[g[x], {x, -3, 2}], Map[{Graphics[Circle[coords[[#]], rads[[#]]]],
%t Graphics[Point[coords[[#]]]]} &, Range[Length[rads]]],
%t AspectRatio -> Automatic, PlotRange -> {-4, 4}, ImageSize -> 600]
%t (* _Peter J. C. Moses_, Jun 17 2020 *)
%t (* Graphics output:: 4 osculating circles;
%t Numerical output: first 4 numbers are x-coordinates of touchpoints of osculating circles with graph of gamma function; next 8 numbers are in pairs: (x,y) for the centers of the four circles; last 4 numbers are radii of the 4 circles *)
%t (* SECOND program: animation of osculating circle *)
%t Animate[Show[cent = {(-PolyGamma[0, x] + x PolyGamma[0, x]^2 -
%t Gamma[x]^2 PolyGamma[0, x]^3 + x PolyGamma[1, x])/(PolyGamma[0, x]^2 + PolyGamma[1, x]), (1 + Gamma[x]^2 (2 PolyGamma[0, x]^2 + PolyGamma[1, x]))/(Gamma[x] (PolyGamma[0, x]^2 + PolyGamma[1, x]))}; rad = Sqrt[(1 +
%t Gamma[x]^2 PolyGamma[0, x]^2)^3/(Gamma[x]^2 (PolyGamma[0, x]^2 + PolyGamma[1, x])^2)]; Plot[Gamma[x], {x, 0, 4}],
%t Graphics[{PointSize[Large], Point[{x, Gamma[x]}]}],
%t Graphics[{PointSize[Large], Point[cent]}],
%t Graphics[Circle[cent, rad]], AxesOrigin -> {0, 0},
%t PlotRange -> {{0, 4}, {0, 6}}, ImageSize -> 400,
%t AspectRatio -> Automatic], {x, 0.4, 3.5}, AnimationRunning -> True]
%t (* _Peter J. C. Moses_, Jun 18 2020 *)
%Y Cf. A030171.
%K nonn,cons
%O 0,1
%A _Clark Kimberling_, Jun 21 2020
|
