Curvature - Based Optimal Polynomial Geometric Interpolation of
Circular Arcs

2. Preliminaries

For[n=2,n<=4,n++,
For[j=0,j<=n,j++,(Subscript[B, n,j])[t_]=Binomial[n,j](((((1+t)/2)))^j)(((((1-t)/2)))^(n-j))]];

BasisChange[s_,x_]:=Module[{n=Length[CoefficientList[s,x]]-1,i,j,y,t={}},
For[j=0,j<=n,j++,
y=0;
For[i=0,i<=j,i++,y=y+Binomial[n-i,j-i]*Coefficient[s,x,i]];
AppendTo[t,Simplify[y]]];
t]
BasisChange[s_,x_,n_]:=Module[{i,j,y,t={}},
For[j=0,j<=n,j++,
y=0;
For[i=0,i<=j,i++,y=y+Binomial[n-i,j-i]*Coefficient[s,x,i]];
AppendTo[t,Simplify[y]]];
t]

3. Quadratic (G^0) approximants

Definitions

n=2;
(Subscript[b, n,0])={c,-(Sqrt[1-(c^2)])};(Subscript[b, n,1])={d,0};
(Subscript[b, n,2])={c,(Sqrt[1-(c^2)])};
(Subscript[p, n])[t_,c_,d_]=Sum[(Subscript[b, n,j])(Subscript[B, n,j])[t],{j,0,2}];
(Subscript[er, n])[t_,c_,d_]=(Sqrt[(((Subscript[p, n])[t,c,d][[1]])^2)+(((Subscript[p, n])[t,c,d][[2]])^2)])-1//Simplify;
(Subscript[e, n])[t_,c_,d_]=1-(1/(Sqrt[(((((D[(Subscript[p, n])[t,c,d][[1]],t])^2)+((D[(Subscript[p, n])[t,c,d][[2]],t])^2)))^3)]))(D[(Subscript[p, n])[t,c,d][[1]],t]*D[(Subscript[p, n])[t,c,d][[2]],{t,2}]-D[(Subscript[p, n])[t,c,d][[2]],t]*D[(Subscript[p, n])[t,c,d][[1]],{t,2}])//Simplify;

Auxiliary calculations

(Subscript[e, 2])[t,c,d]-(1+(((Sqrt[1-(c^2)])(c- d))/(Sqrt[(((1-(c^2)+(((c-d))^2)(t^2)))^3)])))//Simplify

t = 0,-1,1 are the only candidates for the extrema of (Subscript[e, 2])(.,c,d)

D[(Subscript[e, 2])[t,c,d],{t,1}]-((-3 (Sqrt[1-(c^2)]) (((c-d))^3) t)/((1-(c^2)+(((c-d))^2)(t^2))(Sqrt[(((1-(c^2)+(((c-d))^2)(t^2)))^3)])))//Simplify

For d>c we have local minima at t=0

Assuming[0<c<1,D[(Subscript[e, 2])[t,c,d],{t,2}]/.t->0//Simplify]

The function (Subscript[e, 2])(t,c,.) has local extreme at d=c+((Sqrt[2])/2)(Sqrt[1-(c^2)])

Assuming[0<c<1,Solve[D[(Subscript[e, 2])[1,c,d],d]==0,d,Reals]]

Example 3.1

c1=((Sqrt[2])/2);dC1=((1+(Sqrt[2]))/2);dE1=d/.Solve[(Subscript[e, 2])[0,c1,d]+(Subscript[e, 2])[1,c1,d]==0,d][[1]];
c2=((Sqrt[3])/2);dC2=(((Sqrt[2])+2(Sqrt[3]))/4);dE2=d/.Solve[(Subscript[e, 2])[0,c2,d]+(Subscript[e, 2])[1,c2,d]==0,d][[1]];
GraphicsRow[{Plot[{(Subscript[e, 2])[t,c1,dC1],(Subscript[e, 2])[t,c1,dE1]},{t,-1,1},GridLines->{{},{(Subscript[e, 2])[1,c1,dC1],-(Subscript[e, 2])[1,c1,dC1]}},PlotStyle->{Black,{Black,Dotted}}],Plot[{(Subscript[e, 2])[t,c2,dE2],(Subscript[e, 2])[t,c2,dC2]},{t,-1,1},GridLines->{{},{(Subscript[e, 2])[1,c2,dC2],-(Subscript[e, 2])[1,c2,dC2]}},PlotStyle->{Black,{Black,Dotted}}]}]

Theorem 3.2

For c<=(1/6) (Sqrt[(1/6) (181-12 (Sqrt[6]))]) the optimal parameter (SuperStar[d]) is

Assuming[0<c<1,Solve[(Subscript[e, 2])[0,c,c+((Sqrt[1-(c^2)])/(Sqrt[2]))]+(Subscript[e, 2])[1,c,c+((Sqrt[1-(c^2)])/(Sqrt[2]))]==0,c]//Simplify]//ToRadicals

For c>=(1/6) (Sqrt[(1/6) (181-12 (Sqrt[6]))]) the optimal parameter (SuperStar[d]) is obtained as the solution (Subscript[e, 2])[0,c,d]+(Subscript[e, 2])[1,c,d]=0

Select[d/.NSolve[(Subscript[e, 2])[0,c0,d]+(Subscript[e, 2])[1,c0,d]==0,d,Reals],c0<#&][[1]]

Calculation for arbitrary angle φ

Blue curve is optimal interpolant with respect to the curvature error function and orange one the optimal one with respect to the radial error function.
On the middle there are graphs of the radial error functions of both interpolant and on the right there are graphs of the curvature error functions of the interpolants.

φ0=(π/3);
c0=N[Cos[φ0]];dC=If[c0<=(1/6) (Sqrt[(1/6) (181-12 (Sqrt[6]))]),c0+((Sqrt[1-(c0^2)])/(Sqrt[2])),Select[d/.NSolve[(Subscript[e, 2])[0,c0,d]+(Subscript[e, 2])[1,c0,d]==0,d,Reals],c0<#&][[1]]];
dE=d/.NSolve[(Subscript[er, 2])[t,c0,d]+(Subscript[er, 2])[0,c0,d]==0&&D[(Subscript[er, 2])[t,c0,d],t]==0&&0<t<1&&d>0,{d,t},Reals][[1]];
tocke={(Subscript[b, 2,0]),(Subscript[b, 2,1]),(Subscript[b, 2,2])}/.{c->c0,d->dC};GraphicsRow[{Show[ParametricPlot[{(Subscript[p, 2])[t,c0,dC],(Subscript[p, 2])[t,c0,dE],{Cos[φ0 t],Sin[φ0 t]}},{t,-1,1},PlotStyle->{ ,,Red},Ticks->{{0,0.5,1,1.5},{-1,-0.5,0,0.5,1}}],
ListPlot[tocke,PlotStyle->{PointSize[0.02],Black}],Graphics[{Black,Line[tocke]}],AspectRatio->Automatic,PlotRange->All],
Plot[{(Subscript[er, 2])[t,c0,dC],(Subscript[er, 2])[t,c0,dE]},{t,-1,1}],
Plot[{(Subscript[e, 2])[t,c0,dC],(Subscript[e, 2])[t,c0,dE]},{t,-1,1},GridLines->{{},{(Subscript[e, 2])[1,c0,dC],-(Subscript[e, 2])[1,c0,dC]}}]}]

A table of best interpolants with corresponding errors

angles={(π/2),(π/3),(π/4),(π/6),(π/8),(π/12)};
(Subscript[sez, 2])={{"φ","(SuperStar[d])","curvature error","radial error","(d^r)","curvature error","radial error"}};
For[i=1,i≤Length[angles],i++,
φ0=angles[[i]];
c0=N[Cos[φ0]];
dC=If[c0<=(1/6) (Sqrt[(1/6) (181-12 (Sqrt[6]))]),c0+((Sqrt[1-(c0^2)])/(Sqrt[2])),Select[d/.NSolve[(Subscript[e, 2])[0,c0,d]+(Subscript[e, 2])[1,c0,d]==0,d,Reals],c0<#&][[1]]];
dE=d/.NSolve[(Subscript[er, 2])[t,c0,d]+(Subscript[er, 2])[0,c0,d]==0&&D[(Subscript[er, 2])[t,c0,d],t]==0&&0<t<1&&d>0,{d,t},Reals][[1]];
edC=(Subscript[e, 2])[1,c0,dC];
edE=Max[Abs[(Subscript[e, 2])[1,c0,dE]],Abs[(Subscript[e, 2])[0,c0,dE]]];
erdC=Max[Map[Abs[(Subscript[er, 2])[t/.#,c0,dC]]&,Solve[D[(Subscript[er, 2])[t,c0,dC],t]==0&&0<=t<1,t]]];
erdE=(Subscript[er, 2])[0,c0,dE];AppendTo[(Subscript[sez, 2]),{φ0,N[dC,6],ScientificForm[edC,6],ScientificForm[erdC,6],N[dE,6],ScientificForm[edE,6],ScientificForm[erdE,6]}]];

Grid[(Subscript[sez, 2]),Frame->All]

4. Cubic (G^1) approximants

Definitions

n=3;
(Subscript[b, 3,0])={c,-(Sqrt[1-(c^2)])};(Subscript[b, 3,1])={c,-(Sqrt[1-(c^2)])}+d{1-(c^2),c(Sqrt[1-(c^2)])};
(Subscript[b, 3,2])={c,(Sqrt[1-(c^2)])}+d{1-(c^2),-c(Sqrt[1-(c^2)])};(Subscript[b, 3,3])={c,(Sqrt[1-(c^2)])};
(Subscript[p, n])[t_,c_,d_]=Sum[(Subscript[b, n,j])(Subscript[B, n,j])[t],{j,0,n}];
(Subscript[er, n])[t_,c_,d_]=(Sqrt[(((Subscript[p, n])[t,c,d][[1]])^2)+(((Subscript[p, n])[t,c,d][[2]])^2)])-1//FullSimplify;
(Subscript[e, n])[t_,c_,d_]=1-(1/(Sqrt[(((((D[(Subscript[p, n])[t,c,d][[1]],t])^2)+((D[(Subscript[p, n])[t,c,d][[2]],t])^2)))^3)]))(D[(Subscript[p, n])[t,c,d][[1]],t]*D[(Subscript[p, n])[t,c,d][[2]],{t,2}]-D[(Subscript[p, n])[t,c,d][[2]],t]*D[(Subscript[p, n])[t,c,d][[1]],{t,2}])//Simplify;

Auxiliary calculations

f[t_,c_,d_]=(8/3)d(c d-2+(3c d-2)(t^2));
g[t_,c_,d_]=((((2-c d))^2)+2(d(2d+c(8-5c d))-4)(t^2)+(((2-3c d))^2)(t^4));
Assuming[0<c<1,(Subscript[e, 3])[t,c,d]-(1+((f[t,c,d])/(Sqrt[((g[t,c,d])^3)])))//Simplify]

The function (Subscript[e, 3])(0,c,.) is strictly increasing and the function (Subscript[e, 3])(1,c,.) is strictly decreasing

Assuming[0<c<1,(Subscript[e, 3])[0,c,d]-(1-((8 d (2-c d))/(3 (Sqrt[(((2-c d))^6)]))))//Simplify]

Assuming[0<c<1&&d>0,(Subscript[e, 3])[1,c,d]-(1-((4(1-c d))/(3 (d^2))))//Simplify]

de[c_]=((5(c^2)+(5(Sqrt[3])-(Sqrt[27+(c^3)]))((((Sqrt[27+(c^3)])+3(Sqrt[3])))^(1/3))-(5(Sqrt[3])+(Sqrt[27+(c^3)]))((((Sqrt[27+(c^3)])-3(Sqrt[3])))^(1/3)))/(3(2+(c^3))));

Assuming[0<c<1,1-((8 d )/(3 (((2-c d))^2)))-((-4+4 c d+3 (d^2))/(3 (d^2)))/.d->de[c]//FullSimplify]

Example 4.1

de[(1/2)]-(2/51)(5-(383/(((12671+408(Sqrt[1302])))^(1/3)))+(((12671+408(Sqrt[1302])))^(1/3)))//FullSimplify

de[(1/2)]//N

(Subscript[e, 3])[0,(1/2),de[(1/2)]]-(1/36)(38-(193/(((14113-384(Sqrt[1302])))^(1/3)))-(((14113-384(Sqrt[1302])))^(1/3)))//FullSimplify

(Subscript[e, 3])[0,(1/2),de[(1/2)]]//N

Plot[(Subscript[e, 3])[t,(1/2),de[(1/2)]],{t,-1,1},GridLines->{{},{-(Subscript[e, 3])[0,(1/2),de[(1/2)]],(Subscript[e, 3])[0,(1/2),de[(1/2)]]}}]

Example 4.2

de[0]

de[0]//N

(Subscript[e, 3])[0,0,de[0]]//Simplify

(Subscript[e, 3])[0,0,de[0]]//N

(Subscript[e, 3])[1,0,((2(Sqrt[3]))/3)]

(Subscript[e, 3])[0,0,(3/2)]

Solve[D[(Subscript[e, 3])[t,0,d],t]==0,t]

(Subscript[e, 3])[((Sqrt[-4-(d^2)+(Sqrt[144-40 (d^2)+(d^4)])])/(2 (Sqrt[2]))),0,d]-(1-((32 (Sqrt[2])d (4-(d^2)+(Sqrt[144-40(d^2)+(d^4)])))/(9 (Sqrt[3(((4-(d^2)))^3) (((12+(d^2)-(Sqrt[144-40 (d^2)+(d^4)])))^3)]))))//Simplify

The function min (Subscript[e, 3])(.,c,d) is strictly increasing on (0,(3/2))

f1= (82944+29952 (d^2)-3200 (d^4)-800 (d^6)+132 (d^8)-3 (d^10)+(Sqrt[144-40 (d^2)+(d^4)]) (6912+3456 (d^2)+256 (d^4)+72 (d^6)-3 (d^8)));
f2=(Sqrt[144-40 (d^2)+(d^4)]) (144+8 (d^2)+(d^4))-(((12-(d^2)))^2) (12+(d^2));
D[1-((32 (Sqrt[2])d (4-(d^2)+(Sqrt[144-40(d^2)+(d^4)])))/(9 (Sqrt[3(((4-(d^2)))^3) (((12+(d^2)-(Sqrt[144-40 (d^2)+(d^4)])))^3)]))),d]-((8388608 (Sqrt[2]) (((4-(d^2)))^3)(d^6) (36-(d^2))(4-(Sqrt[3])(d^2))(4+(Sqrt[3]) (d^2)))/(f1(9 (Sqrt[3])(Sqrt[144-40 (d^2)+(d^4)]) ((((((-4+(d^2)))^3) f2))^(3/2)))))//Simplify

dE=d/.NSolve[(Subscript[e, 3])[1,0,d]==-(Subscript[e, 3])[((Sqrt[-4-(d^2)+(Sqrt[144-40 (d^2)+(d^4)])])/(2 (Sqrt[2]))),0,d]&&((2(Sqrt[3]))/3)<d<(3/2),d][[1]]

Plot[{(Subscript[e, 3])[t,0,dE],(Subscript[e, 3])[t,0,de[0]]},{t,-1,1},GridLines->{{},{-(Subscript[e, 3])[1,0,dE],(Subscript[e, 3])[1,0,dE]}},PlotStyle->{Black,{Black,Dotted}}]

More auxiliary calculations

D[(Subscript[e, 3])[t,c,d],t]//Simplify

Solve[3 c (d^3) (1+(t^2))-2 (d^2) (3+(t^2))-8 (-2+(t^2)+(t^4))+3 (c^3) (d^3) (-3+2 (t^2)+9 (t^4))+4 c d (-10+7 (t^2)+9 (t^4))-2 (c^2) (d^2) (-17+14 (t^2)+27 (t^4))==0,t]//Simplify

location of local exstrema

tm[c_,d_]=Assuming[0<c d<(2/3),((Sqrt[((-4+8 c d-(d^2)-2 (c^2) (d^2)+(Sqrt[144-40 (d^2)-512 (c^3) (d^3)+(d^4)+112 (c^4) (d^4)-32 (c^2) (d^2) (-26+(d^2))+16 c d (-36+5 (d^2))]))/(((2-3 c d))^2))])/(Sqrt[2]))//FullSimplify];

Plot[(Subscript[e, 3])[0,c,de[c]]+(Subscript[e, 3])[tm[c,de[c]],c,de[c]],{c,0,1}]

FindRoot[(Subscript[e, 3])[0,c,de[c]]+(Subscript[e, 3])[tm[c,de[c]],c,de[c]]==0,{c,0.3}]

(2/π) *ArcCos[0.32791842211649475`]

Bounds for the optimal parameter

d1[c_]=(2/3)+(1/3)(1-c)+(1/24)(((1-c))^2);
d2[c_]=(2/3)+(1/3)(1-c)+(1/6)(((1-c))^2)+(101/1152)(((1-c))^3)+(25/512)(((1-c))^4);

Plot[{de[c],d1[c],d2[c]},{c,0,1}]

Examples for c=((Sqrt[2])/2) and c=0

c1=Cos[(π/4)];
c2=Cos[(π/2)];
GraphicsRow[{Plot[{(Subscript[e, 3])[t,c1,de[c1]],(Subscript[e, 3])[t,c1,d1[c1]],(Subscript[e, 3])[t,c1,d2[c1]]},{t,-1,1},PlotStyle->{Black,{Black,Dashed},{Black,Dotted}},GridLines->{{},{-(Subscript[e, 3])[0,c1,de[c1]],(Subscript[e, 3])[0,c1,de[c1]]}}],
Plot[{(Subscript[e, 3])[t,c2,de[c2]],(Subscript[e, 3])[t,c2,d1[c2]],(Subscript[e, 3])[t,c2,d2[c2]]},{t,-1,1},PlotStyle->{Black,{Black,Dashed},{Black,Dotted}},GridLines->{{},{-(Subscript[e, 3])[0,c2,de[c2]],(Subscript[e, 3])[0,c2,de[c2]]}}]}]

Lemma 4.3  Part 1

h[c_]=(2/(3c))-d2[c];

CoefficientList[(c^2)D[h[c],c],c]

Map[#<0&,BasisChange[Simplify[(c^2)D[h[c],c]],c]]

h[1]

Lemma 4.3  Part 2

h[d_]=4-8 c d+(d^2)+2 (c^2) (d^2);

h[d]==(2(c^2)+1)(((d-((4c)/(2(c^2)+1))))^2)+((4-8(c^2))/(2(c^2)+1))//Simplify

c ∈(0,(1/2))

h[((4c)/(2(c^2)+1))]//Simplify

c ∈((1/2),1)

D[h[d],d]==-(2+4(c^2))((2/(3c))-d)-(4/(3c))(4(c^2)-1)//Simplify

h[(2/(3c))]//Simplify

Lemma 4.3  Part 3

h1[c_,d_]=-1044(c^3)(d^3)+5288(c^2)(d^2)+1275c (d^3)-7892c d-2100(d^2)+3776;
h2[c_,d_]=8d-24c+48(c^2)d-6c (d^2)-24(c^3)(d^2);

Assuming[0<c<1,(D[(Subscript[e, 3])[t,c,d],t]/.t->(3/5))-((-6250d h1[c,d](((-224(c^2)(d^2)+32c d+225(d^2)+256))^2))/((((((-224(c^2)(d^2)+32c d+225(d^2)+256))^3)))^(3/2)))//Simplify]

Assuming[0<c<1&&d>0,(D[(Subscript[e, 3])[t,c,d],t]/.t->1)-((h2[c,d])/(3(d^3)))//Simplify]

x=Simplify[h1[c,(1-δ)d1[c]+δ d2[c]]];
xc=BasisChange[x,δ];
OK={};
Print["The bidegree of h1((1-δ)d1[c]+δ d2[c]) as the polynomial of variables (c,δ) is (",Length[CoefficientList[x,c]]-1,",",Length[xc]-1,")."];
For[i=0,i<Length[xc],i++,
OK=Union[OK,Map[#>=0&,BasisChange[xc[[i+1]],c,15]]]]
Print[OK]

x=Simplify[h2[c,(1-δ)d1[c]+δ d2[c]]];
xc=BasisChange[x,δ];
OK={};
Print["The bidegree of h2((1-δ)d1[c]+δ d2[c]) as the polynomial of variables (c,δ) is (",Length[CoefficientList[x,c]]-1,",",Length[xc]-1,")."];
For[i=0,i<Length[xc],i++,
OK=Union[OK,Map[#>=0&,BasisChange[xc[[i+1]],c,15]]]]
Print[OK]

Lemma 4.3  Part 4

h[t_,c_,d_]=Simplify[D[f[t,c,d],d]*g[t,c,d]-(3/2)f[t,c,d]*D[g[t,c,d],d]];

x=Simplify[h[((3+2τ)/5),c,(1-δ)d1[c]+δ d2[c]]];
Print["The multidegree of h(((3 + 2  τ)/5),(1-δ)d1(c)+δ d2(c)) as the polynomial of variables (c,τ,δ) is (",Length[CoefficientList[x,c]]-1,",",Length[CoefficientList[x,τ]]-1,",",Length[CoefficientList[x,δ]]-1,")."];
xδ=BasisChange[x,δ,3];
OK={};
For[i=0,i<=3,i++,
xδτ=BasisChange[xδ[[i+1]],τ,6];
For[j=0,j<=6,j++,
OK=Union[OK,Map[#>=0&,BasisChange[xδτ[[j+1]],c,15]]]]];
Print[OK]

Lemma 4.4

x=Assuming[0<c<1,(((((5-c))^4)(((48-25c+10(c^2)-(c^3)))^2))/(32(((1-c))^2)))((Subscript[e, 3])[0,c,d1[c]]-(Subscript[e, 3])[1,c,d1[c]])//Simplify];
Print["The degree of (((((5 - c))^4) (((48 - 25  c + 10 (c^2) - (c^3)))^2))/(32 (((1 - c))^2)))((Subscript[e, 3])(0,(Subscript[d, 1])(c))-(Subscript[e, 3])(1,(Subscript[d, 1])(c))) is ",Length[CoefficientList[x,c]]-1,"."];
Map[#>=0&,BasisChange[x,c,7]]

x=Assuming[0<c<1,(((((6005−5184c+3330(c^2)−1304(c^3)+225(c^4)))^2)(((9216−6005c+5184(c^2)−3330(c^3)+1304(c^4)−225(c^5)))^2))/(6144(((1-c))^2)))((Subscript[e, 3])[1,c,d2[c]]-(Subscript[e, 3])[0,c,d2[c]])//Simplify];
Print["The degree of (((((6005 − 5184  c + 3330 (c^2) − 1304 (c^3) + 225 (c^4)))^2) (((9216 − 6005  c + 5184 (c^2) − 3330 (c^3) + 1304 (c^4) − 225 (c^5)))^2))/(6144 (((1 - c))^2)))((Subscript[e, 3])(1,(Subscript[d, 2])(c))-(Subscript[e, 3])(0,(Subscript[d, 2])(c))) is ",Length[CoefficientList[x,c]]-1,"."];
Map[#>=0&,BasisChange[x,c,13]]

x=Assuming[0<c<1,(((((5-c))^4)(((6005−5184c+3330(c^2)−1304(c^3)+225(c^4)))^2))/(2(((1-c))^2)))((Subscript[e, 3])[1,c,d1[c]]+(Subscript[e, 3])[1,c,d2[c]])//Simplify];
Print["The degree of (((((5 - c))^4) (((6005 − 5184  c + 3330 (c^2) − 1304 (c^3) + 225 (c^4)))^2))/(2 (((1 - c))^2))) ((Subscript[e, 3])(1,(Subscript[d, 1])(c))+(Subscript[e, 3])(1,(Subscript[d, 2])(c))) is ",Length[CoefficientList[x,c]]-1,"."];
Map[#<0&,BasisChange[x,c,10]]

Calculation for arbitrary angle φ

Blue curve is optimal interpolant with respect to the curvature error function and orange one the optimal one with respect to the radial error function.
On the middle there are graphs of the radial error functions of both interpolant and on the right there are graphs of the curvature error functions of the interpolants.

φ0=(π/2);
c0=N[Cos[φ0]];If[(Subscript[e, 3])[1,c0,de[c0]]>=-(Subscript[e, 3])[tm[c0,de[c0]],c0,de[c0]],dC=de[c0],
dC=d/.FindRoot[(Subscript[e, 3])[tm[c0,d],c0,d]+(Subscript[e, 3])[1,c0,d]==0,{d,de[c0]}]]
dE=d/.NSolve[(Subscript[er, 3])[t,c0,d]+(Subscript[er, 3])[0,c0,d]==0&&D[(Subscript[er, 3])[t,c0,d],t]==0&&0<t<0.9&&d>0,{d,t},Reals][[1]];
tocke={(Subscript[b, 3,0]),(Subscript[b, 3,1]),(Subscript[b, 3,2]),(Subscript[b, 3,3])}/.{c->c0,d->dC};GraphicsRow[{Show[ParametricPlot[{(Subscript[p, 3])[t,c0,dC],(Subscript[p, 3])[t,c0,dE],{Cos[φ0 t],Sin[φ0 t]}},{t,-1,1},PlotStyle->{ , , Red},Ticks->{{0,0.5,1,1.5},{-1,-0.5,0,0.5,1}}],
ListPlot[tocke,PlotStyle->{PointSize[0.02],Black}],Graphics[{Black,Line[tocke]}],AspectRatio->Automatic,PlotRange->All],
Plot[{(Subscript[er, 3])[t,c0,dC],(Subscript[er, 3])[t,c0,dE]},{t,-1,1}],
Plot[{(Subscript[e, 3])[t,c0,dC],(Subscript[e, 3])[t,c0,dE]},{t,-1,1},GridLines->{{},{(Subscript[e, 3])[1,c0,dC],-(Subscript[e, 3])[1,c0,dC]}}]}]

A table of best interpolants with corresponding errors

angles={(π/2),(π/3),(π/4),(π/6),(π/8),(π/12)};
n=3;
(Subscript[sez, n])={{"φ","(SuperStar[d])","curvature error","radial error","(d^r)","curvature error","radial error"}};
For[i=1,i≤Length[angles],i++,
φ0=angles[[i]];
c0=N[Cos[φ0]];
If[(Subscript[e, 3])[1,c0,de[c0]]>=-(Subscript[e, 3])[tm[c0,de[c0]],c0,de[c0]],dC=de[c0],
dC=d/.FindRoot[(Subscript[e, n])[tm[c0,d],c0,d]+(Subscript[e, n])[1,c0,d]==0,{d,de[c0]}]];
dE=d/.NSolve[(Subscript[er, n])[t,c0,d]+(Subscript[er, n])[0,c0,d]==0&&D[(Subscript[er, 3])[t,c0,d],t]==0&&0<t<0.9&&d>0,{d,t},Reals][[1]];
edC=(Subscript[e, n])[1,c0,dC];
edE=Max[Abs[(Subscript[e, n])[1,c0,dE]],Abs[(Subscript[e, n])[0,c0,dE]]];
(*erdC=Max[Map[Abs[(Subscript[er, n])[t/.#,c0,dC]]&,Solve[D[(Subscript[er, n])[t,c0,dC],t]==0&&0<=t<1,t]]];*);
erdC=-(Subscript[er, n])[0,c0,dC];
erdE=-(Subscript[er, n])[0,c0,dE];AppendTo[(Subscript[sez, n]),{φ0,N[dC,6],ScientificForm[edC,6],ScientificForm[erdC,6],N[dE,6],ScientificForm[edE,6],ScientificForm[erdE,6]}]];

Grid[(Subscript[sez, n]),Frame->All]

5. Quartic (G^2) approximants

Case c=0

Definitions

n=4;
(Subscript[b, n,0])={0,-1};(Subscript[b, n,1])={((Sqrt[3])/2),-1};(Subscript[b, n,2])={d,0};
(Subscript[b, n,3])={((Sqrt[3])/2),1};(Subscript[b, n,4])={0,1};
(Subscript[p, n])[t_,0,d_]=Sum[(Subscript[b, n,j])(Subscript[B, n,j])[t],{j,0,n}];
(Subscript[er, n])[t_,0,d_]=(Sqrt[(((Subscript[p, n])[t,0,d][[1]])^2)+(((Subscript[p, n])[t,0,d][[2]])^2)])-1//FullSimplify;
(Subscript[e, n])[t_,0,d_]=1-(1/(Sqrt[(((((D[(Subscript[p, n])[t,0,d][[1]],t])^2)+((D[(Subscript[p, n])[t,0,d][[2]],t])^2)))^3)]))(D[(Subscript[p, n])[t,0,d][[1]],t]*D[(Subscript[p, n])[t,0,d][[2]],{t,2}]-D[(Subscript[p, n])[t,0,d][[2]],t]*D[(Subscript[p, n])[t,0,d][[1]],{t,2}])//Simplify;

Auxiliary calculations

f[t_,0,d_]=2(2(t^2)(3-(t^2))+(Sqrt[3])d(((1-(t^2)))^2));
g[t_,0,d_]=3-3(2-(d^2))(t^2)+(3+4(Sqrt[3])d-6(d^2))(t^4)+(4-4(Sqrt[3])d+3(d^2))(t^6);

(Subscript[e, 4])[t,0,d]==(1-((f[t,0,d])/(Sqrt[((g[t,0,d])^3)])))//Simplify

(Subscript[e, 4])(0,.) is stricktly decreasing

(Subscript[e, 4])[0,0,d]

The functions (Subscript[e, 4])(.,(3/2)) and (Subscript[e, 4])(.,((8(Sqrt[3]))/9))

Plot[{(Subscript[e, 4])[t,0,(3/2)],(Subscript[e, 4])[t,0,((8(Sqrt[3]))/9)]},{t,-1,1},PlotStyle->{Black,{Black,Dashed}}]

(Subscript[e, 4])[0,0,(3/2)]

D[(Subscript[e, 4])[t,0,((8(Sqrt[3]))/9)],t]/.t->1

h[t_,d_]=-Simplify[D[f[t,0,d],d]*g[t,0,d]-(3/2)f[t,0,d]*D[g[t,0,d],d]];

D[(Subscript[e, 4])[t,0,d],d]-((h[t,d])/(g[t,0,d](Sqrt[((g[t,0,d])^3)])))//Simplify

h((1-τ)(3/5)+τ,((8(Sqrt[3]))/9)δ) has positive coefficients

x=Simplify[h[(1-τ)(3/5)+τ,((8(Sqrt[3]))/9)δ]];
xc=BasisChange[x,δ];
OK={};
Print["The bidegree of h((1-τ)(3/5)+τ,((8 (Sqrt[3]))/9)δ) as the polynomial of variables (τ,δ) is (",Length[CoefficientList[x,τ]]-1,",",Length[xc]-1,")."];
For[i=0,i<Length[xc],i++,
OK=Union[OK,Map[#>=0&,BasisChange[xc[[i+1]],τ,10]]]]
Print[OK]

Grröbner basis

PolynomialRemainder[(((((2d)/3)))^2)((g[t,0,d])^3)-((f[t,0,d])^2),t,t]
PolynomialRemainder[D[f[t,0,d],t]*g[t,0,d]-(3/2)f[t,0,d]*D[g[t,0,d],t],t,t]

res=Resultant[PolynomialQuotient[(((((2d)/3)))^2)((g[t,0,d])^3)-((f[t,0,d])^2),t,t],PolynomialQuotient[D[f[t,0,d],t]*g[t,0,d]-(3/2)f[t,0,d]*D[g[t,0,d],t],t,t],t];

res1[d_]=-2054269543278182400000 (Sqrt[3])+38346364807859404800000 d+78471829192174537638150144 (Sqrt[3]) (d^2)-1482047320196939157709258752 (d^3)+4054625268340760713082437632 (Sqrt[3]) (d^4)-19388705851864098265060343808 (d^5)+20433845591558825561976471552 (Sqrt[3]) (d^6)-46067629052482854461997318144 (d^7)+26144725183646992953212141568 (Sqrt[3]) (d^8)-35498244215204406183686307840 (d^9)+13541360174918596851274874880 (Sqrt[3]) (d^10)-13677436123545387715604250624 (d^11)+4158952973101843449529761792 (Sqrt[3]) (d^12)-3442351706928551250987319296 (d^13)+863779472023350453794242560 (Sqrt[3]) (d^14)-592799931032181400110366720 (d^15)+123532492721640419239133184 (Sqrt[3]) (d^16)-70117553381868096247037952 (d^17)+11788811976775986000691200 (Sqrt[3]) (d^18)-5106568309940036862738432 (d^19)+642634018734008017354752 (Sqrt[3]) (d^20)-207023039592163656597504 (d^21)+12938939974510228537344 (Sqrt[3]) (d^22);
res2[d_]=72+12 (Sqrt[3])d-18 (Sqrt[3])(d^3);
res3[d_]=30-18(Sqrt[3])d+6(d^2)-2(Sqrt[3])(d^3)+3(d^4) ;

res-(1/43046721)(((d-(2/(Sqrt[3]))))^18)((res1[d])^2)((res2[d])^3)((res3[d])^4)//Simplify

Solve[res2[d]==0&&d>(3/2),d,Reals]

Solve[res3[d]==0,d,Reals]

The optimal parameter

φ0=(π/2);
c0=0;
dC=d/.Solve[res1[d]==0&&(3/2)<d<((8(Sqrt[3]))/9),d,Reals][[1]];
dE=d/.FindRoot[(Subscript[er, 4])[t,c0,d]+(Subscript[er, 4])[0,c0,d]==0&&D[(Subscript[er, 4])[t,c0,d],t]==0,{{d,dC},{t,0.5}}];
tocke={(Subscript[b, 4,0]),(Subscript[b, 4,1]),(Subscript[b, 4,2]),(Subscript[b, 4,3]),(Subscript[b, 4,4])}/.{c->c0,d->dC};GraphicsRow[{Show[ParametricPlot[{(Subscript[p, 4])[t,c0,dC],(Subscript[p, 4])[t,c0,dE],{Cos[φ0 t],Sin[φ0 t]}},{t,-1,1},PlotStyle->{ , ,{Thickness[0.003],Red}},Ticks->{{0,0.5,1,1.5},{-1,-0.5,0,0.5,1}}],
ListPlot[tocke,PlotStyle->{PointSize[0.02],Black}],Graphics[{Black,Line[tocke]}],AspectRatio->Automatic,PlotRange->All],
Plot[{(Subscript[er, 4])[t,c0,dC],(Subscript[er, 4])[t,c0,dE]},{t,-1,1}],
Plot[{(Subscript[e, 4])[t,c0,dC],(Subscript[e, 4])[t,c0,dE]},{t,-1,1},GridLines->{{},{(Subscript[e, 4])[0,c0,dC],-(Subscript[e, 4])[0,c0,dC]}}]}]

Case c>0

Definitions

n=4;
(Subscript[b, 4,0])={c,-(Sqrt[1-(c^2)])};(Subscript[b, 4,1])={c,-(Sqrt[1-(c^2)])}+d{1-(c^2),c(Sqrt[1-(c^2)])};
(Subscript[b, 4,2])={((3-4(d^2)(1-(c^2)))/(3c)),0};
(Subscript[b, 4,3])={c,(Sqrt[1-(c^2)])}+d{1-(c^2),-c(Sqrt[1-(c^2)])};(Subscript[b, 4,4])={c,(Sqrt[1-(c^2)])};
(Subscript[p, n])[t_,c_,d_]=Sum[(Subscript[b, n,j])(Subscript[B, n,j])[t],{j,0,n}];
(Subscript[er, n])[t_,c_,d_]=(Sqrt[(((Subscript[p, n])[t,c,d][[1]])^2)+(((Subscript[p, n])[t,c,d][[2]])^2)])-1//Simplify;
(Subscript[e, n])[t_,c_,d_]=1-(1/(Sqrt[(((((D[(Subscript[p, n])[t,c,d][[1]],t])^2)+((D[(Subscript[p, n])[t,c,d][[2]],t])^2)))^3)]))(D[(Subscript[p, n])[t,c,d][[1]],t]*D[(Subscript[p, n])[t,c,d][[2]],{t,2}]-D[(Subscript[p, n])[t,c,d][[2]],t]*D[(Subscript[p, n])[t,c,d][[1]],{t,2}])//Simplify;

Auxiliary calculations

f[t_,c_,d_]=2(c^2)(3(3-4(d^2))(((1-(t^2)))^2)+8c (d^3)(1+3(t^4))-6c d(1-(t^2))(1-(5-4 c d)(t^2)));
g[t_,c_,d_]=(1-(c^2))(t^2)(((4c d (t^2)+(3-4(d^2))(1-(t^2))))^2)+(c^2) (((2+(1-2 c d) (1-3 (t^2))))^2);
Assuming[0<c<1,(Subscript[e, 4])[t,c,d]-(1-(((((1-(c^2)))^(3/2)) f[t,c,d])/((c^3)(Sqrt[((((1/(c^2))(1-(c^2))g[t,c,d]))^3)]))))//Simplify]

Solve[(Subscript[e, 4])[0,c,d]==0,d]

d1[c_]=(1/(192((c^3)+2)))(192(Sqrt[3])-8(16+9(Sqrt[3]))c+(144+37(Sqrt[3]))(c^2)+3(592+232(Sqrt[2])-533(Sqrt[3]))(c^3)-(2608+1104(Sqrt[2])-2415(Sqrt[3]))(c^4)+(1104+408(Sqrt[2])-973(Sqrt[3]))(c^5));
d2[c_]=(1/(120((c^3)+2)))(120(Sqrt[3])-8(4+9(Sqrt[3]))c+(144-11(Sqrt[3]))(c^2)+(444+588(Sqrt[2])-735(Sqrt[3]))(c^3)-(652+996(Sqrt[2])-1191(Sqrt[3]))(c^4)+(276+408(Sqrt[2])-493(Sqrt[3]))(c^5));
d0[c_]=((1+(Sqrt[2]))/2)c-((Sqrt[2])/2);
d3[c_]=((1-(Sqrt[3]))/2)(c-1)+(1/2);

Plot[{d0[c],(c/2),d1[c],d2[c],((3 (c^2)+(Sqrt[6]) (Sqrt[2+c])(1-c))/(2 (2+(c^3)))),d3[c],(3/(2c))},{c,0,1}]

Plot[d2[c]-d1[c],{c,0,1}]

Lemma 5.1 Part 1

Assuming[0<c<1&&d<(3/(2c)),D[(Subscript[e, 4])[0,c,d],d]==((24(c-2d))/(c(((2c d-3))^3)))//Simplify]

Lemma 5.1 Part 2

h[t_,c_,d_]=Simplify[D[f[t,c,d],d]*g[t,c,d]-(3/2)f[t,c,d]*D[g[t,c,d],d]];

x=Together[((((2+(c^3)))^6)/(c^4))h[(1-τ)(9/20)+τ,c,(1-δ)d1[c]+δ d2[c]]];
xc=BasisChange[x,δ];
OK={};
Print["The multidegree of ((((2 + (c^3)))^6)/(c^4))h((1-τ)(9/20)+τ,c,(1-δ)(Subscript[d, 1])(c)+δ (Subscript[d, 2])(c)) as the polynomial of variables (c,τ,δ) is (",Length[CoefficientList[x,c]]-1,",",Length[CoefficientList[x,τ]]-1,",",Length[xc]-1,")."];
For[i=0,i<=6,i++,
xd=BasisChange[xc[[i+1]],τ,10];
For[j=0,j<=10,j++,
OK=Union[OK,Map[#>=0&,BasisChange[xd[[j+1]],c,31]]]]]
Print[OK]

Lemma 5.1 Part 3

(((d^2)h)/(dt^2))(t,d)>0 for all (t,d)∈(0,1)×((Subscript[d, 1])(c),(Subscript[d, 2])(c))

h[t_,c_,d_]=3 ((((3-4 (d^2)))^3) (((1-t))^3) (3-5 t)+64 (c^6) (d^4) (((1-t))^2) (1+3 t-10 (t^2))-2 c d (((3-4 (d^2)))^2) (1-t) (3-39 t+81 (t^2)-45 (t^3)-4 (d^2) (1-3 t-(t^2)-5 (t^3)))-16 (c^5) (d^3) (1-t) (9+44 t-163 (t^2)+110 (t^3)+4 (d^2) (3-4 t+15 (t^2)-30 (t^3)))-(c^2) (3-4 (d^2)) (45 (((1-t))^4)-24 (d^2) (((-1+t))^2) (3-13 t+30 (t^2))+16 (d^4) (3-24 t+50 (t^2)-48 (t^3)+35 (t^4)))-8 (c^4) (3 (d^2) (((1-t))^2) (1-60 t+75 (t^2))+16 (d^6) t (-5+13 t-15 (t^2)+15 (t^3))-4 (d^4) (19-67 t+165 (t^2)-265 (t^3)+140 (t^4)))-2 (c^3) (9 d (((1-t))^3) (-13+45 t)+64 (d^7) (1-4 t+2 (t^2)-4 (t^3)+5 (t^4))-16 (d^5) (9-66 t+176 (t^2)-222 (t^3)+135 (t^4))+4 (d^3) (93-402 t+972 (t^2)-1230 (t^3)+535 (t^4))));

Simplify[D[-((f[(Sqrt[t]),c,d])/(Sqrt[((g[(Sqrt[t]),c,d])^3)])),t]]-(((c^2)h[t,c,d])/(g[(Sqrt[t]),c,d](Sqrt[((g[(Sqrt[t]),c,d])^3)])))//Simplify

x=Numerator[Together[D[h[t,c,(1-δ)d1[c]+δ d2[c]],{t,2}]]];
xc=BasisChange[x,δ];
OK={};
Print["The multidegree of (2+(c^3))^7h(t,c,(1-δ)(Subscript[d, 1])(c)+δ (Subscript[d, 2])(c)) as the polynomial of variables (c,τ,δ) is (",Length[CoefficientList[x,c]]-1,",",Length[CoefficientList[x,t]]-1,",",Length[xc]-1,")."];
For[i=0,i<=7,i++,
xd=BasisChange[xc[[i+1]],t,7];
For[j=0,j<=2,j++,
OK=Union[OK,Map[#>=0&,BasisChange[xd[[j+1]],c,38]]]]]
Print[OK]

(Subscript[e, 4])(0.45,d)>0 for all d∈(Subscript[I, c])

x=Numerator[Together[((g[(9/20),c,d2[c]])^3)-((f[(9/20),c,d2[c]])^2)]];
Denominator[Together[((g[(9/20),c,d2[c]])^3)-((f[(9/20),c,d2[c]])^2)]]
Print["The degree of g((9/20),c,(Subscript[d, 2])(c))^3-f((9/20),c,(Subscript[d, 2])(c))^2 as the polynomial of variable c is ",Length[CoefficientList[x,c]]-1,"."];
Print[Union[Map[#>=0&,BasisChange[x,c,66]]]]

(Subscript[e, 4])(0.9,d)<0 for all d∈(Subscript[I, c])

x=Numerator[Together[f[(9/10),c,d1[c]]]];
Denominator[Together[f[(9/10),c,d1[c]]]]
Print["The degree of f((9/10),c,(Subscript[d, 1])(c)) as the polynomial of variable c is ",Length[CoefficientList[x,c]]-1,"."];
Print[Union[Map[#>=0&,BasisChange[x,c,18]]]]

x=Numerator[Together[((f[(9/10),c,d1[c]])^2)-((g[(9/10),c,d1[c]])^3)]];
Denominator[Together[((f[(9/10),c,d1[c]])^2)-((g[(9/10),c,d1[c]])^3)]]
Print["The degree of f((9/10),c,(Subscript[d, 1])(c))^2-g((9/10),c,(Subscript[d, 1])(c))^3 as the polynomial of variable c is ",Length[CoefficientList[x,c]]-1,"."];
Print[Union[Map[#>=0&,BasisChange[x,c,66]]]]

((Subscript[de, 4])/dt)(0.45,d)<0 for all d∈(Subscript[I, c])

x=Together[-(D[f[t,c,d],t]*g[t,c,d]-(3/2)f[t,c,d]*D[g[t,c,d],t])/.{t->(9/20),d->(1-δ)d1[c]+δ d2[c]}];
Denominator[x]
x=Numerator[x];
xc=BasisChange[Simplify[(x/(c^5))],δ];
OK={};
Print["The multidegree of (2+(c^3))^7h((9/20),c,(1-δ)(Subscript[d, 1])(c)+δ (Subscript[d, 2])(c)) as the polynomial of variables (c,δ) is (",Length[CoefficientList[(x/(c^5)),c]]-1,",",Length[xc]-1,")."];
For[j=0,j<=7,j++,
OK=Union[OK,Map[#>=0&,BasisChange[xc[[j+1]],c,35]]]]
Print[OK]

Figure 8

c1=0.1;
dd1=d/.FindRoot[{D[(Subscript[e, 4])[t,c1,d],t]==0,(Subscript[e, 4])[t,c1,d]==(Subscript[e, 4])[0,c1,d]},{{t,0.9},{d,0.8}}];
c2=0.5;
dd2=d/.FindRoot[{D[(Subscript[e, 4])[t,c2,d],t]==0,(Subscript[e, 4])[t,c2,d]==(Subscript[e, 4])[0,c2,d]},{{t,0.9},{d,0.6}}];
{tt3,dd3}={t,d}/.FindRoot[{D[(Subscript[e, 4])[t,c2,d],t]==0,D[(Subscript[e, 4])[t1,c2,d],t1]==0,(Subscript[e, 4])[t,c2,d]==-(Subscript[e, 4])[t1,c2,d]},{{t,0.9},{t1,0.5},{d,0.6}}];
GraphicsRow[{Plot[(Subscript[e, 4])[t,c1,dd1],{t,-1,1},PlotStyle->Black,GridLines->{{},{(Subscript[e, 4])[0,c1,dd1],-(Subscript[e, 4])[0,c1,dd1]}}],Plot[{(Subscript[e, 4])[t,c2,dd2],(Subscript[e, 4])[t,c2,dd3]},{t,-1,1},PlotStyle->{{Black,Dotted},Black},GridLines->{{},{(Subscript[e, 4])[tt3,c2,dd3],-(Subscript[e, 4])[tt3,c2,dd3]}}]}]

Lemma 5.2 Part 1

(Subscript[e, 4])(0,(Subscript[d, 1])(c))+(Subscript[e, 4])(t,(Subscript[d, 1])(c))<=0 for all t∈[0.45,1]

x=Together[f[((55τ+45)/100),c,d1[c]]];
Denominator[x]
x=Numerator[x];
xc=BasisChange[Simplify[(x/(c^3))],τ];
OK={};
Print["The multidegree of ((((2 + (c^3)))^3)/(c^3))f(((55  τ + 45)/100),c,(Subscript[d, 1])(c)) as the polynomial of variables (c,τ) is (",Length[CoefficientList[(x/(c^3)),c]]-1,",",Length[xc]-1,")."];
For[j=0,j<=4,j++,
OK=Union[OK,Map[#>=0&,BasisChange[xc[[j+1]],c,15]]]]
Print[OK]

ee4[c_,d_]=1-((6-8 (d^2))/(c (((3-2 c d))^2)));
Refine[Simplify[(Subscript[e, 4])[0,c,d]],d<(3/(2c))&&0<c<1]==ee4[c,d]//Simplify

xx=Together[((f[t,c,d1[c]])^2)-(((1+ee4[c,d1[c]]))^2)((g[t,c,d1[c]])^3)];

Denominator[xx]==153177439332441840943104 (((2+(c^3)))^16)(96^4) (((3-2c d1[c]))^4)//Simplify

PolynomialRemainder[Numerator[xx],(c^6)(((1-c))^3),c]

x=PolynomialQuotient[Numerator[xx],(c^6)(((1-c))^3),c];
x=x/.t->((55τ+45)/100);
xc=BasisChange[x,τ,37];
OK={};
Print["The multidegree of h(((55  τ + 45)/100),c) as the polynomial of variables (c,τ) is (",Length[CoefficientList[x,c]]-1,",",Length[xc]-1,")."];
For[j=0,j<=37,j++,
OK=Union[OK,Map[#>=0&,BasisChange[xc[[j+1]],c,81]]]]
Print[OK]

(Subscript[e, 4])(0,(Subscript[d, 1])(c))-(Subscript[e, 4])(t,(Subscript[d, 1])(c))<=0 for all t∈[0.45,1]

1-ee4[c,d]

x=Together[(((((2+(c^3)))^16)(((3-2 c d1[c]))^4))/((c^6)(t^2)(((1-c))^3)))((((1-ee4[c,d1[c]]))^2)((g[t,c,d1[c]])^3)-((f[t,c,d1[c]])^2))];
Denominator[x]
x=Numerator[x];
xc=BasisChange[x/.t->((55τ+45)/100),τ,16];
OK={};
Print["The multidegree of \!\(\*FractionBox[\(\*SuperscriptBox[\((2 + \*SuperscriptBox[\(c\), \(3\)])\), \(16\)] \*SuperscriptBox[\((3 - 2\\ c\\ \*SubscriptBox[\(d\), \(1\)] \((c)\))\), \(4\)]\), \(\*SuperscriptBox[\(c\), \(6\)] \*SuperscriptBox[\(t\), \(2\)] \*SuperscriptBox[\((1 - c)\), \(3\)]\)]\)((1-(Subscript[e, 4])(0,c,(Subscript[d, 1])(c)))^2g(t,c,d_1(c))^3-f(t,c,(Subscript[d, 1])(c))^2) as the polynomial of variables (c,τ) is (",Length[CoefficientList[x,c]]-1,",",Length[xc]-1,")."];
For[j=0,j<=16,j++,
OK=Union[OK,Map[#>=0&,BasisChange[xc[[j+1]],c,75]]]]
Print[OK]

Lemma 5.2 Part 2

(Subscript[e, 4])(0.9,c,(Subscript[d, 2])(c))<(Subscript[e, 4])(0,(Subscript[d, 2])(c)) for all c

x=Together[((((2+(c^3)))^3)/(c^3))f[(9/10),c,d2[c]]];
Denominator[x]
x=Numerator[x];
xc=BasisChange[Simplify[x],c];
OK={};
Print["The degree of ((((2 + (c^3)))^3)/(c^3))f((9/10),c,(Subscript[d, 2])(c)) as the polynomial of variable c is ",Length[xc]-1,"."];
Union[Map[#>=0&,xc]]

((f(0.9,(Subscript[d, 2])(c)))^2)((g(0,(Subscript[d, 2])(c)))^3)-f(0,(Subscript[d, 2])(c))^2((g(0.9,(Subscript[d, 2])(c)))^3)>0 for all c

x=Together[Together[((((2+(c^3)))^16)/((c^12)(((3-2c d2[c]))^2)))(((f[(9/10),c,d2[c]])^2)((g[0,c,d2[c]])^3)-((f[0,c,d2[c]])^2)((g[(9/10),c,d2[c]])^3))]];
Denominator[x]
x=Numerator[x];
xc=BasisChange[x,c,78];
OK={};
Print["The degree of \!\(\*FractionBox[SuperscriptBox[\((2 + \*SuperscriptBox[\(c\), \(3\)])\), \(16\)], \(\*SuperscriptBox[\(c\), \(12\)] \*SuperscriptBox[\((3 - 2  c\\ \*SubscriptBox[\(d\), \(2\)] \((c)\))\), \(2\)]\)]\)(f((9/10),c,(Subscript[d, 2])(c))^2g(0,c,(Subscript[d, 2])(c))^3-f(0,c,(Subscript[d, 2])(c))^2g((9/10),c,(Subscript[d, 2])(c))^3) as the polynomial of variable c is ",Length[xc]-1,"."];
Union[Map[#>=0&,xc]]

l(t,c)>0 for all c and all t∈[0.45,1]

x=Together[((((2+(c^3)))^24)/(c^12))(4((g[(9/10),c,d2[c]])^3)((g[t,c,d2[c]])^3)-((f[(9/10),c,d2[c]])^2)((g[t,c,d2[c]])^3)-((f[t,c,d2[c]])^2)((g[(9/10),c,d2[c]])^3))];
Denominator[x]
x=Numerator[x];
xc=BasisChange[x/.t->((55τ+45)/100),τ,18];
OK={};
Print["The multidegree of ((c^12)/(((2 + (c^3)))^24))r(((55  τ + 45)/100),c) as the polynomial of variables (c,τ) is (",Length[CoefficientList[x,c]]-1,",",Length[xc]-1,")."];
For[j=0,j<=18,j++,
OK=Union[OK,Map[#>=0&,BasisChange[xc[[j+1]],c,120]]]]
Print[OK]

((r(t,c))^2)-((l(t,c))^2)>0 for all c and all t∈[0.45,1]

x1=Together[2((f[(9/10),c,d2[c]])^2)((f[t,c,d2[c]])^2)((g[(9/10),c,d2[c]])^3)((g[t,c,d2[c]])^3)];
x2=Together[-((f[t,c,d2[c]])^4)((g[(9/10),c,d2[c]])^6)];
x3=Together[-((f[(9/10),c,d2[c]])^4)((g[t,c,d2[c]])^6)];
x4=Together[-16((g[(9/10),c,d2[c]])^6)((g[t,c,d2[c]])^6)];
x5=Together[8((f[t,c,d2[c]])^2)((g[(9/10),c,d2[c]])^6)((g[t,c,d2[c]])^3)];
x6=Together[8((f[(9/10),c,d2[c]])^2)((g[(9/10),c,d2[c]])^3)((g[t,c,d2[c]])^6)];

x=Together[x1+x2+x3+x4+x5+x6];
Denominator[x]
x=Numerator[x];

xc=BasisChange[x/.t->((55τ+45)/100),τ,67];
OK={};
Print["The multidegree of ((c^24)/(((2 + (c^3)))^48))((r^2)(((55  τ + 45)/100),c)-(l^2)(((55  τ + 45)/100),c)) as the polynomial of variables (c,τ) is (",Length[CoefficientList[x,c]]-1,",",Length[xc]-1,")."];
For[j=0,j<=67,j++,
OK=Union[OK,Map[#>=0&,BasisChange[xc[[j+1]],c,264]]]]
Print[OK]

Lemma 5.2 Part 3

g[0,c,d]

x=Simplify[((((2+(c^3)))^3)/(((1-c))^3))(f[0,c,d0[c]](((c(3-2 c d1[c])))^3)-f[0,c,d1[c]](((c(3-2 c d0[c])))^3))];
Simplify[PolynomialRemainder[x,(c^5),c]]
x=Simplify[PolynomialQuotient[x,(c^5),c]];
OK={};
Print["The degree of ((((2 + (c^3)))^3)/((c^5) (((1 - c))^3)))(f(0,c,(Subscript[d, 0])(c))(Sqrt[g (((0, c, (Subscript[d, 1]) (c)))^3)])-f(0,c,(Subscript[d, 1])(c))(Sqrt[g (((0, c, (Subscript[d, 0]) (c)))^3)])) is ",Length[CoefficientList[x,c]]-1,"."];
OK=Union[OK,Map[#>=0&,BasisChange[x,c,17]]]

x=Simplify[(1/(c^2))f[(4/10),c,d0[c]δ]];
xc=BasisChange[x,δ];
OK={};
Print["The multidegree of (1/(c^2))f((4/10),c,(Subscript[d, 0])(c)δ) as the polynomial of variables (c,τ) is (",Length[CoefficientList[x,c]]-1,",",Length[xc]-1,")."];
For[j=0,j<=3,j++,
OK=Union[OK,Map[#>=0&,BasisChange[xc[[j+1]],c,4]]]]
Print[OK]

x=Together[(((2+(c^3)))^4)(((3-2 c d1[c]))^4)((((1+((f[0,c,d1[c]])/(((c(3-2 c d1[c])))^3))))^2)((g[(4/10),c,d0[c]δ])^3)-((f[(4/10),c,d0[c]δ])^2))];
xc=BasisChange[x,δ];
OK={};
Print["The multidegree of (2+(c^3))^4(3-2 c (Subscript[d, 1])[c])^4((1+(Subscript[e, 4])(0,c,(Subscript[d, 1])(c)))g((4/10),c,(Subscript[d, 0])(c)δ)^3-f((4/10),c,(Subscript[d, 0])(c)δ)^2) as the polynomial of variables (c,δ) is (",Length[CoefficientList[x,c]]-1,",",Length[xc]-1,")."];
For[j=0,j<=12,j++,
OK=Union[OK,Map[#>=0&,BasisChange[xc[[j+1]],c,42]]]]
Print[OK]

Lemma 5.3 Part 4

h1[c_,d_]=6-8 (d^2);
h2[c_,d_]=c (((3-2 c d))^2);
x=Assuming[0<c<1&&d<(3/(2c)),(Subscript[e, 4])[0,c,d]==1-((h1[c,d])/(h2[c,d]))//Simplify]

x=Together[((((2+(c^3)))^2)/(c^2))(2h2[c,d3[c]]*h2[c,d2[c]]-h1[c,d3[c]]*h2[c,d2[c]]-h1[c,d2[c]]*h2[c,d3[c]])];
Denominator[x]
x=Numerator[x];
xc=BasisChange[x,c,16];
OK={};
Print["The degree of ((((2 + (c^3)))^2)/(c^2))(2h2(c,(Subscript[d, 3])(c))*h2(c,(Subscript[d, 2])(c))-h1(c,(Subscript[d, 3])(c))*h2(c,(Subscript[d, 2])(c))-h1(c,(Subscript[d, 2])(c))*h2(c,(Subscript[d, 3])(c))) as the polynomial of variable c is ",Length[xc]-1,"."];
Union[Map[#>=0&,xc]]

Calculation for arbitrary angle φ

Blue curve is optimal interpolant with respect to the curvature error function and orange one the optimal one with respect to the radial error function.
On the middle there are graphs of the radial error functions of both interpolant and on the right there are graphs of the curvature error functions of the interpolants.

φ0=(π/3);
If[φ0==(π/2),c0=0,c0=N[Cos[φ0]]];
{dC,tm}={d,t}/.FindRoot[D[(Subscript[e, 4])[t,c0,d],t]==0&&(Subscript[e, 4])[t,c0,d]==(Subscript[e, 4])[0,c0,d],{d,d1[c0]},{t,0.9}];
tM=t/.NSolve[D[(Subscript[e, 4])[t,c0,dC],t]==0&&0.45<t<tm,t][[1]];
If[(Subscript[e, 4])[0,c0,dC]+(Subscript[e, 4])[tM,c0,dC]>0,
dC=d/.FindRoot[D[(Subscript[e, 4])[t,c0,d],t]==0&&(Subscript[e, 4])[t,c0,d]+(Subscript[e, 4])[0,c0,d]==0,{d,d1[c0]},{t,0.5}]];
dE=d/.FindRoot[(Subscript[er, 4])[t,c0,d]+(Subscript[er, 4])[0,c0,d]==0&&D[(Subscript[er, 4])[t,c0,d],t]==0,{d,d1[c0]},{t,0.45}];
If[c0==0,tocke={{0,-1},{((Sqrt[3])/2),-1},{dC,0},{((Sqrt[3])/2),1},{0,1}},
tocke={(Subscript[b, 4,0]),(Subscript[b, 4,1]),(Subscript[b, 4,2]),(Subscript[b, 4,3]),(Subscript[b, 4,4])}/.{c->c0,d->dC}];GraphicsRow[{Show[ParametricPlot[{Cos[φ],Sin[φ]},{φ,-φ0,φ0},PlotStyle->{Blue,Dashed},Ticks->{{0,0.5,1,1.5},{-1,-0.5,0,0.5,1}}],
ParametricPlot[{(Subscript[p, 4])[t,c0,dC],(Subscript[p, 4])[t,c0,dE]},{t,-1,1},PlotStyle->{Red,Orange}],
ListPlot[tocke,PlotStyle->{PointSize[0.02],Black}],Graphics[{Black,Line[tocke]}],AspectRatio->Automatic,PlotRange->All],
Plot[{(Subscript[er, 4])[t,c0,dC],(Subscript[er, 4])[t,c0,dE]},{t,-1,1},GridLines->{{},{(Subscript[er, 4])[0,c0,dE],-(Subscript[er, 4])[0,c0,dE]}}],
Plot[{(Subscript[e, 4])[t,c0,dC],(Subscript[e, 4])[t,c0,dE]},{t,-1,1},GridLines->{{},{(Subscript[e, 4])[0,c0,dC],-(Subscript[e, 4])[0,c0,dC]}}]}]

Plot[{(Subscript[er, 4])[t,c0,dC],(Subscript[er, 4])[t,c0,dE]},{t,-1,1},GridLines->{{},{(Subscript[er, 4])[0,c0,dE],-(Subscript[er, 4])[0,c0,dE]}},PlotStyle->{{Black},{Black,Dashed}}]

Plot[{(Subscript[e, 4])[t,c0,dC],(Subscript[e, 4])[t,c0,dE]},{t,-1,1},GridLines->{{},{(Subscript[e, 4])[0,c0,dC],-(Subscript[e, 4])[0,c0,dC]}},PlotStyle->{{Black},{Black,Dashed}}]

A table of best interpolants with corresponding errors

angles={(π/2),(π/3),(π/4),(π/6),(π/8),(π/12)};
n=4;
(Subscript[sez, n])={{"φ","(SuperStar[d])","curvature error","radial error","(d^r)","curvature error","radial error"}};
For[i=1,i≤Length[angles],i++,
φ0=angles[[i]];
If[φ0==(π/2),c0=0,c0=N[Cos[φ0]]];
{dC,tm}={d,t}/.FindRoot[D[(Subscript[e, 4])[t,c0,d],t]==0&&(Subscript[e, 4])[t,c0,d]==(Subscript[e, 4])[0,c0,d],{d,d1[c0]},{t,0.9}];
tM=t/.NSolve[D[(Subscript[e, 4])[t,c0,dC],t]==0&&0.45<t<tm,t][[1]];
If[(Subscript[e, 4])[0,c0,dC]+(Subscript[e, 4])[tM,c0,dC]>0,
dC=d/.FindRoot[D[(Subscript[e, 4])[t,c0,d],t]==0&&(Subscript[e, 4])[t,c0,d]+(Subscript[e, 4])[0,c0,d]==0,{d,d1[c0]},{t,0.5}]];
dE=d/.FindRoot[(Subscript[er, 4])[t,c0,d]+(Subscript[er, 4])[0,c0,d]==0&&D[(Subscript[er, 4])[t,c0,d],t]==0,{d,d1[c0]},{t,0.45}];
edC=-(Subscript[e, n])[0,c0,dC];
edE=Max[Map[Abs[(Subscript[e, n])[t/.#,c0,dE]]&,NSolve[D[(Subscript[e, 4])[t,c0,dE],t]==0&&0<t<1,t]]];
edE=Max[edE,Abs[(Subscript[e, n])[0,c0,dE]]];
erdC=Max[Map[Abs[(Subscript[er, n])[t/.#,c0,dC]]&,NSolve[D[(Subscript[er, 4])[t,c0,dC],t]==0&&0<t<1,t]]];
erdC=Max[erdC,Abs[(Subscript[er, n])[0,c0,dC]]];
erdE=(Subscript[er, n])[0,c0,dE];AppendTo[(Subscript[sez, n]),{φ0,N[dC,6],ScientificForm[edC,6],ScientificForm[erdC,6],N[dE,6],ScientificForm[edE,6],ScientificForm[erdE,6]}]];

Grid[(Subscript[sez, n]),Frame->All]