Geometric interpolation of ER frames with G^2 PH curves of degree 7

Functions

ClearAll[Norma]
(* Norm of a vector  *)
Norma[x_]:=(Sqrt[x.x])

ClearAll[bernstein];
(* Bernstein basis polynomial *)
bernstein[x_,n_,i_]:=Module[{},
If[x==0 && i==0,Return[1]];
If[x==1 && i==n,Return[1]];
Return[Binomial[n,i]*x^(i)*(1-x)^(n-i)]
]

ClearAll[Rotacija]
(* Rotation matrix from a quaternion *)
Rotacija[Q_]:=Module[{U,u0},
U={{Q[[1]]^2+Q[[2]]^2-Q[[3]]^2-Q[[4]]^2,2(Q[[2]]Q[[3]]-Q[[1]]Q[[4]]),2(Q[[2]]Q[[4]]+Q[[1]]Q[[3]])},{2(Q[[2]]Q[[3]]+Q[[1]]Q[[4]]),Q[[1]]^2-Q[[2]]^2+Q[[3]]^2-Q[[4]]^2,2(Q[[3]]Q[[4]]-Q[[1]]Q[[2]])},{2(Q[[2]]Q[[4]]-Q[[1]]Q[[3]]),2(Q[[3]]Q[[4]]+Q[[1]]Q[[2]]),Q[[1]]^2-Q[[2]]^2-Q[[3]]^2+Q[[4]]^2}};
u0=Q[[1]]^2+Q[[2]]^2+Q[[3]]^2+Q[[4]]^2;
Return[{U,u0,1/u0 U}]
]

ClearAll[DolociKvat]
(* Inverse kinematic mapping - compute a quaternion from a given rotation matrix. *)
DolociKvat[M_]:=Module[{QQ1,QQ2,QQ3,QQ4,QQ,q},
QQ1={1+M[[1,1]]+M[[2,2]]+M[[3,3]],M[[3,2]]-M[[2,3]],M[[1,3]]-M[[3,1]],M[[2,1]]-M[[1,2]]};
QQ2={M[[3,2]]-M[[2,3]],1+M[[1,1]]-M[[2,2]]-M[[3,3]],M[[2,1]]+M[[1,2]],M[[1,3]]+M[[3,1]]};
QQ3={M[[1,3]]-M[[3,1]],M[[2,1]]-M[[1,2]],1-M[[1,1]]+M[[2,2]]-M[[3,3]],M[[3,2]]+M[[2,3]]};
QQ4={M[[2,1]]-M[[1,2]],M[[1,3]]+M[[3,1]],M[[3,2]]+M[[2,3]],1-M[[1,1]]-M[[2,2]]+M[[3,3]]};
QQ=Select[{QQ1,QQ2,QQ3,QQ4},#≠{0,0,0,0}&];
q=QQ[[1]];
Return[q];
]

ClearAll[Cross1]
(* Cross product *)
Cross1[x_,y_]:={-x[[3]]y[[2]]+x[[2]]y[[3]],x[[3]]y[[1]]-x[[1]]y[[3]],-x[[2]]y[[1]]+x[[1]]y[[2]]}

ClearAll[KvaternionProd,KvaternionConj,KvaternionProd3]
(* Product of two quaternions *)
KvaternionProd[X_,Y_]:=Module[{x0,x,y0,y},
x0=X[[1]];
x=Drop[X,1];
y0=Y[[1]];
y=Drop[Y,1];
Return[Flatten[{x0 y0-x.y,x0 y+y0 x + Cross1[x,y]}]];
]

(* Product of three quaternions *)
KvaternionProd3[X_,Y_,Z_]:=KvaternionProd[KvaternionProd[X,Y],Z]

(* Quaternion conjugate *)
KvaternionConj[X_]:=Flatten[{X[[1]],-Drop[X,1]}]

(* Quaternion norm *)
ClearAll[KvaternionNorm]
KvaternionNorm[X_]:=((Sqrt[KvaternionProd[X,KvaternionConj[X]]]))[[1]]

(* Inverse of a nonzero quaternion *)
ClearAll[KvaternionInv]
KvaternionInv[X_]:=(KvaternionConj[X])/Norma[X]^2;

(* Operation star *)
ClearAll[OPStar]
OPStar[A_,B_]:=1/2(KvaternionProd[A,KvaternionProd[{0,1,0,0},KvaternionConj[B]]]+KvaternionProd[B,KvaternionProd[{0,1,0,0},KvaternionConj[A]]])

ClearAll[OPStar2]
OPStar2[A_,B_]:=1/2(KvaternionProd[A,KvaternionProd[{0,0,1,0},KvaternionConj[B]]]+KvaternionProd[B,KvaternionProd[{0,0,1,0},KvaternionConj[A]]])
ClearAll[OPStar3]
OPStar3[A_,B_]:=1/2(KvaternionProd[A,KvaternionProd[{0,0,0,1},KvaternionConj[B]]]+KvaternionProd[B,KvaternionProd[{0,0,0,1},KvaternionConj[A]]])


ClearAll[QToR]
QToR[Q_,p_]:=Simplify[KvaternionProd[Q,KvaternionProd[p,KvaternionConj[Q]]]];


ClearAll[SolveEQStar]
SolveEQStar[a_,phi_]:=Module[{A,nA,X},
A=Prepend[a,0];
nA=KvaternionNorm[A];
If[Simplify[A/nA]=={0,-1,0,0},Return[Sqrt[nA]KvaternionProd[{0,0,0,1},{Cos[phi],Sin[phi],0,0}]]];
X=(Sqrt[nA])KvaternionProd[((A/nA+{0,1,0,0})/(KvaternionNorm[A/nA+{0,1,0,0}])),{Cos[phi],Sin[phi],0,0}];
Return[X];
]

ClearAll[SolveEQStar1]
SolveEQStar1[a_,phi_]:=Module[{A,nA,X},
A=Prepend[a,0];
nA=KvaternionNorm[A];
X=(Sqrt[nA])KvaternionProd[((A/nA+{0,1,0,0})/(KvaternionNorm[A/nA+{0,1,0,0}])),{Cos[phi],Sin[phi],0,0}];
Return[X];
]

ClearAll[Jacobijan];
Jacobijan[enacbe_, spr_]:=Module[{Jac,i,j},
Jac=Table[Table[D[enacbe[[i]],spr[[j]]],{j,1,Length[spr]}],{i,1,Length[enacbe]}];
Return[Jac];
]

ClearAll[StopnjaEQP]
(* Compute a degree of a polynomial 'eq' in t. *)
StopnjaEQP[eq_,t_]:=Length[CoefficientList[eq,t]]-1;

ClearAll[StopnjaEQR]
(* Compute a degree of a rational function 'eq' in t. *)
StopnjaEQR[eq_,t_]:=Module[{p1,p2},
p1=Numerator[Together[eq]];
p2=Denominator[Together[eq]];
Return[{StopnjaEQP[p1,t],StopnjaEQP[p2,t]}]
]

WedgeProd[v1_,v2_,v3_]:=Module[{A},
A=Transpose[{v1,v2,v3}];
Return[{-Det[{A[[2]],A[[3]],A[[4]]}],Det[{A[[1]],A[[3]],A[[4]]}],Det[{A[[1]],A[[4]],A[[2]]}],Det[{A[[1]],A[[2]],A[[3]]}]}]

]

ClearAll[IzracunERF]
(* From a given quaternion polynomial compute the ER frame, function omega... *)
IzracunERF[AA_,t_]:=Module[{uu,vv,pp,qq,du,dv,dp,dq,WW1,WW2,WW3,WI,W1,W2,W3,EE1,EE2,EE3,UN},
uu=AA[[1]];
vv=AA[[2]];
pp=AA[[3]];
qq=AA[[4]];
du=D[uu,t];
dv=D[vv,t];
dp=D[pp,t];
dq=D[qq,t];
(* Izracunam Wi *)
WW1=2(uu dv -du vv -pp dq + dp qq);
WW2=2(uu dp - du pp + vv dq-dv qq);
WW3=2(uu dq - du qq-vv dp+dv pp);
WI=uu^2+vv^2+pp^2+qq^2;
W1=WW1/WI;
W2=WW2/WI;
W3=WW3/WI;
(* Izracunam ERF ogrodje *)
EE1={uu^2+vv^2-pp^2-qq^2,2(vv pp + uu qq),2(vv qq -uu pp)};
EE2={2(vv pp - uu qq),uu^2-vv^2+pp^2-qq^2,2(pp qq + uu vv)};
EE3={2(vv qq + uu pp),2(pp qq- uu vv), uu^2-vv^2-pp^2+qq^2};
UN=WW2 EE2 + WW3 EE3;
Return[{WW1,WW2,WW3,WI,EE1,EE2,EE3,UN}]
]

ClearAll[RotationAxis]
(* Compute a rotational axis from a given frame. *)
RotationAxis[e1_,e2_,e3_,t_]:=Module[{w1,w2,w3,w},
w1=D[e2,t].e3;
w2=D[e3,t].e1;
w3=D[e1,t].e2;
w=w1 e1+w2 e2+w3 e3;
Return[w]
]


ClearAll[DeCasteljau]
DeCasteljau[KT_,t_]:=Module[{M,n,r,i,j},
n=Length[KT]-1;
M=Table[Table[0,{i,0,n}],{j,0,n}];
For[i=0,i≤n,i++,
M[[i+1,1]]=KT[[i+1]];
];
For[r=1,r≤n,r++,
For[i=0,i≤n-r,i++,
M[[i+1,r+1]]=(1-t)M[[i+1,r]]+t M[[i+2,r]];
];
];
Return[M]
]

ClearAll[PrehodnaM]
PrehodnaM[n_]:=Module[{p,t,i},
p=Table[CoefficientList[bernstein[t,n,i],t],{i,0,n}];
Return[p]
]

ClearAll[BezKoef]
(* From the coefficients in a standard basis determine coefficients in a Bezier basis. *)
BezKoef[n_,koef_]:=Module[{IA,i,koef1},
koef1=koef;
For[i=Length[koef],i≤n,i++,
koef1=Append[koef1,0]
];
IA=Inverse[PrehodnaM[n]];
Return[koef1.IA]
]


ClearAll[Frene]
Frene[r_,t_]:=Module[{tt,bb,nn},
tt=D[r,t]/Norma[D[r,t]];
bb=Cross[D[r,t],D[r,{t,2}]]/Norma[Cross[D[r,t],D[r,{t,2}]]];
nn=Cross[bb,tt];
Return[{tt,nn,bb}]
]


(* Curvature, torsion *)
ClearAll[Ukriv,Torsion]
Ukriv[R_,t_]:=Norma[Cross[D[R,t],D[R,{t,2}]]]/Norma[D[R,t]]^3;
Torsion[R_,t_]:=Det[{D[R,t],D[R,{t,2}],D[R,{t,3}]}]/Norma[Cross[D[R,t],D[R,{t,2}]]]^2


ClearAll[Red1];
(* Function computes the approximation order of two consecutive measurements. *)
Red1[napaka1_,h_,napaka2_,k_]:=(Log[napaka1]-Log[napaka2])/(Log[h]-Log[k])

ClearAll[RedAproksimacije];
(* Function computes an approximation order. *)
RedAproksimacije[TabH_,TabN_]:=Module[{tabela,i},
If[Length[TabH]≠Length[TabN],Return[{}]];
tabela={{"h","error","decay exponent"}};
tabela=Append[tabela,{TabH[[1]],TabN[[1]],"/"}];
For[i=2,i≤Length[TabH],i++,
tabela=Append[tabela,{TabH[[i]],TabN[[i]],Red1[TabN[[i-1]],TabH[[i-1]],TabN[[i]],TabH[[i]]]}];
];
Return[tabela];
]

ClearAll[RedAproksimacijeZaZlepek];
(* Function computes an approximation order for a spline. *)
RedAproksimacijeZaZlepek[TabM_,TabN_]:=Module[{tabela,i},
If[Length[TabM]≠Length[TabN],Return[{}]];
tabela={{"m","napaka","eksponent padanja"}};
tabela=Append[tabela,{TabM[[1]],TabN[[1]],"/"}];
For[i=2,i≤Length[TabM],i++,
tabela=Append[tabela,{TabM[[i]],TabN[[i]],Red1[TabN[[i-1]],1/TabM[[i-1]],TabN[[i]],1/TabM[[i]]]}];
];
Return[tabela];
]


ClearAll[BendEnergy]
BendEnergy[r_,t_,a_,b_,WP_]:=Module[{u1,u2,ii},
u1=Norm[Cross[D[r,t],D[r,{t,2}]]];
u2=Norm[D[r,t]];
ii=NIntegrate[u1^2/u2^5,{t,a,b},WorkingPrecision->WP];
Return[ii]
]

ClearAll[BendEnergyApprox]
BendEnergyApprox[r_,t_,a_,b_,WP_]:=Module[{u1,u2,ii},
u1=Norm[D[r,{t,2}]];
ii=NIntegrate[u1^2,{t,a,b},WorkingPrecision->WP];
Return[ii]
]


(* Simpson integration rule *)
ClearAll[Simpson]
Simpson[f_,t_,a_,b_,m_]:=Module[{x,y1,y2,y3,i},
x=Table[a+i*(b-a)/(2m),{i,0,2m}];
y1=4*Plus@@(Table[f/.{t->x[[2i]]},{i,1,m}]);
y2=2*Plus@@(Table[f/.{t->x[[2i+1]]},{i,1,m-1}]);
y3=(f/.{t->a})+(f/.{t->b});
Return[(b-a)/(6m)*(y1+y2+y3)]
]


ClearAll[DrawERFFrame]
DrawERFFrame[cA_,AA_,t_,a_,b_,step_,vel_,color1_,color2_,color3_]:=Module[{ANorm,ff1,ff2,ff3,ogr1,ogr2,ogr3,i,ogrG},
ANorm=Simplify[KvaternionNorm[AA]^2];
ff1=Drop[QToR[AA,{0,1,0,0}]/ANorm,1];
ff2=Drop[QToR[AA,{0,0,1,0}]/ANorm,1];
ff3=Drop[QToR[AA,{0,0,0,1}]/ANorm,1];
ogr1=Flatten[Table[Arrow[{cA/.{t->i},(cA/.{t->i})+vel ff1/.{t->i}}],{i,a,b,step}]];
ogr2=Flatten[Table[Arrow[{cA/.{t->i},(cA/.{t->i})+vel ff2/.{t->i}}],{i,a,b,step}]];
ogr3=Flatten[Table[Arrow[{cA/.{t->i},(cA/.{t->i})+vel ff3/.{t->i}}],{i,a,b,step}]];
ogrG=Graphics3D[{Arrowheads[0.015],RGBColor[color1],ogr1,RGBColor[color2],ogr2,RGBColor[color3],ogr3}];;
Return[{ogr1,ogr2,ogr3,ogrG}]
]

ClearAll[DrawGeneralFrame]
DrawGeneralFrame[e1_,e2_,e3_,curve_,t_,a_,b_,kor_,vel_,color1_,color2_,color3_]:=Module[{ogr1,ogr2,ogr3,ogr,i},
ogr1=Flatten[Table[Arrow[{curve/.{t->i},(curve/.{t->i})+vel e1/.{t->i}}],{i,a,b,kor}]];
ogr2=Flatten[Table[Arrow[{curve/.{t->i},(curve/.{t->i})+vel e2/.{t->i}}],{i,a,b,kor}]];
ogr3=Flatten[Table[Arrow[{curve/.{t->i},(curve/.{t->i})+vel e3/.{t->i}}],{i,a,b,kor}]];
ogr=Graphics3D[{Arrowheads[0.015],RGBColor[color1],ogr1,RGBColor[color2],ogr2,RGBColor[color3],ogr3}];
Return[ogr]
]

ClearAll[DrawGeneralFrame1]
DrawGeneralFrame1[e1_,e2_,e3_,curve_,t_,tabPar_,vel_,color1_,color2_,color3_,aH_,aT_]:=Module[{ogr1,ogr2,ogr3,ogr,i},
ogr1=Flatten[Table[Arrow[{curve/.{t->tabPar[[i]]},(curve/.{t->tabPar[[i]]})+vel e1/.{t->tabPar[[i]]}}],{i,1,Length[tabPar]}]];
ogr2=Flatten[Table[Arrow[{curve/.{t->tabPar[[i]]},(curve/.{t->tabPar[[i]]})+vel e2/.{t->tabPar[[i]]}}],{i,1,Length[tabPar]}]];
ogr3=Flatten[Table[Arrow[{curve/.{t->tabPar[[i]]},(curve/.{t->tabPar[[i]]})+vel e3/.{t->tabPar[[i]]}}],{i,1,Length[tabPar]}]];
ogr=Graphics3D[{Thickness[aT],Arrowheads[aH],RGBColor[color1],ogr1,RGBColor[color2],ogr2,RGBColor[color3],ogr3}];
Return[ogr]
]

ClearAll[DrawFrame]
DrawFrame[cA_,AA_,a_,b_,fac1_,step_,t_]:=Module[{ANorm,ff1,ff2,ff3,ogr1,ogr2,ogr3,kk,i,τ,ogrG},
ANorm=Simplify[KvaternionNorm[AA]^2];
ff1=Drop[QToR[AA,{0,1,0,0}]/ANorm,1];
ff2=Drop[QToR[AA,{0,0,1,0}]/ANorm,1];
ff3=Drop[QToR[AA,{0,0,0,1}]/ANorm,1];
kk=fac1;
ogr1=Flatten[Table[Arrow[{cA/.{t->i},(cA/.{t->i})+kk ff1/.{t->i}}],{i,a,b,step}]];
ogr2=Flatten[Table[Arrow[{cA/.{t->i},(cA/.{t->i})+kk ff2/.{t->i}}],{i,a,b,step}]];
ogr3=Flatten[Table[Arrow[{cA/.{t->i},(cA/.{t->i})+kk ff3/.{t->i}}],{i,a,b,step}]];
ogrG=Graphics3D[{Arrowheads[0.02],RGBColor[1,0,0],ogr1,RGBColor[0,1,0],ogr2,RGBColor[0,0,1],ogr3}];
Return[{ogr1,ogr2,ogr3,ogrG}]
]

ClearAll[DrawGeneralFrameTab]
DrawGeneralFrameTab[tabAFrame_,tabcurve_,vel_, color1_,color2_,color3_]:=Module[{ogr1,ogr2,ogr3,ogr,i},
ogr1=Flatten[Table[Arrow[{tabcurve[[i]],tabcurve[[i]]+vel tabAFrame[[i,1]]}],{i,1,Length[tabAFrame]}]];
ogr2=Flatten[Table[Arrow[{tabcurve[[i]],tabcurve[[i]]+vel tabAFrame[[i,2]]}],{i,1,Length[tabAFrame]}]];
ogr3=Flatten[Table[Arrow[{tabcurve[[i]],tabcurve[[i]]+vel tabAFrame[[i,3]]}],{i,1,Length[tabAFrame]}]];
ogr=Graphics3D[{Arrowheads[0.015],RGBColor[color1],ogr1,RGBColor[color2],ogr2,RGBColor[color3],ogr3}];
Return[ogr]
]

(* A cube *)
ClearAll[Kocka];
Kocka=Table[Table[0,{i,1,4}],{j,1,12}];
Kocka[[1]]={{0,0,0},{1,0,0},{1,1,0},{0,1,0}};
Kocka[[2]]={{0,0,1},{1,0,1},{1,1,1},{0,1,1}};
Kocka[[3]]={{0,0,0},{0,1,0},{0,1,1},{0,0,1}};
Kocka[[4]]={{1,0,0},{1,1,0},{1,1,1},{1,0,1}};
Kocka[[5]]={{0,0,0},{1,0,0},{1,0,1},{0,0,1}};
Kocka[[6]]={{0,1,0},{1,1,0},{1,1,1},{0,1,1}};
Kocka[[7]]={{1/3,1/3,0},{2/3,1/3,0},{1/3,2/3,0},{2/3,2/3,0}};
Kocka[[8]]={{0,1/3,1/3},{0,2/3,1/3},{0,2/3,2/3},{0,2/3,2/3}};
Kocka[[9]]={{1/3,0,1/3},{2/3,0,1/3},{2/3,0,2/3},{1/3,0,2/3}};
Kocka[[10]]={{1,1/2,1/4},{1,2/3,1/2},{1,1/2,3/4},{1,1/3,1/2}};
Kocka[[11]]={{1/2,1/4,1},{1/2,3/4,1},{1/4,1/2,1},{3/4,1/2,1}};
Kocka[[12]]={{1/2,1,1/5},{2/3,1,4/5},{1/2,1,2/3},{1/3,1,4/5}};

(* Draw motion of a cube *)
ClearAll[DrawRB];
DrawRB[Kocka_,u_,Q_]:=Module[{RotV,Rot,q,Polyg,Poz,i},
RotV=Rotacija[Q];
Rot=RotV[[3]];
q=RotV[[2]];
Poz=Table[u+(Rot.#)&/@Kocka[[i]],{i,1,Length[Kocka]}];
Polyg=Flatten[Table[{White,EdgeForm[Thick],Polygon[Poz[[i]]]},{i,1,Length[Poz]}]];
Return[Polyg]
]

DrawRB1[Kocka_,u_,Q_]:=Module[{RotV,Rot,q,Polyg,Poz,i},
RotV=Rotacija[Q];
Rot=RotV[[3]];
q=RotV[[2]];
Poz=Table[u+(Rot.#)&/@Kocka[[i]],{i,1,Length[Kocka]}];
Polyg=Flatten[Table[{Red,EdgeForm[Thick],Polygon[Poz[[i]]]},{i,1,Length[Poz]}]];
Return[Polyg]
]


(* Compute 'arc-length' parameters  *)
ClearAll[EqualParameters]
EqualParameters[polA_,t_,kol_]:=Module[{u,pom,kor,tabT,i,pom1},
pom=Integrate[Norma[polA]^2,{t,0,u}];
kor=((pom/.{u->1})-(pom/.{u->0}))/kol;
tabT={0};
For[i=1,i≤kol,i++,
pom1=Quiet[FindRoot[pom-i kor,{u,Last[tabT]}]];
tabT=Append[tabT,u/.pom1]
];
Return[tabT]
]


ClearAll[Ogrodje]
(* Adapted frame *)
Ogrodje[ww_,t_,x_,tt_,nn_,bb_,NAT_]:=Module[{theta,R1,R2,R3},
theta=NIntegrate[ww,{t,0,x},WorkingPrecision->NAT];
R1=tt;
R2=Cos[theta]nn-Sin[theta]bb;
R3=Sin[theta]nn+Cos[theta]bb;
Return[{R1,R2,R3}/.{t->x}];
]


ClearAll[MyFindMin]
MyFindMin[fun_,φ_,NAT_]:=Module[{tab,i,j,izb},
tab=Table[Quiet[FindMinimum[{fun,(-Pi<=φ<Pi)},{φ,i},WorkingPrecision->NAT]],{i,-Pi,Pi-Pi/4,Pi/4}];
izb={fun/.{φ->-Pi},{φ->-Pi}};
For[j=1,j≤Length[tab],j++,
If[(-Pi<=(φ/.tab[[j,2]])<Pi)&&(tab[[j,1]]<=izb[[1]]),izb=tab[[j]]]
];
Return[izb];
]

ClearAll[MyFindMin1]
MyFindMin1[fun_,φ_,a_,b_,NAT_]:=Module[{tab,i,j,izb},
tab=Table[Quiet[FindMinimum[{fun,(a<=φ<b)},{φ,i},WorkingPrecision->NAT]],{i,a,b-(b-a)/10,(b-a)/10}];
izb={fun/.{φ->a},{φ->a}};
For[j=1,j≤Length[tab],j++,
If[(a<=(φ/.tab[[j,2]])<b)&&(tab[[j,1]]<=izb[[1]]),izb=tab[[j]]]
];
Return[izb];
]

ClearAll[MyFindMax1]
MyFindMax1[fun_,φ_,a_,b_,NAT_]:=Module[{tab,i,j,izb},
tab=Table[Quiet[FindMaximum[{fun,(a<=φ<b)},{φ,i},WorkingPrecision->NAT]],{i,a,b-(b-a)/10,(b-a)/10}];
izb={fun/.{φ->a},{φ->a}};
For[j=1,j≤Length[tab],j++,
If[(a<=(φ/.tab[[j,2]])<b)&&(tab[[j,1]]>=izb[[1]]),izb=tab[[j]]]
];
Return[izb];
]


(* Compute a PH curve of degree 7 from a cubic quaternion polynomial.  *)
ClearAll[PHCurveOfDegree7]
PHCurveOfDegree7[KA_,P0_,t_]:=Module[{AA,i,Hod,hh,pp,curve,pom,CoefSigma,locna},
AA=Plus@@Table[KA[[i+1]]bernstein[t,3,i],{i,0,3}];
(Subscript[hh, 0])=Rest[OPStar[KA[[1]],KA[[1]]]];
(Subscript[hh, 1])=Rest[OPStar[KA[[1]],KA[[2]]]];
(Subscript[hh, 2])=1/5Rest[2OPStar[KA[[1]],KA[[3]]]+3OPStar[KA[[2]],KA[[2]]]];
(Subscript[hh, 3])=1/10Rest[OPStar[KA[[1]],KA[[4]]]+9OPStar[KA[[2]],KA[[3]]]];
(Subscript[hh, 4])=1/5Rest[2OPStar[KA[[2]],KA[[4]]]+3OPStar[KA[[3]],KA[[3]]]];
(Subscript[hh, 5])=Rest[OPStar[KA[[3]],KA[[4]]]];
(Subscript[hh, 6])=Rest[OPStar[KA[[4]],KA[[4]]]];
Hod=Plus@@Table[(Subscript[hh, i])bernstein[t,6,i],{i,0,6}];
(Subscript[pp, 0])=P0;
(Subscript[pp, 1])=(Subscript[pp, 0])+1/7(Subscript[hh, 0]);
(Subscript[pp, 2])=(Subscript[pp, 0])+1/7((Subscript[hh, 0])+(Subscript[hh, 1]));
(Subscript[pp, 3])=(Subscript[pp, 0])+1/7((Subscript[hh, 0])+(Subscript[hh, 1])+(Subscript[hh, 2]));
(Subscript[pp, 4])=(Subscript[pp, 0])+1/7((Subscript[hh, 0])+(Subscript[hh, 1])+(Subscript[hh, 2])+(Subscript[hh, 3]));
(Subscript[pp, 5])=(Subscript[pp, 0])+1/7((Subscript[hh, 0])+(Subscript[hh, 1])+(Subscript[hh, 2])+(Subscript[hh, 3])+(Subscript[hh, 4]));
(Subscript[pp, 6])=(Subscript[pp, 0])+1/7((Subscript[hh, 0])+(Subscript[hh, 1])+(Subscript[hh, 2])+(Subscript[hh, 3])+(Subscript[hh, 4])+(Subscript[hh, 5]));
(Subscript[pp, 7])=(Subscript[pp, 0])+1/7((Subscript[hh, 0])+(Subscript[hh, 1])+(Subscript[hh, 2])+(Subscript[hh, 3])+(Subscript[hh, 4])+(Subscript[hh, 5])+(Subscript[hh, 6]));
curve=Plus@@Table[(Subscript[pp, i])bernstein[t,7,i],{i,0,7}];
pom=CoefficientList[First[KvaternionProd[AA,KvaternionConj[AA]]],t];
CoefSigma=BezKoef[6,pom];
locna=1/7Plus@@CoefSigma;
Return[{curve,{(Subscript[pp, 0]),(Subscript[pp, 1]),(Subscript[pp, 2]),(Subscript[pp, 3]),(Subscript[pp, 4]),(Subscript[pp, 5]),(Subscript[pp, 6]),(Subscript[pp, 7])},locna}]
]


(* Compute equations for G^2 PH interpolant of degree 7. *)
ClearAll[ComputeEqForG2PHInt7]
ComputeEqForG2PHInt7[Q0_,Q1_,U0_,U1_,P0_,P1_,x_,y_,z_,ξ_]:=Module[{qq,q00,q11,q01,qu00,qu11,qu10,qu01,u00,u11,u01,tabKoef,eq,tabGam,pom,vec1,vec2,vec3,a1,a2,a3,ζ,tabZ,e1B,e2B,e3B,j},
qq=Q0[[1]];
q00=Rest[OPStar[Q0,Q0]];
q11=Rest[OPStar[Q1,Q1]];
q01=Rest[OPStar[Q0,Q1]];
qu00=Rest[OPStar[Q0,U0]];
qu11=Rest[OPStar[Q1,U1]];
qu10=Rest[OPStar[Q1,U0]];
qu01=Rest[OPStar[Q0,U1]];
u00=Rest[OPStar[U0,U0]];
u11=Rest[OPStar[U1,U1]];
u01=Rest[OPStar[U0,U1]];
tabKoef={q00,q11,q01,qu00,qu11,qu10,qu01,u00,u11,u01,P1-P0};
tabGam={(1/5) (5 (x^2)+5 x y+3 (y^2)),(1/5) (3 (z^2)+5 x z ξ+5 (x^2) (ξ^2)),(1/10) (4 x z+9 y z+(x^2) ξ+4 x y ξ),(1/15) (x^2) (5 x+6 y),-(1/15) (x^2) (ξ^3) (6 z+5 x ξ),(1/30) (x^2) (9 z+4 x ξ),-(1/30) (x^2) (4 x+9 y) (ξ^3),((x^4)/15),(((x^4) (ξ^6))/15),-(1/10) (x^4) (ξ^3),-7 x};
eq=Plus@@Table[tabGam[[i]]tabKoef[[i]],{i,1,11}];
pom=Simplify[Flatten[Solve[{q00.{a1,a2,a3}==0,q11.{a1,a2,a3}==0},{a1,a2}]]];
vec1=Simplify[{a1,a2,a3}/.pom/.{a3->Q1[[2]]Q1[[3]]+Q1[[1]]Q1[[4]] }];
pom=Simplify[Flatten[Solve[{q00.{a1,a2,a3}==0,q01.{a1,a2,a3}==0},{a1,a2}]]];
vec2={a1,a2,a3}/.pom/.{a3->Q1[[4]]};
pom=Simplify[Flatten[Solve[{q11.{a1,a2,a3}==0,q01.{a1,a2,a3}==0},{a1,a2}]]];
vec3=Simplify[{a1,a2,a3}/.pom/.{a3->2 Q1[[1]] Q1[[2]] Q1[[3]]+Q1[[1]]^2 Q1[[4]]+Q1[[4]] (-Q1[[2]]^2+Q1[[3]]^2+Q1[[4]]^2)}];
(*Coefficients ζ: *)
(Subscript[ζ, 3])=-Simplify[q01.vec1];
(Subscript[ζ, 1])=2qq (Subscript[ζ, 3]);
(Subscript[ζ, 2])=2/qq (Subscript[ζ, 3]);
For[j=4,j≤11,j++,
(Subscript[ζ, j-2,1])=Simplify[tabKoef[[j]].vec1];
(Subscript[ζ, j-2,2])=Simplify[tabKoef[[j]].vec2];
(Subscript[ζ, j-2,3])=Simplify[tabKoef[[j]].vec3];
];
(*Equations expressed with zetas: *)
e1B=-(Subscript[ζ, 3])tabGam[[3]]+Plus@@Table[(Subscript[ζ, j-2,1])tabGam[[j]],{j,4,11}];
e2B=2/qq (Subscript[ζ, 3])tabGam[[2]]+Plus@@Table[(Subscript[ζ, j-2,2])tabGam[[j]],{j,4,11}];
e3B=2 qq (Subscript[ζ, 3])tabGam[[1]]+Plus@@Table[(Subscript[ζ, j-2,3])tabGam[[j]],{j,4,11}];
tabZ={{(Subscript[ζ, 3])},Table[(Subscript[ζ, j-2,1]),{j,4,11}],Table[(Subscript[ζ, j-2,2]),{j,4,11}],Table[(Subscript[ζ, j-2,3]),{j,4,11}]};
Return[{tabGam,tabKoef,tabZ,{e1B,e2B,e3B}}]
]

ClearAll[SolForG2PHInt]
SolForG2PHInt[Q0_,Q1_,U0_,U1_,x_,y_,z_,ksi_]:=Module[{λ,μ,KA},
KA={Table[(Subscript[λ, 0])Q0[[i]],{i,1,4}],Table[(Subscript[μ, 0])Q0[[i]]+1/3(Subscript[λ, 0]^3)U0[[i]],{i,1,4}],Table[(Subscript[μ, 1])Q1[[i]]-1/3(Subscript[λ, 1]^3)U1[[i]],{i,1,4}],Table[(Subscript[λ, 1])Q1[[i]],{i,1,4}]}/.{(Subscript[λ, 0])->(Sqrt[x]),(Subscript[λ, 1])->ksi(Sqrt[x]),(Subscript[μ, 0])->y/(Sqrt[x]),(Subscript[μ, 1])->z/(Sqrt[x])};
Return[KA]
]

ClearAll[SepticPHInterpolant]
(* Compute G^2 PH interpolant of degree 7. *)
SepticPHInterpolant[t_,P0a_,P1a_,U0a_,U1a_,V0a_,V1a_,ksi_,NAT_]:=Module[{Rot,P0,P1,U0,U1,V0,V1,tabGamF,tabKoefF,tabz,enac2,x,y,z,ξ,sol,tabpol,tabKP,tabE,tabERF,jj,solX,sol1,λ,μ,KA,KP,pol7,KAPol,ERFrame,loc,pomLen,pom,pomW},
(*We need to rotate the data: *)
Rot=Inverse[Rotacija[U0a][[3]]];
P0=Rot.P0a;
P1=Rot.P1a;
U0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U0a];
U1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U1a];
V0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V0a];
V1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V1a];
(*Equations: *)
{tabGamF,tabKoefF,tabz,enac2}=ComputeEqForG2PHInt7[U0,U1,V0,V1,P0,P1,x,y,z,ξ];
(*Print["Admissible solutions: "]*)
sol=Quiet[{x,y,z}/.NSolve[(#==0)&/@(enac2/.{ξ->ksi}),{x,y,z},WorkingPrecision->NAT]];
sol=Sort[Select[sol,((Element[#[[1]],Reals]&&(#[[1]]>0))&&(Element[#[[2]],Reals])&&(Element[#[[3]],Reals]))&]];
If[Length[sol]==0,Return[{{},{},{},{},{}}]];
tabpol={};
tabKP={};
tabE={};
tabERF={};
For[jj=1,jj≤Length[sol],jj++,
(*Print["---------------------"];*)
solX=sol[[jj]];
sol1={(Subscript[λ, 0])->(Sqrt[solX[[1]]]),(Subscript[λ, 1])->ksi(Sqrt[solX[[1]]]),(Subscript[μ, 0])->solX[[2]]/(Sqrt[solX[[1]]]),(Subscript[μ, 1])->solX[[3]]/(Sqrt[solX[[1]]])};
KA=SolForG2PHInt[U0,U1,V0,V1,solX[[1]],solX[[2]],solX[[3]],ksi];
KA=Table[KvaternionProd[U0a/Norma[U0a],KA[[i]]],{i,1,Length[KA]}];
KAPol=Plus@@Table[KA[[i+1]]bernstein[t,3,i],{i,0,3}];
ERFrame=1/Norma[KAPol]^2{Rest[OPStar[KAPol,KAPol]],Rest[OPStar2[KAPol,KAPol]],Rest[OPStar3[KAPol,KAPol]]};
(*Compute PH interpolants: *)
{pol7,KP,loc}=PHCurveOfDegree7[KA,Inverse[Rot].P0,t];
(* --------- *)
pomLen=(Plus@@Table[Norma[KP[[i+1]]-KP[[i]]],{i,1,Length[KP]-1}])/Norma[P1a-P0a];
(*Length of the control polygon: ",pomLen];*)
pom=D[ERFrame[[2]],t].ERFrame[[3]];
(*Plot[Abs[pom],{t,0,1},PlotRange->All];*)
pomW=Max[Table[Abs[pom]/.{t->i},{i,0,1,0.001}]];
(*Print["Total rotation: ",pomW];*)
(* --------------- *)
tabpol=Append[tabpol,pol7];
tabKP=Append[tabKP,KP];
tabE=Append[tabE,{pomLen,pomW}];
tabERF=Append[tabERF,ERFrame];
];
Return[{sol,tabpol,tabKP,tabERF,tabE}]
]

ClearAll[SepticPHInterpolant1]
SepticPHInterpolant1[t_,P0a_,P1a_,U0a_,U1a_,V0a_,V1a_,ksi_,NAT_]:=Module[{Rot,P0,P1,U0,U1,V0,V1,tabGamF,tabKoefF,tabz,enac2,x,y,z,ξ,sol,tabpol,tabpolA,tabKP,tabE,tabERF,jj,solX,sol1,λ,μ,KA,KP,pol7,KAPol,ERFrame,loc,pomLen,pom,pomW},
(*We need to rotate the data: *)
Rot=Inverse[Rotacija[U0a][[3]]];
P0=Rot.P0a;
P1=Rot.P1a;
U0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U0a];
U1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U1a];
V0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V0a];
V1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V1a];
(*Equations: *)
{tabGamF,tabKoefF,tabz,enac2}=ComputeEqForG2PHInt7[U0,U1,V0,V1,P0,P1,x,y,z,ξ];
(*Print["Admissible solutions: "]*)
sol=Quiet[{x,y,z}/.NSolve[(#==0)&/@(enac2/.{ξ->ksi}),{x,y,z},WorkingPrecision->NAT]];
sol=Sort[Select[sol,((Element[#[[1]],Reals]&&(#[[1]]>0))&&(Element[#[[2]],Reals])&&(Element[#[[3]],Reals]))&]];
If[Length[sol]==0,Return[{{},{},{},{},{}}]];
tabpol={};
tabpolA={};
tabKP={};
tabE={};
tabERF={};
For[jj=1,jj≤Length[sol],jj++,
(*Print["---------------------"];*)
solX=sol[[jj]];
sol1={(Subscript[λ, 0])->(Sqrt[solX[[1]]]),(Subscript[λ, 1])->ksi(Sqrt[solX[[1]]]),(Subscript[μ, 0])->solX[[2]]/(Sqrt[solX[[1]]]),(Subscript[μ, 1])->solX[[3]]/(Sqrt[solX[[1]]])};
KA=SolForG2PHInt[U0,U1,V0,V1,solX[[1]],solX[[2]],solX[[3]],ksi];
KA=Table[KvaternionProd[U0a/Norma[U0a],KA[[i]]],{i,1,Length[KA]}];
KAPol=Plus@@Table[KA[[i+1]]bernstein[t,3,i],{i,0,3}];
ERFrame=1/Norma[KAPol]^2{Rest[OPStar[KAPol,KAPol]],Rest[OPStar2[KAPol,KAPol]],Rest[OPStar3[KAPol,KAPol]]};
(*Compute PH interpolants: *)
{pol7,KP,loc}=PHCurveOfDegree7[KA,Inverse[Rot].P0,t];
(* --------- *)
pomLen=(Plus@@Table[Norma[KP[[i+1]]-KP[[i]]],{i,1,Length[KP]-1}])/Norma[P1a-P0a];
(*Length of the control polygon: ",pomLen];*)
pom=D[ERFrame[[2]],t].ERFrame[[3]];
(*Plot[Abs[pom],{t,0,1},PlotRange->All];*)
pomW=Max[Table[Abs[pom]/.{t->i},{i,0,1,0.001}]];
(*Print["Total rotation: ",pomW];*)
(* --------------- *)
tabpol=Append[tabpol,pol7];
tabpolA=Append[tabpolA,KAPol];
tabKP=Append[tabKP,KP];
tabE=Append[tabE,{pomLen,pomW}];
tabERF=Append[tabERF,ERFrame];
];
Return[{sol,tabpol,tabKP,tabpolA,tabERF,tabE}]
]

ClearAll[AsymptoticCond]
AsymptoticCond[curveR_,t_]:=Module[{sig,pomT,pomC,cond1,cond2},
sig=Norma[D[curveR,t]];
pomT=Torsion[curveR,t];
pomC=Ukriv[curveR,t];
cond1=(D[pomT,{t,2}]/pomT)-(D[pomC,{t,2}]/pomC);
cond2=3((D[sig,t]/sig))((D[pomT,{t,1}])/(pomT)-(D[pomC,{t,1}])/(pomC));
Return[cond1+cond2]
]

ClearAll[RMFrame]
RMFrame[x_,t_,RR_,tt_,nn_,bb_,NAT_]:=Module[{tor,ww,theta,R1,R2,R3},
tor=Det[{D[RR,t],D[RR,{t,2}],D[RR,{t,3}]}]/(Cross[D[RR,t],D[RR,{t,2}]].Cross[D[RR,t],D[RR,{t,2}]]);
ww=Simplify[tor (Sqrt[(D[RR,t].D[RR,t])]) ];
theta=NIntegrate[ww,{t,0,x},WorkingPrecision->NAT,PrecisionGoal->NAT];
R1=tt;
R2=Cos[theta]nn-Sin[theta]bb;
R3=Sin[theta]nn+Cos[theta]bb;
Return[{R1,R2,R3}/.{t->x}];
]

ClearAll[SelectKsi]
(* Compute parameter ksi (from a set {ksi0:step:ksi1}) that gives the minimum of E_weight. *)
SelectKsi[ksi0_,ksi1_,step_,weight_,P0_,P1_,U0_,U1_,V0_,V1_,NAT_]:=Module[{t,TabKsi,kk,izbKsi,sol,tabpol,tabKP,tabERF,tabE,ind,j,FunE,TABE,minI,pom},
TabKsi=Table[i,{i,ksi0,ksi1,step}];
TABE={};
For[kk=1,kk≤Length[TabKsi],kk++,
izbKsi=TabKsi[[kk]];
(*Print["Chosen ξ: ",izbKsi];*)
{sol,tabpol,tabKP,tabERF,tabE}=SepticPHInterpolant[t,P0,P1,U0,U1,V0,V1,izbKsi,NAT];
FunE={};
If[Length[sol]≠0,
ind=1;
For[j=2,j<=Length[sol],j++,
(* we choose the interpolant with the smallest length and smallest w (with respect to given weight) *)
If[((1-weight)tabE[[j,1]]+weight tabE[[j,2]])<((1-weight)tabE[[ind,1]]+weight tabE[[ind,2]]),
ind=j;
];
];
FunE=tabE[[ind]];
];
TABE=Append[TABE,FunE];
];
minI=1;
pom={{TabKsi[[1]],(1-weight)TABE[[1,1]]+weight TABE[[1,2]]}};
For[kk=2,kk≤Length[TABE],kk++,
If[Length[TABE[[kk]]]≠0,
pom=Append[pom,{TabKsi[[kk]],(1-weight)TABE[[kk,1]]+weight TABE[[kk,2]]}];
If[(1-weight)TABE[[kk,1]]+weight TABE[[kk,2]]<(1-weight)TABE[[minI,1]]+weight TABE[[minI,2]],minI=kk],
pom=Append[pom,{}];
];
];
Return[{TabKsi[[minI]],pom}]
]

ClearAll[SelectKsi1]
(* Compute parameter ksi (from a set TabKsi) that gives the minimum of E_weight. *)
SelectKsi1[TabKsi_,weight_,P0_,P1_,U0_,U1_,V0_,V1_,NAT_]:=Module[{t,kk,izbKsi,sol,tabpol,tabKP,tabERF,tabE,ind,j,FunE,TABE,minI,pom},
TABE={};
For[kk=1,kk≤Length[TabKsi],kk++,
izbKsi=TabKsi[[kk]];
(*Print["Chosen ξ: ",izbKsi];*)
{sol,tabpol,tabKP,tabERF,tabE}=SepticPHInterpolant[t,P0,P1,U0,U1,V0,V1,izbKsi,NAT];
FunE={};
If[Length[sol]≠0,
ind=1;
For[j=2,j<=Length[sol],j++,
(* we choose the interpolant with the smallest length and smallest w (with respect to given weight) *)
If[((1-weight)tabE[[j,1]]+weight tabE[[j,2]])<((1-weight)tabE[[ind,1]]+weight tabE[[ind,2]]),
ind=j;
];
];
FunE=tabE[[ind]];
];
TABE=Append[TABE,FunE];
];
minI=1;
pom={{TabKsi[[1]],(1-weight)TABE[[1,1]]+weight TABE[[1,2]]}};
For[kk=2,kk≤Length[TABE],kk++,
If[Length[TABE[[kk]]]≠0,
pom=Append[pom,{TabKsi[[kk]],(1-weight)TABE[[kk,1]]+weight TABE[[kk,2]]}];
If[(1-weight)TABE[[kk,1]]+weight TABE[[kk,2]]<(1-weight)TABE[[minI,1]]+weight TABE[[minI,2]],minI=kk],
pom=Append[pom,{}];
];
];
Return[{TabKsi[[minI]],pom}]
]

ClearAll[MinOfSet]
MinOfSet[M_]:=Module[{ind,m,i},
ind=1;
m=M[[1]];
For[i=2,i≤Length[M],i++,
If[M[[i]]<m, ind=i;m=M[[i]]]
];
Return[{ind,m}]
]

G^2 PH curves of degree 7 with G^1 ER frame

Derivation of equations

ClearAll[t,a]
Print["Cubic quaternion polynomial: "]
ClearAll[a]
KA={{a00,a01,a02,a03},{a10,a11,a12,a13},{a20,a21,a22,a23},{a30,a31,a32,a33}};
AA=Plus@@Table[KA[[i+1]]bernstein[t,3,i],{i,0,3}]
Print["Hodograph (directly): "]
hodA=Rest[Simplify[OPStar[AA,AA]]]

Print["Control points of a hodograph: "]
ClearAll[hh]
(Subscript[hh, 0])=Rest[OPStar[KA[[1]],KA[[1]]]];
(Subscript[hh, 1])=Rest[OPStar[KA[[1]],KA[[2]]]];
(Subscript[hh, 2])=1/5Rest[2OPStar[KA[[1]],KA[[3]]]+3OPStar[KA[[2]],KA[[2]]]];
(Subscript[hh, 3])=1/10Rest[OPStar[KA[[1]],KA[[4]]]+9OPStar[KA[[2]],KA[[3]]]];
(Subscript[hh, 4])=1/5Rest[2OPStar[KA[[2]],KA[[4]]]+3OPStar[KA[[3]],KA[[3]]]];
(Subscript[hh, 5])=Rest[OPStar[KA[[3]],KA[[4]]]];
(Subscript[hh, 6])=Rest[OPStar[KA[[4]],KA[[4]]]];
Print["Hodograph from control vectors:"]
Hod=Plus@@Table[(Subscript[hh, i])bernstein[t,6,i],{i,0,6}];
Print["Let us check:"]
Rest[Simplify[OPStar[AA,AA]]]-Hod//Simplify

Print["Control points of a septic curve: "]
ClearAll[pp]
(Subscript[pp, 0])={(Subscript[ppx, 0]),(Subscript[ppy, 0]),(Subscript[ppz, 0])};
(Subscript[pp, 1])=(Subscript[pp, 0])+1/7(Subscript[hh, 0]);
(Subscript[pp, 2])=(Subscript[pp, 0])+1/7((Subscript[hh, 0])+(Subscript[hh, 1]));
(Subscript[pp, 3])=(Subscript[pp, 0])+1/7((Subscript[hh, 0])+(Subscript[hh, 1])+(Subscript[hh, 2]));
(Subscript[pp, 4])=(Subscript[pp, 0])+1/7((Subscript[hh, 0])+(Subscript[hh, 1])+(Subscript[hh, 2])+(Subscript[hh, 3]));
(Subscript[pp, 5])=(Subscript[pp, 0])+1/7((Subscript[hh, 0])+(Subscript[hh, 1])+(Subscript[hh, 2])+(Subscript[hh, 3])+(Subscript[hh, 4]));
(Subscript[pp, 6])=(Subscript[pp, 0])+1/7((Subscript[hh, 0])+(Subscript[hh, 1])+(Subscript[hh, 2])+(Subscript[hh, 3])+(Subscript[hh, 4])+(Subscript[hh, 5]));
(Subscript[pp, 7])=(Subscript[pp, 0])+1/7((Subscript[hh, 0])+(Subscript[hh, 1])+(Subscript[hh, 2])+(Subscript[hh, 3])+(Subscript[hh, 4])+(Subscript[hh, 5])+(Subscript[hh, 6]));
Print["PH curve: "]
curve=Plus@@Table[(Subscript[pp, i])bernstein[t,7,i],{i,0,7}];

Print["Let us check:"]
D[curve,t]-Hod//Simplify

Print["Control points of sigma: "]
pom=Simplify[CoefficientList[First[Simplify[KvaternionProd[AA,KvaternionConj[AA]]]],t]];
CoefSigma=Simplify[BezKoef[6,pom]];
Print["Length of the curve: "]
locnaA=Simplify[1/7Plus@@CoefSigma]

Print["Given data: "]
ClearAll[px,py,pz,qq,q,u]
P0={0,0,0}
P1={px,py,pz}
Print["Given frames (quaternions Q0, Q1): "]
U0={(Subscript[q, 0,0]),(Subscript[q, 0,1]),(Subscript[q, 0,2]),(Subscript[q, 0,3])}/.{(Subscript[q, 0,0])->qq,(Subscript[q, 0,1])->0,(Subscript[q, 0,2])->0,(Subscript[q, 0,3])->0}
U1={(Subscript[q, 0]),(Subscript[q, 1]),(Subscript[q, 2]),(Subscript[q, 3])}
Print["Given curvature quaternions U0, U1: "]
V0={(Subscript[u, 0,0]),(Subscript[u, 0,1]),(Subscript[u, 0,2]),(Subscript[u, 0,3])}
V1={(Subscript[u, 1,0]),(Subscript[u, 1,1]),(Subscript[u, 1,2]),(Subscript[u, 1,3])}

ClearAll[λ,μ]
Print["Determine the quaternions A0, A1, A3, A2: "]
resKA=Join[{(Subscript[ppx, 0])->P0[[1]],(Subscript[ppy, 0])->P0[[2]],(Subscript[ppz, 0])->P0[[3]]},Table[KA[[1,i]]->(Subscript[λ, 0])U0[[i]],{i,1,4}],Table[KA[[2,i]]->(Subscript[μ, 0])U0[[i]]+1/3(Subscript[λ, 0]^3)V0[[i]],{i,1,4}],Table[KA[[3,i]]->(Subscript[μ, 1])U1[[i]]-1/3(Subscript[λ, 1]^3)V1[[i]],{i,1,4}],Table[KA[[4,i]]->(Subscript[λ, 1])U1[[i]],{i,1,4}]]

Print["Equation for point interpolation: "]
eqP=Simplify[(Plus@@Table[(Subscript[hh, i]),{i,0,6}])-7(P1-P0)/.resKA]

Print["11 vectors that form the equation: "]
q00=Rest[OPStar[U0,U0]];
q11=Rest[OPStar[U1,U1]];
q01=Rest[OPStar[U0,U1]];
qu00=Rest[OPStar[U0,V0]];
qu11=Rest[OPStar[U1,V1]];
qu10=Rest[OPStar[U1,V0]];
qu01=Rest[OPStar[U0,V1]];
u00=Rest[OPStar[V0,V0]];
u11=Rest[OPStar[V1,V1]];
u01=Rest[OPStar[V0,V1]];
tabKoef={q00,q11,q01,qu00,qu11,qu10,qu01,u00,u11,u01,P1-P0};

Print["Corresponding coefficients: "]
gam1A=1/5(5(Subscript[λ, 0])^2+5 (Subscript[λ, 0])(Subscript[μ, 0])+ 3(Subscript[μ, 0])^2);
gam2A=1/5(5(Subscript[λ, 1])^2+5 (Subscript[λ, 1])(Subscript[μ, 1])+ 3(Subscript[μ, 1])^2);
gam3A=1/10(4 (Subscript[λ, 1])(Subscript[μ, 0]) +4 (Subscript[λ, 0])(Subscript[μ, 1])+(Subscript[λ, 0])(Subscript[λ, 1])+9 (Subscript[μ, 0])(Subscript[μ, 1]));
gam4A=1/15(6(Subscript[λ, 0])^3(Subscript[μ, 0])+5(Subscript[λ, 0])^4);
gam5A=-1/15(6(Subscript[λ, 1])^3(Subscript[μ, 1])+5(Subscript[λ, 1])^4);
gam6A=1/30(9(Subscript[λ, 0])^3(Subscript[μ, 1])+4(Subscript[λ, 1])(Subscript[λ, 0])^3);
gam7A=-1/30(9(Subscript[λ, 1])^3(Subscript[μ, 0])+4(Subscript[λ, 0])(Subscript[λ, 1])^3);
gam8A=1/15(Subscript[λ, 0])^6;
gam9A=1/15(Subscript[λ, 1])^6;
gam10A=-1/10(Subscript[λ, 0])^3(Subscript[λ, 1])^3;
gam11A=-7;
tabGamA={gam1A,gam2A,gam3A,gam4A,gam5A,gam6A,gam7A,gam8A,gam9A,gam10A,gam11A};
Print["Equations expressed with gammas:"]
eqP1A=Plus@@Table[tabGamA[[i]]tabKoef[[i]],{i,1,11}]
Print["Let us check:"]
Simplify[eqP1A-eqP]

Print["We introduce new unknowns: "]
newUnknowns={(Subscript[λ, 0])->(Sqrt[x]),(Subscript[λ, 1])->ξ(Sqrt[x]),(Subscript[μ, 0])->y/(Sqrt[x]),(Subscript[μ, 1])->z/(Sqrt[x])}
Solve[{(Subscript[λ, 0])==(Sqrt[x]),(Subscript[λ, 1])==ξ(Sqrt[x]),(Subscript[μ, 0])==y/(Sqrt[x]),(Subscript[μ, 1])==z/(Sqrt[x])},{x,y,z,ξ}]

Print["New coefficients gamma:"]
ClearAll[x,y,z,ξ]
gam1=1/5(5x^2+5 x y + 3y^2);
gam2=1/5(5ξ^2x^2+5ξ x z+3z^2);
gam3=1/10(4 ξ x y +4 x z+ξ x^2+9 y z);
gam4=1/15x^2(6y+5x);
gam5=-1/15ξ^3x^2(6 z+5ξ x);
gam6=1/30x^2(9z+4ξ x);
gam7=-1/30ξ^3x^2(9y+4x);
gam8=1/15x^4;
gam9=1/15ξ^6x^4;
gam10=-1/10ξ^3x^4;
gam11=-7x;
tabGam={gam1,gam2,gam3,gam4,gam5,gam6,gam7,gam8,gam9,gam10,gam11}
Print["Let us check: "]
Simplify[tabGam-Simplify[x tabGamA/.newUnknowns]]

Print["Equations expressed with gamma:"]
eqP1=Plus@@Table[tabGam[[i]]tabKoef[[i]],{i,1,11}]
Print["Let us check:"]
Simplify[eqP1/.{x->(Subscript[λ, 0])^2,ξ->(Subscript[λ, 1])/(Subscript[λ, 0]),y->(Subscript[μ, 0])(Subscript[λ, 0]),z->(Subscript[μ, 1])(Subscript[λ, 0])}]-(Subscript[λ, 0]^2) eqP//Simplify

(* We do some further transformation of equations. *)
pom=Simplify[Flatten[Solve[{q00.{a1,a2,a3}==0,q11.{a1,a2,a3}==0},{a1,a2}]]];
vec1=Simplify[{a1,a2,a3}/.pom/.{a3->U1[[2]]U1[[3]]+U1[[1]]U1[[4]] }];
pom=Simplify[Flatten[Solve[{q00.{a1,a2,a3}==0,q01.{a1,a2,a3}==0},{a1,a2}]]];
vec2={a1,a2,a3}/.pom/.{a3->U1[[4]]};
pom=Simplify[Flatten[Solve[{q11.{a1,a2,a3}==0,q01.{a1,a2,a3}==0},{a1,a2}]]];
vec3=Simplify[{a1,a2,a3}/.pom/.{a3->2 U1[[1]] U1[[2]] U1[[3]]+U1[[1]]^2 U1[[4]]+U1[[4]] (-U1[[2]]^2+U1[[3]]^2+U1[[4]]^2)}];

Print["3 orthogonal vectors: "]
pom=Simplify[Flatten[Solve[{q00.{a1,a2,a3}==0,q11.{a1,a2,a3}==0},{a1,a2}]]];
vec1=Simplify[{a1,a2,a3}/.pom/.{a3->(Subscript[q, 1]) (Subscript[q, 2])+(Subscript[q, 0]) (Subscript[q, 3])}]

pom=Simplify[Flatten[Solve[{q00.{a1,a2,a3}==0,q01.{a1,a2,a3}==0},{a1,a2}]]];
vec2={a1,a2,a3}/.pom/.{a3->(Subscript[q, 3])}

pom=Simplify[Flatten[Solve[{q11.{a1,a2,a3}==0,q01.{a1,a2,a3}==0},{a1,a2}]]];
vec3=Simplify[{a1,a2,a3}/.pom/.{a3->2 (Subscript[q, 0]) (Subscript[q, 1]) (Subscript[q, 2])+(Subscript[q, 0]^2) (Subscript[q, 3])+(Subscript[q, 3]) (-(Subscript[q, 1]^2)+(Subscript[q, 2]^2)+(Subscript[q, 3]^2))}]

Print["The determinant of the matrix:"]
Simplify[Det[{vec1,vec2,vec3} ]]

Print["New equations: "]
e1=Collect[eqP.vec1,{ (Subscript[μ, 0]), (Subscript[μ, 1])}];
e2=Collect[eqP.vec2,{ (Subscript[μ, 0]), (Subscript[μ, 1])}];
e3=Collect[eqP.vec3,{ (Subscript[μ, 0]), (Subscript[μ, 1])}];

Print["Symmetry: "]
(e1/.{(Subscript[λ, 0])->-(Subscript[λ, 0]),(Subscript[λ, 1])->-(Subscript[λ, 1]),(Subscript[μ, 0])->-(Subscript[μ, 0]),(Subscript[μ, 1])->-(Subscript[μ, 1])})-e1//Simplify
(e2/.{(Subscript[λ, 0])->-(Subscript[λ, 0]),(Subscript[λ, 1])->-(Subscript[λ, 1]),(Subscript[μ, 0])->-(Subscript[μ, 0]),(Subscript[μ, 1])->-(Subscript[μ, 1])})-e2//Simplify
(e3/.{(Subscript[λ, 0])->-(Subscript[λ, 0]),(Subscript[λ, 1])->-(Subscript[λ, 1]),(Subscript[μ, 0])->-(Subscript[μ, 0]),(Subscript[μ, 1])->-(Subscript[μ, 1])})-e3//Simplify

Print["Equations in new variables: "]
e1A=x Simplify[e1/.{(Subscript[λ, 0])->(Sqrt[x]),(Subscript[λ, 1])->ξ(Sqrt[x]),(Subscript[μ, 0])->y/(Sqrt[x]),(Subscript[μ, 1])->z/(Sqrt[x])}];
e2A= x Simplify[e2/.{(Subscript[λ, 0])->(Sqrt[x]),(Subscript[λ, 1])->ξ(Sqrt[x]),(Subscript[μ, 0])->y/(Sqrt[x]),(Subscript[μ, 1])->z/(Sqrt[x])}];
e3A=x  Simplify[e3/.{(Subscript[λ, 0])->(Sqrt[x]),(Subscript[λ, 1])->ξ(Sqrt[x]),(Subscript[μ, 0])->y/(Sqrt[x]),(Subscript[μ, 1])->z/(Sqrt[x])}];

Print["Let us check:"]
Simplify[eqP1.vec1]-e1A//Simplify
Simplify[eqP1.vec2]-e2A//Simplify
Simplify[eqP1.vec3]-e3A//Simplify

ClearAll[ζ]
Print["Coefficients ζ: "]
(Subscript[ζ, 3])=-Simplify[q01.vec1];
(Subscript[ζ, 1])=2qq (Subscript[ζ, 3]);
(Subscript[ζ, 2])=2/qq (Subscript[ζ, 3]);
Print["Check: "]
{(Subscript[ζ, 1])-Simplify[q00.vec3],(Subscript[ζ, 2])-Simplify[q11.vec2],(Subscript[ζ, 3])-(-Simplify[q01.vec1])}
For[j=4,j≤11,j++,
(Subscript[ζ, j-2,1])=Simplify[tabKoef[[j]].vec1];
(Subscript[ζ, j-2,2])=Simplify[tabKoef[[j]].vec2];
(Subscript[ζ, j-2,3])=Simplify[tabKoef[[j]].vec3];
]

Print["Equations expressed with zetas: "]
e1B=-(Subscript[ζ, 3])tabGam[[3]]+Plus@@Table[(Subscript[ζ, j-2,1])tabGam[[j]],{j,4,11}];
e2B=2/qq (Subscript[ζ, 3])tabGam[[2]]+Plus@@Table[(Subscript[ζ, j-2,2])tabGam[[j]],{j,4,11}];
e3B=2 qq (Subscript[ζ, 3])tabGam[[1]]+Plus@@Table[(Subscript[ζ, j-2,3])tabGam[[j]],{j,4,11}];
Print["Let us check: "]
{e1A-e1B,e2A-e2B,e3A-e3B}//Simplify

(* We use a function 'ComputeEqForG2PHInt7' to compute equations: *){tabGamF,tabKoefF,tabz,enac2}=ComputeEqForG2PHInt7[U0,U1,V0,V1,P0,P1,x,y,z,ξ];

Print["Let us check: "]
enac2-{e1B,e2B,e3B}

Print["Symbolic equations: "]
ClearAll[ζζ]
e1S=-(Subscript[ζζ, 1]) tabGam[[3]]+Plus@@Table[(Subscript[ζζ, j-2,1])tabGam[[j]],{j,4,11}];
e2S=2/qq (Subscript[ζζ, 1]) tabGam[[2]]+Plus@@Table[(Subscript[ζζ, j-2,2])tabGam[[j]],{j,4,11}];
e3S=2qq (Subscript[ζζ, 1])  tabGam[[1]]+Plus@@Table[(Subscript[ζζ, j-2,3])tabGam[[j]],{j,4,11}];

symZeta=Join[Table[(Subscript[ζζ, j,1])->(Subscript[ζ, j,1]),{j,4,11}],Table[(Subscript[ζζ, j,2])->(Subscript[ζ, j,2]),{j,4,11}],Table[(Subscript[ζζ, j,3])->(Subscript[ζ, j,3]),{j,4,11}],Table[(Subscript[ζζ, j])->(Subscript[ζ, j]),{j,1,3}]];

Print["Degrees of unknowns involved in equations: "]
(*{Length[CoefficientList[e1S,ξ]],Length[CoefficientList[e2S,ξ]],Length[CoefficientList[e3S,ξ]]}-1*)
{Length[CoefficientList[e1S,x]],Length[CoefficientList[e2S,x]],Length[CoefficientList[e3S,x]]}-1
{Length[CoefficientList[e1S,y]],Length[CoefficientList[e2S,y]],Length[CoefficientList[e3S,y]]}-1
{Length[CoefficientList[e1S,z]],Length[CoefficientList[e2S,z]],Length[CoefficientList[e3S,z]]}-1

(* --- we first eliminate z ------------ *)

resZ1=z/.Simplify[Solve[Simplify[e3B]==0,z]][[1]];

resZ=Simplify[30(tabGam[[1]]2qq (Subscript[ζ, 3])+tabGam[[4]](Subscript[ζ, 2,3])+(Plus@@Table[(Subscript[ζ, j-2,3])tabGam[[j]],{j,7,11}]))-10ξ^4x^3(Subscript[ζ, 3,3])+4ξ x^3(Subscript[ζ, 4,3])]/(3x^2(4ξ^3(Subscript[ζ, 3,3])-3(Subscript[ζ, 4,3])));

resZ-resZ1//Simplify

Print["Solution z symbolically: "]
resZ=Simplify[30(tabGam[[1]]2 qq (Subscript[ζζ, 1])+tabGam[[4]](Subscript[ζζ, 2,3])+(Plus@@Table[(Subscript[ζζ, j-2,3])tabGam[[j]],{j,7,11}]))-10ξ^4x^3(Subscript[ζζ, 3,3])+4ξ x^3(Subscript[ζζ, 4,3])]/(3x^2(4ξ^3(Subscript[ζζ, 3,3])-3(Subscript[ζζ, 4,3])))

Print["Denominator: "]
denom=(3x^2(4ξ^3(Subscript[ζζ, 3,3])-3(Subscript[ζζ, 4,3])))

Print["The remaining equations: "]
r1z=Simplify[denom Together[e1S/.{z->resZ}]]
r2z=Simplify[denom^2 Together[e2S/.{z->resZ}]]

Print["Degrees of unknowns involved in these two equations: "]
{Length[CoefficientList[r1z,x]],Length[CoefficientList[r2z,x]]}-1
{Length[CoefficientList[r1z,y]],Length[CoefficientList[r2z,y]]}-1
(*{Length[CoefficientList[r1z,ξ]],Length[CoefficientList[r2z,ξ]]}-1*)

Print["Resultant: "]
rezz=Resultant[r1z,r2z,y];

Print["Coefficients of the final resultant polynomial: "]
klrezz=CoefficientList[rezz,x];
Print["Degree of the final resultant polynomial: "]
Length[klrezz]-1

Print["First 12 coefficients: "]
Table[klrezz[[i]],{i,1,12}]

Print["Coefficient at x^12: "]
koef12=Simplify[klrezz[[13]]]

Print["We eliminate a factor 18^7 7^4 (Subscript[ζ, 1]^9) (4 (ξ^3) (Subscript[ζ, 3, 3])-3 (Subscript[ζ, 4, 3]))^4: "]
klrezz1=Drop[klrezz/( 18^7 7^4(Subscript[ζζ, 1]^9) (((4 (ξ^3) (Subscript[ζζ, 3,3])-3 (Subscript[ζζ, 4,3])))^4)),{1,12}];

Print["Coefficient at x^12 after this factor is eliminated: "]
Simplify[klrezz1[[1]]]
Print["Coefficient at x^13 after this factor is eliminated: "]
Simplify[klrezz1[[2]]]

(*Print["Degrees of ξ at the coefficients of resultant polynomial of degree 12: "]
For[i=1,i≤13,i++,
Print[Length[CoefficientList[klrezz1[[i]],ξ]]-1]
]*)

(*pom=CoefficientList[klrezz1[[13]],ξ];
Table[{pom[[3i+2]],pom[[3i+3]]},{i,0,7}]*)

(*pom1=klrezz[[25]]/.{ξ->(w^(1/3))};
pom2z=CoefficientList[pom1,w];
Length[pom2z]*)

(* ------------------------------------------------------------------------ *)
(* --- We would get a similar resultant if we would first eliminate y ------------ *)

Print["Solution y: "]
resY=y/.Simplify[Solve[e2S==0,y]][[1]]

resY1=Simplify[30(tabGam[[2]]2/qq (Subscript[ζζ, 1])+tabGam[[5]](Subscript[ζζ, 3,2])+tabGam[[6]](Subscript[ζζ, 4,2])+(Plus@@Table[(Subscript[ζζ, j-2,2])tabGam[[j]],{j,8,11}]))+10x^3(Subscript[ζζ, 2,2])-4ξ^3 x^3(Subscript[ζζ, 5,2])]/(3 x^2(3ξ^3(Subscript[ζζ, 5,2])-4(Subscript[ζζ, 2,2])));

Simplify[resY1-resY]

denom=Denominator[resY1];
r1y=Simplify[denom Together[e1S/.{y->resY}]];
r2y=Simplify[denom^2 Together[e3S/.{y->resY}]];

Print["Final resultant: "]
rezy=Resultant[r1y,r2y,z];

Print["Its coefficients: "]
klrezy=CoefficientList[rezy,x];
Print["Degree of the resultant: "]
Length[klrezy]-1
Print["First 12 coefficients: "]
Table[klrezy[[i]],{i,1,12}]

Examples

Example 1

Print["Chosen data: "]
P0p={0,0,0};
P1p={6,7,4};
U0p={1,0,0,0};
U1p=1/Sqrt[9]{1,-2,0,2};
V0p=1/4{0,1,0,1};
V1p= 1/2{-2,1,0,1};
MatrixRank[{U0p,U1p,V0p,V1p}]

Print["Compute equations: "]
{tabGamF,tabKoefF,tabz,enac2}=ComputeEqForG2PHInt7[U0p,U1p,V0p,V1p,P0p,P1p,x,y,z,ξ];
(*enac1=Simplify[Plus@@Table[tabGamF[[i]]tabKoefF[[i]],{i,1,11}]];*)

izbKsi=1/2;
Print["Chosen ξ = ",izbKsi]

Print["Solution (directly): "]
pom={x,y,z}/.NSolve[(enac2/.{ξ->izbKsi})=={0,0,0},{x,y,z},WorkingPrecision->20];sol1=Select[pom,(Element[#,Reals]&&(#[[1]]>0))&];
sol=Table[{x->sol1[[i,1]],y->sol1[[i,2]],z->sol1[[i,3]]},{i,1,Length[sol1]}]

Print["Eliminate unknowns. First we eliminate z: "]
resZ1=z/.Flatten[Solve[enac2[[3]]==0,z]];
denom=Denominator[Together[resZ1]];
Print["The remaining equations: "]
r1z=Together[denom(enac2[[1]]/.{z->resZ1})];
r2z=Together[denom^2(enac2[[2]]/.{z->resZ1})];
rezz=Factor[Resultant[r1z,r2z,y]];
Simplify[Take[CoefficientList[rezz,x],{1,12}]]
Print["Resultant: "]
rezz1=rezz/x^12;

FindInstance[(rezz1==0)&&(x>0)&&(ξ>0),{ξ,x}]//N

(*FindInstance[(rezz1>0)&&(x>0)&&(ξ>0),{x,ξ}]
FindInstance[(rezz1<0)&&(x>0)&&(ξ>0),{x,ξ}]*)

resx1=Select[x/.NSolve[rezz1/.{ξ->izbKsi},x,WorkingPrecision->20],(Element[#,Reals]&&(#>0))&];
resx=Table[x->resx1[[1]],{i,1,1Length[resx1]}]

Print["Solution: "]
sol
resX={x,y,z}/.sol[[1]]

Print["PH interpolant of degree 7: "]
KAp=SolForG2PHInt[U0p,U1p,V0p,V1p,resX[[1]],resX[[2]],resX[[3]],1];
{pol7,KP,loc}=PHCurveOfDegree7[KAp,P0p,t];

Show[{ParametricPlot3D[pol7,{t,0,1},PlotStyle->RGBColor[{0,0,1}],PlotRange->All]},PlotRange->All]

Example 2

Print["Chosen data: "]
P0p={0,0,0}
P1p={RandomInteger[{-10,10}],RandomInteger[{-10,10}],RandomInteger[{-10,10}]}
Print["Chosen (random) frames: "]
U0p={1,0,0,0};
U1p={RandomInteger[{-10,10}],RandomInteger[{-10,10}],RandomInteger[{-10,10}],RandomInteger[{-10,10}]};
U1p=U1p/Norma[U1p];
Print["Chosen (random) curvature quaternions: "]
V0p={RandomInteger[{-10,10}],RandomInteger[{-10,10}],RandomInteger[{-10,10}],RandomInteger[{-10,10}]}
V1p={RandomInteger[{-10,10}],RandomInteger[{-10,10}],RandomInteger[{-10,10}],RandomInteger[{-10,10}]}
MatrixRank[{U0p,U1p,V0p,V1p}]

Print["Compute equations: "]
{tabGamF,tabKoefF,tabz,enac2}=ComputeEqForG2PHInt7[U0p,U1p,V0p,V1p,P0p,P1p,x,y,z,ξ];
(*enac1=Simplify[Plus@@Table[tabGamF[[i]]tabKoefF[[i]],{i,1,11}]];*)

izbKsi=1;
Print["Chosen ξ = ",izbKsi]

Print["Solution (directly): "]
pom={x,y,z}/.NSolve[(enac2/.{ξ->izbKsi})=={0,0,0},{x,y,z},WorkingPrecision->20];sol1=Select[pom,(Element[#,Reals]&&(#[[1]]>0))&];
sol=Table[{x->sol1[[i,1]],y->sol1[[i,2]],z->sol1[[i,3]]},{i,1,Length[sol1]}]

Print["Eliminate unknowns. First we eliminate z: "]
resZ1=z/.Flatten[Solve[enac2[[3]]==0,z]];
denom=Denominator[Together[resZ1]];
Print["The remaining equations: "]
r1z=Together[denom(enac2[[1]]/.{z->resZ1})];
r2z=Together[denom^2(enac2[[2]]/.{z->resZ1})];
rezz=Factor[Resultant[r1z,r2z,y]];
Simplify[Take[CoefficientList[rezz,x],{1,12}]]
Print["Resultant: "]
rezz1=rezz/x^12;

(*
FindInstance[(rezz1==0)&&(x>0)&&(ξ>0),{ξ,x}]//N
FindInstance[(rezz1>0)&&(x>0)&&(ξ>0),{x,ξ}]
FindInstance[(rezz1<0)&&(x>0)&&(ξ>0),{x,ξ}]*)

resx1=Select[x/.NSolve[rezz1/.{ξ->izbKsi},x,WorkingPrecision->20],(Element[#,Reals]&&(#>0))&];
resx=Table[x->resx1[[1]],{i,1,1Length[resx1]}]

Print["Solution: "]
sol
resX={x,y,z}/.sol[[1]]

Print["PH interpolant of degree 7: "]
KAp=SolForG2PHInt[U0p,U1p,V0p,V1p,resX[[1]],resX[[2]],resX[[3]],1];
{pol7,KP,loc}=PHCurveOfDegree7[KAp,P0p,t];

Show[{ParametricPlot3D[pol7,{t,0,1},PlotStyle->RGBColor[{0,0,1}],PlotRange->All]},PlotRange->All]

Asymptotic Analysis

For data sampled from the Frenet frame of the given curve

Print["First we compute the Taylor expansion of the curve with prescribed arc-length, curvature and torsion. "]
ClearAll[c,tt,nn,bb,κ,τ,σ]
do=10;
tt=Plus@@Table[(Subscript[c, 1,i])t^i,{i,0,do}];
nn=Plus@@Table[(Subscript[c, 2,i])t^i,{i,0,do}];
bb=Plus@@Table[(Subscript[c, 3,i])t^i,{i,0,do}];
curv=Plus@@Table[(Subscript[κ, i])/i!t^i,{i,0,do}];
tor=Plus@@Table[(Subscript[τ, i])/i!t^i,{i,0,do}];
sig=Plus@@Table[(Subscript[σ, i])/i!t^i,{i,0,do}];
Mat={{0,curv,0},{-curv,0,tor},{0,-tor,0}};
pomD=CoefficientList[sig (Mat.{tt,nn,bb}),t];
pomL=CoefficientList[D[{tt,nn,bb},t],t];
(* --- first component ---  *)
ddo=8;
pog1={(tt/.{t->0})->1,(nn/.{t->0})->0,(bb/.{t->0})->0};
eq=Flatten[Table[Table[pomD[[i,j]]-pomL[[i,j]],{i,1,3}],{j,1,ddo}]/.pog1];
nez=Flatten[Table[(Subscript[c, i,j]),{i,1,3},{j,1,ddo}]];
res1=Flatten[Solve[(#==0)&/@eq,nez]];
(* --- second component ---  *)
pog2={(tt/.{t->0})->0,(nn/.{t->0})->1,(bb/.{t->0})->0};
eq=Flatten[Table[Table[pomD[[i,j]]-pomL[[i,j]],{i,1,3}],{j,1,ddo}]/.pog2];
nez=Flatten[Table[(Subscript[c, i,j]),{i,1,3},{j,1,ddo}]];
res2=Flatten[Solve[(#==0)&/@eq,nez]];
(* --- third component ---  *)
pog3={(tt/.{t->0})->0,(nn/.{t->0})->0,(bb/.{t->0})->1};
eq=Flatten[Table[Table[pomD[[i,j]]-pomL[[i,j]],{i,1,3}],{j,1,ddo}]/.pog3];
nez=Flatten[Table[(Subscript[c, i,j]),{i,1,3},{j,1,ddo}]];
res3=Flatten[Solve[(#==0)&/@eq,nez]];
(* --- Expansion of Frenet frame --- *)
ttR={tt/.res1/.pog1,tt/.res2/.pog2,tt/.res3/.pog3};
nnR={nn/.res1/.pog1,nn/.res2/.pog2,nn/.res3/.pog3};
bbR={bb/.res1/.pog1,bb/.res2/.pog2,bb/.res3/.pog3};

Print["Given curve:"]
do=6;
tan=Normal[Series[sig ttR,{t,0,ddo}]];
curveR=Normal[Series[Integrate[tan,{t,0,s}],{s,0,do+1}]]

(* Frenet Frame *)
FFrame=Frene[curveR,s];
Print["Frenet frame at s=0: "]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[FFrame/.{s->0}]]
Print["Expansion of curvature κ(s): "]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[Norma[Cross[D[curveR,s],D[curveR,{s,2}]]]/Norma[D[curveR,s]]^3,{s,0,5}]]]
Print["Expansion of torsion τ(s): "]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[Det[{D[curveR,s],D[curveR,{s,2}],D[curveR,{s,3}]}]/Norma[Cross[D[curveR,s],D[curveR,{s,2}]]]^2,{s,0,4}]]]
Print["Expansion of arc-length function: "]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[Norma[D[curveR,s]],{s,0,5}]]]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[FFrame[[1]]-(ttR/.{t->s}),{s,0,5}]]]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[FFrame[[2]]-(nnR/.{t->s}),{s,0,5}]]]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[FFrame[[3]]-(bbR/.{t->s}),{s,0,5}]]]

Print["We compute a quaternion polynomial U1(s) from the Frenet frame (using the inverse kinematic mapping): "]
MR=Transpose[FFrame];
curveQ1={1+MR[[1,1]]+MR[[2,2]]+MR[[3,3]],MR[[3,2]]-MR[[2,3]],MR[[1,3]]-MR[[3,1]],MR[[2,1]]-MR[[1,2]]};
curveQ=Simplify[Assuming[(s>0)&&((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Normal[Series[Sqrt[Norma[D[curveR,s]]] (curveQ1/Norma[curveQ1]),{s,0,do}]]]];
Simplify[Series[curveQ,{s,0,4}]]

Print["We compute the interpolation data: "]
ClearAll[h]
P0=curveR/.{s->0};
P1=curveR/.{s->h};
U0=curveQ/.{s->0};
U1=curveQ/.{s->h};
V0=D[curveQ,s]/.{s->0};
V1=D[curveQ,s]/.{s->h};
Print["P0 = ", P0]
Print["U0 = ", U0]
Print["V0 = ", V0]
Print["P1 = ", Series[P1,{h,0,3}]]
Print["U1 = ", Series[U1,{h,0,3}]]
Print["V1 = ",Series[V1,{h,0,3}]]

Print["Bezier coefficients of a quaternion polynomial: "]
KAp=SolForG2PHInt[U0,U1,V0,V1,x,y,z,ξ]
Print["PH interpolant of degree 7, its control points and its arc-length function: "]
{pol7,KP,loc}=PHCurveOfDegree7[KAp,P0,t];
Print["Reparameterization function: "]
ClearAll[λ,μ]
rep=Simplify[InterpolatingPolynomial[{{0,{0,(Subscript[λ, 0])^2,6(Subscript[λ, 0])((Subscript[μ, 0])-(Subscript[λ, 0]))}},{1,{h,(Subscript[λ, 1])^2,6(Subscript[λ, 1])(-(Subscript[μ, 1])+(Subscript[λ, 1]))}}}/.{(Subscript[λ, 0])->(Sqrt[x]),(Subscript[λ, 1])->ξ(Sqrt[x]),(Subscript[μ, 0])->y/(Sqrt[x]),(Subscript[μ, 1])->z/(Sqrt[x])},t]]

Print["Compute nonlinear equations. "]
ClearAll[x,y,z]
q00=Rest[OPStar[U0,U0]];
q11=Rest[OPStar[U1,U1]];
q01=Rest[OPStar[U0,U1]];
qu00=Rest[OPStar[U0,V0]];
qu11=Rest[OPStar[U1,V1]];
qu10=Rest[OPStar[U1,V0]];
qu01=Rest[OPStar[U0,V1]];
u00=Rest[OPStar[V0,V0]];
u11=Rest[OPStar[V1,V1]];
u01=Rest[OPStar[V0,V1]];
tabKoef={q00,q11,q01,qu00,qu11,qu10,qu01,u00,u11,u01,P1-P0};
Print["(Subscript[γ, i]), i=1,...,11: "]
tabGam={(1/5) (5 (x^2)+5 x y+3 (y^2)),(1/5) (3 (z^2)+5 x z ξ+5 (x^2) (ξ^2)),(1/10) (4 x z+9 y z+(x^2) ξ+4 x y ξ),(1/15) (x^2) (5 x+6 y),-(1/15) (x^2) (ξ^3) (6 z+5 x ξ),(1/30) (x^2) (9 z+4 x ξ),-(1/30) (x^2) (4 x+9 y) (ξ^3),((x^4)/15),(((x^4) (ξ^6))/15),-(1/10) (x^4) (ξ^3),-7 x};
tabGam//MatrixForm
Print["Vectors (Subscript[U, 0]^(2* )), (Subscript[U, 1]^(2* )), (Subscript[U, 0])*(Subscript[U, 1]), (Subscript[U, 0])*(Subscript[V, 0]), (Subscript[U, 1])*(Subscript[V, 1]), (Subscript[U, 1])*(Subscript[V, 0]), (Subscript[U, 0])*(Subscript[V, 1]), (Subscript[V, 0]^(2* )), (Subscript[V, 1]^(2* )), (Subscript[V, 0])*(Subscript[V, 1]), (Subscript[P, 1])-(Subscript[P, 0]): "]
Series[tabKoef,{h,0,2}]
eq=Plus@@Table[tabGam[[i]]tabKoef[[i]],{i,1,11}];

Print["Compute coefficients ζ: "]
ClearAll[q,ζ]
vec1={0,(Subscript[q, 0]) (Subscript[q, 2])-(Subscript[q, 1]) (Subscript[q, 3]),(Subscript[q, 1]) (Subscript[q, 2])+(Subscript[q, 0]) (Subscript[q, 3])}/.{(Subscript[q, 0])->U1[[1]],(Subscript[q, 1])->U1[[2]],(Subscript[q, 2])->U1[[3]],(Subscript[q, 3])->U1[[4]]};
vec2={0,(Subscript[q, 2]),(Subscript[q, 3])}/.{(Subscript[q, 0])->U1[[1]],(Subscript[q, 1])->U1[[2]],(Subscript[q, 2])->U1[[3]],(Subscript[q, 3])->U1[[4]]};
vec3={2 (Subscript[q, 1]) ((Subscript[q, 2]^2)+(Subscript[q, 3]^2)),(Subscript[q, 0]^2) (Subscript[q, 2])-2 (Subscript[q, 0]) (Subscript[q, 1]) (Subscript[q, 3])+(Subscript[q, 2]) (-(Subscript[q, 1]^2)+(Subscript[q, 2]^2)+(Subscript[q, 3]^2)),2 (Subscript[q, 0]) (Subscript[q, 1]) (Subscript[q, 2])+(Subscript[q, 0]^2) (Subscript[q, 3])+(Subscript[q, 3]) (-(Subscript[q, 1]^2)+(Subscript[q, 2]^2)+(Subscript[q, 3]^2))}/.{(Subscript[q, 0])->U1[[1]],(Subscript[q, 1])->U1[[2]],(Subscript[q, 2])->U1[[3]],(Subscript[q, 3])->U1[[4]]};
(Subscript[ζ, 1])=-q01.vec1;
For[j=4,j≤11,j++,
(Subscript[ζ, j-2,1])=tabKoef[[j]].vec1;
(Subscript[ζ, j-2,2])=tabKoef[[j]].vec2;
(Subscript[ζ, j-2,3])=tabKoef[[j]].vec3;
];
tabZetas={{(Subscript[ζ, 1])},Table[(Subscript[ζ, j-2,1]),{j,4,11}],Table[(Subscript[ζ, j-2,2]),{j,4,11}],Table[(Subscript[ζ, j-2,3]),{j,4,11}]};
tabZetas=Normal[Series[tabZetas,{h,0,do}]];
Print["(Subscript[ζ, 1]) = ",Simplify[Series[(Subscript[ζ, 1]),{h,0,4}]]]
Print["{(Subscript[ζ, 2, 1]), (Subscript[ζ, 3, 1]), (Subscript[ζ, 4, 1]), (Subscript[ζ, 5, 1]), (Subscript[ζ, 6, 1]), (Subscript[ζ, 7, 1]), (Subscript[ζ, 8, 1]), (Subscript[ζ, 9, 1])} = ",Table[Simplify[Series[(Subscript[ζ, i,1]),{h,0,3}]],{i,2,9}]]
Print["{(Subscript[ζ, 2, 2]), (Subscript[ζ, 3, 2]), (Subscript[ζ, 4, 2]), (Subscript[ζ, 5, 2]), (Subscript[ζ, 6, 2]), (Subscript[ζ, 7, 2]), (Subscript[ζ, 8, 2]), (Subscript[ζ, 9, 2])} = ",Table[Simplify[Series[(Subscript[ζ, i,2]),{h,0,3}]],{i,2,9}]]
Print["{(Subscript[ζ, 2, 3]), (Subscript[ζ, 3, 3]), (Subscript[ζ, 4, 3]), (Subscript[ζ, 5, 3]), (Subscript[ζ, 6, 3]), (Subscript[ζ, 7, 3]), (Subscript[ζ, 8, 3]), (Subscript[ζ, 9, 3])} = ",Table[Simplify[Series[(Subscript[ζ, i,3]),{h,0,3}]],{i,2,9}]]

Print["Equations expressed with zetas. We multiply the second equation by (Sqrt[(Subscript[σ, 0])]) and divide the third equation by (Sqrt[(Subscript[σ, 0])]). "]
e1B=-(Subscript[ζ, 1])tabGam[[3]]+Plus@@Table[(Subscript[ζ, j-2,1])tabGam[[j]],{j,4,11}];
e2B=(2/U0[[1]] (Subscript[ζ, 1])tabGam[[2]]+Plus@@Table[(Subscript[ζ, j-2,2])tabGam[[j]],{j,4,11}])(Sqrt[(Subscript[σ, 0])]);
e3B=(2 U0[[1]] (Subscript[ζ, 1])tabGam[[1]]+Plus@@Table[(Subscript[ζ, j-2,3])tabGam[[j]],{j,4,11}])/(Sqrt[(Subscript[σ, 0])]);
Print["Taylor expansion of unknowns x,y,z: "]
ClearAll[x0,x1,x2,x3,x4,x5,x6,y0,y1,y2,y3,y4,y5,y6,z0,z1,z2,z3,z4,z5,z6]
razNez={x->(x0+x1 h+x2 h^2+x3 h^3+x4 h^4+x5 h^5+x6 h^6),y->(y0+y1 h+y2 h^2+y3 h^3+y4 h^4+y5 h^5+y6 h^6),z->(z0+z1 h+z2 h^2+z3 h^3+z4 h^4+z5 h^5+z6 h^6)}
Print["Taylor expansion of equations: "]
FullSimplify [Series[{e1B,e2B ,e3B}/.razNez,{h,0,2}]]

Print["At h^1 we have"]
FullSimplify [Series[{e1B,e2B,e3B}/.razNez,{h,0,1}]]
Print["We see that x0 has to be zero. Then the equations up to h^3 are "]
pom=Simplify [Series[{e1B,e2B,e3B}/.razNez/.{x0->0},{h,0,3}]]
Print["which implies y0=z0=0. "]
Print["For x0=y0=z0 we get "]
eqxyz1=Normal[Simplify [Series[{e1B,e2B,e3B}/.razNez/.{x0->0,y0->0,z0->0},{h,0,5}]]]
eqxyz1A=eqxyz1/((Subscript[κ, 0]^2) (Subscript[σ, 0]^5) (Subscript[τ, 0]) h^5);

Print["We compute x1,y1,z1 from equations at h^5:"]
res=Sort[Solve[eqxyz1A=={0,0,0},{x1,y1,z1}]];
resx1=x1/.res;
resy1=y1/.res;
resz1=z1/.res;

Print["Solutions x1 for ξ>0: "]
Plot[resx1,{ξ,0,3},PlotStyle->{RGBColor[0,0,1]}]

Print["Jacobian of the system for {x1,y1,z1}: "]
spr={x1,y1,z1};
jac=Simplify[Det[Table[Table[D[eqxyz1A[[i]],spr[[j]]],{j,1,Length[spr]}],{i,1,Length[eqxyz1A]}]]];

res1=Quiet[Sort[Solve[Join[eqxyz1A,{jac}]=={0,0,0,0},{x1,y1,z1,ξ}]]];
First[res1]
res2=Rest[res1];
ksiJ=Select[{ξ,x1,y1,z1}/.res2,(Element[#,Reals]&&(#[[2]]>0))&];
Print["Values of ξ for which the Jacobian at the solution is zero (we have a double solution for {x1,y1,z1}): "]
First[#]&/@N[ksiJ,20]

(* ---------------------- *)

Print["Equations at h^6:"]
eqxyz2=Simplify[1/6!D[Normal[Series[{e1B,e2B,e3B}/.razNez/.{x0->0,y0->0,z0->0},{h,0,6}]],{h,6}]/.{h->0}];
(*Print["Equations at h^7:"]
eqxyz3=Simplify[1/7!D[Normal[Series[{e1B,e2B,e3B}/.razNez/.{x0->0,y0->0,z0->0},{h,0,7}]],{h,7}]/.{h->0}];*)

Print["We compute {x2,y2,z2} from equations at h^6: "]
resxyz2=Solve[eqxyz2=={0,0,0},{x2,y2,z2}];
Print["Number of solutions: "]
Length[resxyz2]
resxyz2=Flatten[resxyz2]

Print["If we choose ξ for which we have a double solution for {x1,y1,z1}, the denominator of the solution {x2,y2,z2} is zero:  "]
kat=1;
Quiet[resxyz2/.N[{ξ->ksiJ[[kat,1]],x1->ksiJ[[kat,2]],y1->ksiJ[[kat,3]],z1->ksiJ[[kat,4]]},100]]
kat=2;
Quiet[resxyz2/.N[{ξ->ksiJ[[kat,1]],x1->ksiJ[[kat,2]],y1->ksiJ[[kat,3]],z1->ksiJ[[kat,4]]},100]]
kat=3;
Quiet[resxyz2/.N[{ξ->ksiJ[[kat,1]],x1->ksiJ[[kat,2]],y1->ksiJ[[kat,3]],z1->ksiJ[[kat,4]]},100]]

Print["We now show that this happens iff ξ is such that {x1,y1,z1} is a double solution: "]
dene6=Denominator[Together[x2/.resxyz2]]/((Subscript[κ, 0]) (Subscript[σ, 0]) (Subscript[τ, 0]));
res1=Quiet[Sort[Solve[Join[eqxyz1A,{dene6}]=={0,0,0,0},{x1,y1,z1,ξ}]]];
First[res1]
res2=Rest[res1];
ksi1=Select[{ξ,x1,y1,z1}/.res2,(Element[#,Reals]&&(#[[2]]>0))&];
Print["Values of ξ for which x2,y2,z2 are not well defined: "]
First[#]&/@N[ksi1,10]

(* --- Approximation error --- *)
Print["PH interpolant: "]
pol7A3=Normal[Series[pol7/.razNez/.{x0->0,y0->0,z0->0},{h,0,do}]];
Print["Reparameterization function: "]
repA=Normal[Series[rep/.razNez/.{x0->0,y0->0,z0->0},{h,0,do}]];
Print["Reparameterized curve f:"]
curveRR=Normal[Series[curveR/.{s->repA},{h,0,5}]];
residual=Simplify[Series[pol7A3-curveRR,{h,0,2}]];

Print["Expansion of the error up to order h^1"]
residualKSI1=Series[residual,{h,0,1}]
Print["||E_err||^2: "]
residualKSI2=Norma[Normal[residualKSI1]]^2

Print["Quaternion polynomial: "]
KAPol=Plus@@Table[KAp[[i+1]]bernstein[t,3,i],{i,0,3}];
Print["ER frame: "]
ERFrame=1/Norma[KAPol]^2{Rest[OPStar[KAPol,KAPol]],Rest[OPStar2[KAPol,KAPol]],Rest[OPStar3[KAPol,KAPol]]};
Print["Length of the control polygon: "]
KPLen=Plus@@Table[Norma[KP[[i+1]]-KP[[i]]],{i,1,Length[KP]-1}];
KPLen1=Assuming[(h>0)&&((Subscript[σ, 0])>0),Series[KPLen/.{(Subscript[λ, 0])->(Sqrt[x]),(Subscript[λ, 1])->ξ(Sqrt[x]),(Subscript[μ, 0])->y/(Sqrt[x]),(Subscript[μ, 1])->z/(Sqrt[x])}/.razNez/.{x0->0,y0->0,z0->0},{h,0,1}]];
Print["Function ω: "]
pomWW=D[ERFrame[[2]],t].ERFrame[[3]]/.{(Subscript[λ, 0])->(Sqrt[x]),(Subscript[λ, 1])->ξ(Sqrt[x]),(Subscript[μ, 0])->y/(Sqrt[x]),(Subscript[μ, 1])->z/(Sqrt[x])}/.razNez/.{x0->0,y0->0,z0->0};
funEW=Simplify[Series[pomWW,{h,0,1}]]
funEW1=Normal[funEW]/((Subscript[σ, 0]) (Subscript[τ, 0]) h);

Choice ξ = 1

Print["Nonlinear system for ξ=1: "]
eqxyz1k=eqxyz1/((h^5) (Subscript[κ, 0]^2) (Subscript[σ, 0]^5) (Subscript[τ, 0]))/.{ξ->1}
Print["All the solutions: "]
resxyz1=Sort[Solve[eqxyz1k=={0,0,0},{x1,y1,z1}]];
N[resxyz1,16]

Print["Groebner basis: "]
G=Factor[Simplify[GroebnerBasis[eqxyz1k,{z1,y1,x1}]]]

Print["Solution y1 expressed with the solution x1: "]
resy1z1=Flatten[Simplify[Solve[G[[2]]==0,y1]]]

Print["The three (different) real solutions x1,y1,z1: "]
RES1=resxyz1[[2]]
RES3=resxyz1[[7]];
RES4=resxyz1[[8]];
N[RES3,10]
N[RES4,10]

Print["Quaternion polynomial: "]
KAPol=Plus@@Table[KAp[[i+1]]bernstein[t,3,i],{i,0,3}];
Print["ER frame: "]
ERFrame=1/Norma[KAPol]^2{Rest[OPStar[KAPol,KAPol]],Rest[OPStar2[KAPol,KAPol]],Rest[OPStar3[KAPol,KAPol]]};
Print["Function ω: "]
pomWW=D[ERFrame[[2]],t].ERFrame[[3]]/.{(Subscript[λ, 0])->(Sqrt[x]),(Subscript[λ, 1])->ξ(Sqrt[x]),(Subscript[μ, 0])->y/(Sqrt[x]),(Subscript[μ, 1])->z/(Sqrt[x])}/.razNez/.{x0->0,y0->0,z0->0};
funEW=Simplify[Series[pomWW,{h,0,1}]]
funEW1=Normal[funEW]/((Subscript[σ, 0]) (Subscript[τ, 0]) h);

(* -------- Function ω ------------ *)

Print["Function ω for solution 1 and 2: "]
Simplify[funEW/.{ξ->1}/.RES1]

Print["Function ω for solution 3: "]
Simplify[funEW/.{ξ->1}/.N[RES3,30]]
pom=Simplify[funEW1/.{ξ->1}/.N[RES3,30]];
Plot[pom,{t,0,1},PlotRange->All]

Print["Function ω for solution 4: "]
Simplify[funEW/.{ξ->1}/.N[RES4,30]]
pom=Simplify[funEW1/.{ξ->1}/.N[RES4,30]];
Plot[pom,{t,0,1},PlotRange->All]
Max[Table[Abs[pom/.{t->i}],{i,0,1,1/500}]]((Subscript[σ, 0]) (Subscript[τ, 0]) h)

(* ---------  Length of the control polygon -------------------------- *)

Print["Length of the control polygon: "]
KPLen=Plus@@Table[Norma[KP[[i+1]]-KP[[i]]],{i,1,Length[KP]-1}];

Print["Length of the control polygon for solution 1 and 2: "]
Assuming[((Subscript[σ, 0])>0)&&(h>0),Simplify[Series[KPLen/.{(Subscript[λ, 0])->(Sqrt[x]),(Subscript[λ, 1])->ξ(Sqrt[x]),(Subscript[μ, 0])->y/(Sqrt[x]),(Subscript[μ, 1])->z/(Sqrt[x])}/.razNez/.{x0->0,y0->0,z0->0}/.{ξ->1}/.RES1,{h,0,1}]]]

Print["Length of the control polygon for solution 3: "]
Assuming[((Subscript[σ, 0])>0)&&(h>0),Simplify[Series[KPLen/.{(Subscript[λ, 0])->(Sqrt[x]),(Subscript[λ, 1])->ξ(Sqrt[x]),(Subscript[μ, 0])->y/(Sqrt[x]),(Subscript[μ, 1])->z/(Sqrt[x])}/.razNez/.{x0->0,y0->0,z0->0}/.{ξ->1}/.N[RES3,30],{h,0,1}]]]

Print["Length of the control polygon for solution 4: "]
Assuming[((Subscript[σ, 0])>0)&&(h>0),Simplify[Series[KPLen/.{(Subscript[λ, 0])->(Sqrt[x]),(Subscript[λ, 1])->ξ(Sqrt[x]),(Subscript[μ, 0])->y/(Sqrt[x]),(Subscript[μ, 1])->z/(Sqrt[x])}/.razNez/.{x0->0,y0->0,z0->0}/.{ξ->1}/.N[RES4,30],{h,0,1}]]]

Print["Next, we examine higher order terms and approximation error (for the case when ξ=1) for solutions 1-4. "]

Choice ξ = 1, solution 1-2

Print["We assume ξ=1, x0=y0=z0=0, x1=y1=z1=1. Taylor expansion of equations e1=0, e2=0, e3=0 with this assumption up to h^6:  "]

enac=Simplify [Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1},{h,0,6}]]

Print["We see that y2=0, z2=0. Taylor expansion of equations e1=0, e2=0, e3=0 with this additional assumption up to h^7:  "]

enac=Simplify [Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0}/.RES1/.{z2->0,y2->0},{h,0,7}]]

Print["Expressions (Subscript[e, 1, 7]), (Subscript[e, 2, 7]), (Subscript[e, 3, 7]):  "]
tmp1=Normal[enac]/h^7
Print["From (Subscript[e, 2, 7])=0, (Subscript[e, 3, 7])=0 we express y3 and z3 with x2: "]
resy3z3=Flatten[Simplify[Solve[{tmp1[[2]],tmp1[[3]]}=={0,0},{y3,z3}]]]
Print["If we insert y3, z3 into (Subscript[e, 1, 7]), we obtain a quadratic equation for x2:"]
tmp2=Simplify[tmp1/.resy3z3]
Print["Two solutions for x2: "]
resx2=Simplify[Solve[tmp2[[1]]==0,x2]]
resPom={Join[resx2[[2]],Simplify[resy3z3/.resx2[[2]]]],Join[resx2[[1]],Simplify[resy3z3/.resx2[[1]]]]};
Print["First solution for x2, y3, z3: "]
resx2y3z3a=resPom[[1]]
Print["Second solution for x2, y3, z3: "]
resx2y3z3b=resPom[[2]]
Print["Let us define κκ=-((Subscript[κ, 2])/(Subscript[κ, 0]))-\!\(\*FractionBox[\(3\\ \*SubscriptBox[\(κ\), \(1\)]\\ \*SubscriptBox[\(σ\), \(1\)]\), \(\*SubscriptBox[\(κ\), \(0\)]\\ \*SubscriptBox[\(σ\), \(0\)]\)]\)+\!\(\*FractionBox[\(3\\ \*SubscriptBox[\(σ\), \(1\)]\\ \*SubscriptBox[\(τ\), \(1\)]\), \(\*SubscriptBox[\(σ\), \(0\)]\\ \*SubscriptBox[\(τ\), \(0\)]\)]\)+((Subscript[τ, 2])/(Subscript[τ, 0]))."]
constK=Solve[-((Subscript[κ, 2])/(Subscript[κ, 0]))-((3 (Subscript[κ, 1]) (Subscript[σ, 1]))/((Subscript[κ, 0]) (Subscript[σ, 0])))+((3 (Subscript[σ, 1]) (Subscript[τ, 1]))/((Subscript[σ, 0]) (Subscript[τ, 0])))+((Subscript[τ, 2])/(Subscript[τ, 0]))==κκ,(Subscript[κ, 2])][[1]];
Print["First solution for x2, y3, z3 expressed with κκ: "]
Assuming[(κκ>0)&&((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),FullSimplify[resPom[[1]]/.constK]]
Print["Second solution for x2, y3, z3 expressed with κκ: "]
Assuming[(κκ>0)&&((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),FullSimplify[resPom[[2]]/.constK]]

Print["---------- ANALYSIS OF THE FIRST SOLUTION ------------- "]

Print["We choose the first solution and compute Taylor expansion of equations e1=0, e2=0, e3=0 up to h^8:  "]

tmp=Simplify [Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1}/.{z2->0,y2->0}/.resx2y3z3a,{h,0,8}]]

Print["Expressions (Subscript[e, 1, 8]), (Subscript[e, 2, 8]), (Subscript[e, 3, 8]):  "]
tmp1=Normal[tmp]/h^8

Print["Equations (Subscript[e, 1, 8])=0, (Subscript[e, 2, 8])=0, (Subscript[e, 3, 8])=0 represent a system of linear equations for unknowns x3, y4, z4. The matrix of this system is equal to:  "]
MM=Assuming[(κκ>0)&&((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),FullSimplify[{D[tmp1,x3],D[tmp1,y4],D[tmp1,z4]}/.constK]];
MM//MatrixForm
Print["Determinant of this matrix: "]
Simplify[Det[MM]]

Print["Solution for x3, y4, z4: "]
resx3y4z4a=Flatten[Simplify[Solve[tmp1==0,{x3,y4,z4}]]]

Print["We further compute Taylor expansion of equations e1=0, e2=0, e3=0 up to h^9:  "]

tmp=Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1}/.{z2->0,y2->0}/.resx2y3z3a/.resx3y4z4a,{h,0,9}]

Print["Expressions (Subscript[e, 1, 9]), (Subscript[e, 2, 9]), (Subscript[e, 3, 9]):  "]
tmp1=Normal[tmp]/h^9;

Print["Equations (Subscript[e, 1, 9])=0, (Subscript[e, 2, 9])=0, (Subscript[e, 3, 9])=0 represent a system of linear equations for unknowns x4, y5, z5. The matrix of this system is equal to:  "]
MM=Assuming[(κκ>0)&&((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),FullSimplify[{D[tmp1,x4],D[tmp1,y5],D[tmp1,z5]}/.constK]];
MM//MatrixForm
Print["Determinant of this matrix: "]
Simplify[Det[MM]]

Print["Solution for x4, y5, z5: "]
resx4y5z5a=Flatten[Solve[tmp1==0,{x4,y5,z5}]]

Print["PH interpolant: "]
pol7A=Normal[Series[pol7/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1}/.{z2->0,y2->0}/.resx2y3z3a/.resx3y4z4a,{h,0,4}]];

Print["Reparameterization function: "]
repA=Normal[Series[rep/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1}/.{z2->0,y2->0}/.resx2y3z3a/.resx3y4z4a,{h,0,5}]];
Print["Reparameterized curve f:"]
curveRR=Normal[Series[curveR/.{s->repA}/.{ξ->1},{h,0,4}]];

Print["Residual: "]
residual=Simplify[Series[pol7A-curveRR,{h,0,4}]]

residual1=Assuming[(κκ>0)&&((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),FullSimplify[Normal[residual]/.constK]]

Print["Error \!\(\*SubscriptBox[\(E\), \(\(err\)\(\\ \)\)]\)(p,r) = "]
normRes=Assuming[(κκ>0)&&(h>0),Simplify[(Sqrt[residual1.residual1])]]

Print["---------- ANALYSIS OF THE SECOND SOLUTION ------------- "]

Print["We choose the second solution and compute Taylor expansion of equations e1=0, e2=0, e3=0 up to h^8:  "]

tmp=Simplify [Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1}/.{z2->0,y2->0}/.resx2y3z3b,{h,0,8}]]

Print["Expressions (Subscript[e, 1, 8]), (Subscript[e, 2, 8]), (Subscript[e, 3, 8]):  "]
tmp1=Normal[tmp]/h^8

Print["Equations (Subscript[e, 1, 8])=0, (Subscript[e, 2, 8])=0, (Subscript[e, 3, 8])=0 represent a system of linear equations for unknowns x3, y4, z4. The matrix of this system is equal to:  "]
MM=Assuming[(κκ>0)&&((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),FullSimplify[{D[tmp1,x3],D[tmp1,y4],D[tmp1,z4]}/.constK]];
MM//MatrixForm
Print["Determinant of this matrix: "]
Simplify[Det[MM]]

Print["Solution for x3, y4, z4: "]
resx3y4z4b=Flatten[Simplify[Solve[tmp1==0,{x3,y4,z4}]]]

Print["We further compute Taylor expansion of equations e1=0, e2=0, e3=0 up to h^9:  "]

tmp=Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1}/.{z2->0,y2->0}/.resx2y3z3b/.resx3y4z4b,{h,0,9}]

Print["Expressions (Subscript[e, 1, 9]), (Subscript[e, 2, 9]), (Subscript[e, 3, 9]):  "]
tmp1=Normal[tmp]/h^9;

Print["Equations (Subscript[e, 1, 9])=0, (Subscript[e, 2, 9])=0, (Subscript[e, 3, 9])=0 represent a system of linear equations for unknowns x4, y5, z5. The matrix of this system is equal to:  "]
MM=Assuming[(κκ>0)&&((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),FullSimplify[{D[tmp1,x4],D[tmp1,y5],D[tmp1,z5]}/.constK]];
MM//MatrixForm
Print["Determinant of this matrix: "]
Simplify[Det[MM]]

Print["Solution for x4, y5, z5: "]
resx4y5z5b=Flatten[Solve[tmp1==0,{x4,y5,z5}]]

Print["PH interpolant: "]
pol7A=Normal[Series[pol7/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1}/.{z2->0,y2->0}/.resx2y3z3b/.resx3y4z4b,{h,0,4}]];

Print["Reparameterization function: "]
repA=Normal[Series[rep/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1}/.{z2->0,y2->0}/.resx2y3z3b/.resx3y4z4b,{h,0,5}]];
Print["Reparameterized curve f:"]
curveRR=Normal[Series[curveR/.{s->repA}/.{ξ->1},{h,0,4}]];

Print["Residual: "]
residual=Simplify[Series[pol7A-curveRR,{h,0,4}]]

residual1=Assuming[(κκ>0)&&((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),FullSimplify[Normal[residual]/.constK]]

Print["Error \!\(\*SubscriptBox[\(E\), \(\(err\)\(\\ \)\)]\)(p,r) = "]
normRes=Assuming[(κκ>0)&&(h>0),Simplify[(Sqrt[residual1.residual1])]]

Expand[(((70 (Subscript[κ, 1]) (Subscript[σ, 0])+179 (Subscript[κ, 0]) (Subscript[σ, 1])))^2)]

Choice ξ = 1, solution 3-4

Print["Expressions for (Subscript[e, 1, 6]), (Subscript[e, 2, 6]), (Subscript[e, 3, 6]) under the assumption that x0=y0=z0=0:"]
enac=Simplify[1/6!D[Normal[Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0},{h,0,6}]],{h,6}]/.{h->0}];

Print["Equations (Subscript[e, 1, 6])=0, (Subscript[e, 2, 6])=0, (Subscript[e, 3, 6])=0 represent a system of linear equations for unknowns x2, y2, z2. The matrix of this system for the third solution is equal to:  "]
MM=Simplify[{D[enac,x2],D[enac,y2],D[enac,z2]}]/.N[RES3,20];
MM//MatrixForm
Print["Determinant of this matrix: "]
Simplify[Det[MM]]

Print["Equations (Subscript[e, 1, 6])=0, (Subscript[e, 2, 6])=0, (Subscript[e, 3, 6])=0 represent a system of linear equations for unknowns x2, y2, z2. The matrix of this system for the fourth solution is equal to:  "]
MM=Simplify[{D[enac,x2],D[enac,y2],D[enac,z2]}]/.N[RES4,20];
MM//MatrixForm
Print["Determinant of this matrix: "]
Simplify[Det[MM]]

Print["Solution for x2, y2, z2 (expressed with x1, y1, z1): "]
res2=Flatten[Solve[enac=={0,0,0},{x2,y2,z2}]];

Print["Third solution: "]
RES3A=Join[{x0->0,y0->0,z0->0},RES3,res2/.RES3];
N[Chop[Quiet[Expand[Chop[N[RES3A,100]]]],10^(-90)],10]

Print["Fourth solution: "]
RES4A=Join[{x0->0,y0->0,z0->0},RES4,res2/.RES4];
N[Chop[Quiet[Expand[Chop[N[RES4A,100]]]],10^(-90)],10]

Print["Expressions for (Subscript[e, 1, 7]), (Subscript[e, 2, 7]), (Subscript[e, 3, 7]) under the assumption that x0=y0=z0=0:"]
enac7=1/7!D[Normal[Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0},{h,0,7}]],{h,7}]/.{h->0};

Print["Equations (Subscript[e, 1, 7])=0, (Subscript[e, 2, 7])=0, (Subscript[e, 3, 7])=0 represent a system of linear equations for unknowns x3, y3, z3. The matrix of this system for the third solution is equal to:  "]
MM=Simplify[{D[enac7,x3],D[enac7,y3],D[enac7,z3]}]/.N[RES3,20];
MM//MatrixForm
Print["Determinant of this matrix: "]
Simplify[Det[MM]]

Print["Equations (Subscript[e, 1, 7])=0, (Subscript[e, 2, 7])=0, (Subscript[e, 3, 7])=0 represent a system of linear equations for unknowns x3, y3, z3. The matrix of this system for the fourth solution is equal to:  "]
MM=Simplify[{D[enac7,x3],D[enac7,y3],D[enac7,z3]}]/.N[RES4,20];
MM//MatrixForm
Print["Determinant of this matrix: "]
Simplify[Det[MM]]

(* --- Approximation error --- *)

Print["PH interpolant: "]
pol7A3=Normal[Series[pol7/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0},{h,0,do}]];

Print["Reparameterization function: "]
repA=Normal[Series[rep/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0},{h,0,do}]];
Print["Reparameterized curve f:"]
curveRR=Normal[Series[curveR/.{s->repA}/.{ξ->1},{h,0,4}]];

Print["Residual: "]
residual=Normal[Simplify[Series[pol7A3-curveRR,{h,0,2}]]];

Print["Residual at h^1: "]
Chop[Simplify[D[residual,h]/.{h->0}/.N[RES3,100]],10^(-90)]

Print["Residual at h^2 is nonzero: "]
residualA=Simplify[1/2D[residual,{h,2}]/.{h->0}];
Print["||p(t)-f∘φ(t)||^2 at h^4: "]
residualB=Simplify[residualA.residualA];
residualC=residualB/.Simplify[res2/.N[RES3,50]]/.N[RES3,50];

pol1=PolynomialRemainder[residualC,t^6(1-t)^6,t];
pol2=PolynomialQuotient[residualC,t^6(1-t)^6,t];

Quiet[Chop[pol1/.N[RES3A,50]]]
Quiet[Chop[pol1/.N[RES4A,50]]]

Print["||p(t)-f∘φ(t)|| for the third solution. Coefficient at h^2:  "]
(Sqrt[Quiet[Simplify[t^6(1-t)^6Chop[pol2/.N[RES3A,50]]]]])

Print["||p(t)-f∘φ(t)|| for the fourth solution. Coefficient at h^2:  "]
(Sqrt[Quiet[Simplify[t^6(1-t)^6Chop[pol2/.N[RES4A,50]]]]])

Choice ξ \not= 1

Print["At h^1 we have"]
FullSimplify [Series[{e1B,e2B,e3B}/.razNez,{h,0,1}]]
Print["We see that x0 has to be zero. Then the equations up to h^3 are "]
pom=Simplify [Series[{e1B,e2B,e3B}/.razNez/.{x0->0},{h,0,3}]]
Print["which implies y0=z0=0. "]
Print["For x0=y0=z0 we get "]
eqxyz1=Normal[Simplify [Series[{e1B,e2B,e3B}/.razNez/.{x0->0,y0->0,z0->0},{h,0,5}]]]

eqxyz1A=eqxyz1/( (Subscript[κ, 0]^2) (Subscript[σ, 0]^5) (Subscript[τ, 0])(h^5))

Print["We compute x1,y1,z1 from equations at h^5:"]
res=Sort[Solve[eqxyz1A=={0,0,0},{x1,y1,z1}]];
resx1=x1/.res;
resy1=y1/.res;
resz1=z1/.res;

Plot[resx1,{ξ,0,4},PlotStyle->{RGBColor[0,0,1]}]

(* ------------------------- *)

Print["Nonlinear system for chosen ξ = "]
izbKsi=2
eqxyz1k=eqxyz1/((h^5) (Subscript[κ, 0]^2) (Subscript[σ, 0]^5) (Subscript[τ, 0]))/.{ξ->izbKsi};
Print["Solution: "]
resxyz1=Solve[eqxyz1k=={0,0,0},{x1,y1,z1}];
pom=Sort[Select[{x1,y1,z1}/.resxyz1,(Element[#,Reals]&&(#[[1]]>0))&]];
resxyz1=Table[{x1->pom[[i,1]],y1->pom[[i,2]],z1->pom[[i,3]]},{i,1,Length[pom]}];
N[resxyz1,16]

Print["Expansions: "]
For[i=1,i≤Length[resxyz1],i++,
RES1=N[resxyz1[[i]],100];
Print[{x1 h+x2 h^2,y1 h +y2 h^2,z1 h+z2 h^2}/.N[RES1,8]/.N[Simplify[resxyz2/.RES1/.{ξ->izbKsi}],8]//MatrixForm]]

Print["||p-f∘φ(Subscript[||, ∞]) for all solutions: "]
residual3=Simplify[residualKSI2/.{ξ->izbKsi}/.N[resxyz1,100]]/((Subscript[σ, 0]^2)h^2);
Sqrt[Table[Max[Table[Abs[residual3[[kat]]/.{t->i}],{i,0,1,1/1000}]],{kat,1,Length[residual3]}]](Subscript[σ, 0])h

Print["Function (Subscript[E, ω]): "]
Table[Plot[Simplify[funEW1/.{ξ->izbKsi}/.N[resxyz1[[kat]],100]],{t,0,1}],{kat,1,Length[resxyz1]}]
N[Table[Max[Table[Abs[Simplify[funEW1/.{ξ->izbKsi}/.N[resxyz1[[kat]],100]]]/.{t->i},{i,0,1,1/100}]],{kat,1,Length[resxyz1]}]((Subscript[σ, 0]) (Subscript[τ, 0]) h)]

Print["Length of the control polygon for all solutions: "]
Table[Series[Normal[Assuming[(Subscript[σ, 0])>0,Simplify[KPLen1/.{ξ->izbKsi}/.N[resxyz1[[kat]],100]]]],{h,0,1}],{kat,1,Length[resxyz1]}]

For data sampled from general adapted frame of the given curve

Print["First we compute the Taylor expansion of the curve with prescribed arc-length, curvature and torsion. "]
ClearAll[c,tt,nn,bb,κ,τ,σ]
do=10;
tt=Plus@@Table[(Subscript[c, 1,i])t^i,{i,0,do}];
nn=Plus@@Table[(Subscript[c, 2,i])t^i,{i,0,do}];
bb=Plus@@Table[(Subscript[c, 3,i])t^i,{i,0,do}];
curv=Plus@@Table[(Subscript[κ, i])/i!t^i,{i,0,do}];
tor=Plus@@Table[(Subscript[τ, i])/i!t^i,{i,0,do}];
sig=Plus@@Table[(Subscript[σ, i])/i!t^i,{i,0,do}];
Mat={{0,curv,0},{-curv,0,tor},{0,-tor,0}};
pomD=CoefficientList[sig (Mat.{tt,nn,bb}),t];
pomL=CoefficientList[D[{tt,nn,bb},t],t];
(* --- first component ---  *)
ddo=8;
pog1={(tt/.{t->0})->1,(nn/.{t->0})->0,(bb/.{t->0})->0};
eq=Flatten[Table[Table[pomD[[i,j]]-pomL[[i,j]],{i,1,3}],{j,1,ddo}]/.pog1];
nez=Flatten[Table[(Subscript[c, i,j]),{i,1,3},{j,1,ddo}]];
res1=Flatten[Solve[(#==0)&/@eq,nez]];
(* --- second component ---  *)
pog2={(tt/.{t->0})->0,(nn/.{t->0})->1,(bb/.{t->0})->0};
eq=Flatten[Table[Table[pomD[[i,j]]-pomL[[i,j]],{i,1,3}],{j,1,ddo}]/.pog2];
nez=Flatten[Table[(Subscript[c, i,j]),{i,1,3},{j,1,ddo}]];
res2=Flatten[Solve[(#==0)&/@eq,nez]];
(* --- third component ---  *)
pog3={(tt/.{t->0})->0,(nn/.{t->0})->0,(bb/.{t->0})->1};
eq=Flatten[Table[Table[pomD[[i,j]]-pomL[[i,j]],{i,1,3}],{j,1,ddo}]/.pog3];
nez=Flatten[Table[(Subscript[c, i,j]),{i,1,3},{j,1,ddo}]];
res3=Flatten[Solve[(#==0)&/@eq,nez]];
(* --- Expansion of Frenet frame --- *)
ttR={tt/.res1/.pog1,tt/.res2/.pog2,tt/.res3/.pog3};
nnR={nn/.res1/.pog1,nn/.res2/.pog2,nn/.res3/.pog3};
bbR={bb/.res1/.pog1,bb/.res2/.pog2,bb/.res3/.pog3};

Print["Given curve:"]
do=7;
tan=Normal[Series[sig ttR,{t,0,ddo}]];
curveR=Normal[Series[Integrate[tan,{t,0,s}],{s,0,do+1}]]

(* Frenet Frame *)
FFrame=Frene[curveR,s];
Print["Frenet frame at s=0: "]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[FFrame/.{s->0}]]
Print["Expansion of curvature κ(s): "]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[Norma[Cross[D[curveR,s],D[curveR,{s,2}]]]/Norma[D[curveR,s]]^3,{s,0,5}]]]
Print["Expansion of torsion τ(s): "]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[Det[{D[curveR,s],D[curveR,{s,2}],D[curveR,{s,3}]}]/Norma[Cross[D[curveR,s],D[curveR,{s,2}]]]^2,{s,0,4}]]]
Print["Expansion of arc-length function: "]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[Norma[D[curveR,s]],{s,0,5}]]]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[FFrame[[1]]-(ttR/.{t->s}),{s,0,6}]]]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[FFrame[[2]]-(nnR/.{t->s}),{s,0,6}]]]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[FFrame[[3]]-(bbR/.{t->s}),{s,0,6}]]]

Print["Expansion of function θ(s):"]
ClearAll[θ]
theta=Plus@@Table[(Subscript[θ, i])/i!s^i,{i,0,10}]/.{(Subscript[θ, 0])->0}

cosTh=Normal[Series[Cos[theta],{s,0,do}]];
sinTh=Normal[Series[Sin[theta],{s,0,do}]];

Print["Adapted frame:"]
AFrame=Assuming[(s>0)&&((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Normal[Series[{FFrame[[1]],Cos[theta] FFrame[[2]]+Sin[theta] FFrame[[3]],-Sin[theta] FFrame[[2]]+Cos[theta] FFrame[[3]]},{s,0,do}]/.{(Subscript[θ, 0])->0}]];

Print["Function θ(s) for rotation minimizing frame:"]
thetaR=Integrate[Expand[-tor sig],{t,0,s}];
thetaR=Normal[Series[thetaR,{s,0,10}]]
Print["Coefficients (Subscript[θ, i]) for rotation minimizing frame: "]
izbRM=Simplify[Flatten[Solve[(#==0)&/@CoefficientList[theta-thetaR,s],Table[(Subscript[θ, i]),{i,1,10}]]]]

Print["We compute a quaternion polynomial U1(s) from the adapted frame (using the inverse kinematic mapping): "]
MR=Transpose[AFrame];
curveQ1={1+MR[[1,1]]+MR[[2,2]]+MR[[3,3]],MR[[3,2]]-MR[[2,3]],MR[[1,3]]-MR[[3,1]],MR[[2,1]]-MR[[1,2]]};
curveQ=Assuming[(s>0)&&((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Normal[Series[Sqrt[Norma[D[curveR,s]]] (curveQ1/Norma[curveQ1]),{s,0,do}]]];

Assuming[(s>0)&&((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[curveQ,{s,0,3}]]]

Print["We compute the interpolation data: "]
ClearAll[h]
P0=curveR/.{s->0};
P1=curveR/.{s->h};
U0=curveQ/.{s->0};
U1=curveQ/.{s->h};
V0=D[curveQ,s]/.{s->0};
V1=D[curveQ,s]/.{s->h};
Print["P0 = ", P0]
Print["U0 = ", U0]
Print["V0 = ", V0]
Print["P1 = ",Simplify[ Series[P1,{h,0,3}]]]
Print["U1 = ", Simplify[Series[U1,{h,0,3}]]]
Print["V1 = ",Simplify[Series[V1,{h,0,3}]]]

Print["Check:"]
Rest[OPStar[U0,U0]]-D[curveR,s]/.{s->0}
Rest[2OPStar[U0,V0]]-D[curveR,{s,2}]/.{s->0}
Series[Rest[OPStar[U1,U1]]-D[curveR,s]/.{s->h},{h,0,6}]
Series[2Rest[OPStar[U1,V1]]-D[curveR,{s,2}]/.{s->h},{h,0,6}]

Print["Bezier coefficients of a quaternion polynomial: "]
KAp=SolForG2PHInt[U0,U1,V0,V1,x,y,z,ξ]
Print["PH interpolant of degree 7, its control points and its arc-length function: "]
{pol7,KP,loc}=PHCurveOfDegree7[KAp,P0,t];
pol7
Print["Reparameterization function: "]
ClearAll[λ,μ]
rep=Simplify[InterpolatingPolynomial[{{0,{0,(Subscript[λ, 0])^2,6(Subscript[λ, 0])((Subscript[μ, 0])-(Subscript[λ, 0]))}},{1,{h,(Subscript[λ, 1])^2,6(Subscript[λ, 1])(-(Subscript[μ, 1])+(Subscript[λ, 1]))}}}/.{(Subscript[λ, 0])->(Sqrt[x]),(Subscript[λ, 1])->ξ(Sqrt[x]),(Subscript[μ, 0])->y/(Sqrt[x]),(Subscript[μ, 1])->z/(Sqrt[x])},t]]

Print["Compute nonlinear equations. "]
ClearAll[x,y,z]
q00=Rest[OPStar[U0,U0]];
q11=Rest[OPStar[U1,U1]];
q01=Rest[OPStar[U0,U1]];
qu00=Rest[OPStar[U0,V0]];
qu11=Rest[OPStar[U1,V1]];
qu10=Rest[OPStar[U1,V0]];
qu01=Rest[OPStar[U0,V1]];
u00=Rest[OPStar[V0,V0]];
u11=Rest[OPStar[V1,V1]];
u01=Rest[OPStar[V0,V1]];
tabKoef={q00,q11,q01,qu00,qu11,qu10,qu01,u00,u11,u01,P1-P0};
Print["(Subscript[γ, i]), i=1,...,11: "]
tabGam={(1/5) (5 (x^2)+5 x y+3 (y^2)),(1/5) (3 (z^2)+5 x z ξ+5 (x^2) (ξ^2)),(1/10) (4 x z+9 y z+(x^2) ξ+4 x y ξ),(1/15) (x^2) (5 x+6 y),-(1/15) (x^2) (ξ^3) (6 z+5 x ξ),(1/30) (x^2) (9 z+4 x ξ),-(1/30) (x^2) (4 x+9 y) (ξ^3),((x^4)/15),(((x^4) (ξ^6))/15),-(1/10) (x^4) (ξ^3),-7 x};
tabGam//MatrixForm

Print["Vectors (Subscript[U, 0]^(2* )), (Subscript[U, 1]^(2* )), (Subscript[U, 0])*(Subscript[U, 1]), (Subscript[U, 0])*(Subscript[V, 0]), (Subscript[U, 1])*(Subscript[V, 1]), (Subscript[U, 1])*(Subscript[V, 0]), (Subscript[U, 0])*(Subscript[V, 1]), (Subscript[V, 0]^(2* )), (Subscript[V, 1]^(2* )), (Subscript[V, 0])*(Subscript[V, 1]), (Subscript[P, 1])-(Subscript[P, 0]): "]
(*Series[tabKoef,{h,0,2}]*)
eq=Plus@@Table[tabGam[[i]]tabKoef[[i]],{i,1,11}];

Print["Compute coefficients ζ: "]
ClearAll[q,ζ]
vec1={0,(Subscript[q, 0]) (Subscript[q, 2])-(Subscript[q, 1]) (Subscript[q, 3]),(Subscript[q, 1]) (Subscript[q, 2])+(Subscript[q, 0]) (Subscript[q, 3])}/.{(Subscript[q, 0])->U1[[1]],(Subscript[q, 1])->U1[[2]],(Subscript[q, 2])->U1[[3]],(Subscript[q, 3])->U1[[4]]};
vec2={0,(Subscript[q, 2]),(Subscript[q, 3])}/.{(Subscript[q, 0])->U1[[1]],(Subscript[q, 1])->U1[[2]],(Subscript[q, 2])->U1[[3]],(Subscript[q, 3])->U1[[4]]};
vec3={2 (Subscript[q, 1]) ((Subscript[q, 2]^2)+(Subscript[q, 3]^2)),(Subscript[q, 0]^2) (Subscript[q, 2])-2 (Subscript[q, 0]) (Subscript[q, 1]) (Subscript[q, 3])+(Subscript[q, 2]) (-(Subscript[q, 1]^2)+(Subscript[q, 2]^2)+(Subscript[q, 3]^2)),2 (Subscript[q, 0]) (Subscript[q, 1]) (Subscript[q, 2])+(Subscript[q, 0]^2) (Subscript[q, 3])+(Subscript[q, 3]) (-(Subscript[q, 1]^2)+(Subscript[q, 2]^2)+(Subscript[q, 3]^2))}/.{(Subscript[q, 0])->U1[[1]],(Subscript[q, 1])->U1[[2]],(Subscript[q, 2])->U1[[3]],(Subscript[q, 3])->U1[[4]]};
(Subscript[ζ, 1])=-q01.vec1;
For[j=4,j≤11,j++,
(Subscript[ζ, j-2,1])=tabKoef[[j]].vec1;
(Subscript[ζ, j-2,2])=tabKoef[[j]].vec2;
(Subscript[ζ, j-2,3])=tabKoef[[j]].vec3;
];

tabZetas={{(Subscript[ζ, 1])},Table[(Subscript[ζ, j-2,1]),{j,4,11}],Table[(Subscript[ζ, j-2,2]),{j,4,11}],Table[(Subscript[ζ, j-2,3]),{j,4,11}]};
tabZetas=Normal[Series[tabZetas,{h,0,7}]];

Print["(Subscript[ζ, 1]) = ",Simplify[Series[(Subscript[ζ, 1]),{h,0,4}]]]
Print["{(Subscript[ζ, 2, 1]), (Subscript[ζ, 3, 1]), (Subscript[ζ, 4, 1]), (Subscript[ζ, 5, 1]), (Subscript[ζ, 6, 1]), (Subscript[ζ, 7, 1]), (Subscript[ζ, 8, 1]), (Subscript[ζ, 9, 1])} = ",Table[Simplify[Series[(Subscript[ζ, i,1]),{h,0,3}]],{i,2,9}]]
Print["{(Subscript[ζ, 2, 2]), (Subscript[ζ, 3, 2]), (Subscript[ζ, 4, 2]), (Subscript[ζ, 5, 2]), (Subscript[ζ, 6, 2]), (Subscript[ζ, 7, 2]), (Subscript[ζ, 8, 2]), (Subscript[ζ, 9, 2])} = ",Table[Simplify[Series[(Subscript[ζ, i,2]),{h,0,3}]],{i,2,9}]]
Print["{(Subscript[ζ, 2, 3]), (Subscript[ζ, 3, 3]), (Subscript[ζ, 4, 3]), (Subscript[ζ, 5, 3]), (Subscript[ζ, 6, 3]), (Subscript[ζ, 7, 3]), (Subscript[ζ, 8, 3]), (Subscript[ζ, 9, 3])} = ",Table[Simplify[Series[(Subscript[ζ, i,3]),{h,0,3}]],{i,2,9}]]

Print["Equations expressed with zetas. We multiply the second equation by (Sqrt[(Subscript[σ, 0])]) and divide the third equation by (Sqrt[(Subscript[σ, 0])]). "]
e1B=-(Subscript[ζ, 1])tabGam[[3]]+Plus@@Table[(Subscript[ζ, j-2,1])tabGam[[j]],{j,4,11}];
e2B=(2/U0[[1]] (Subscript[ζ, 1])tabGam[[2]]+Plus@@Table[(Subscript[ζ, j-2,2])tabGam[[j]],{j,4,11}])(Sqrt[(Subscript[σ, 0])]);
e3B=(2 U0[[1]] (Subscript[ζ, 1])tabGam[[1]]+Plus@@Table[(Subscript[ζ, j-2,3])tabGam[[j]],{j,4,11}])/(Sqrt[(Subscript[σ, 0])]);
Print["Taylor expansion of unknowns x,y,z: "]
ClearAll[x0,x1,x2,x3,x4,x5,x6,x7,x8,y0,y1,y2,y3,y4,y5,y6,y7,y8,z0,z1,z2,z3,z4,z5,z6,z7,z8]
razNez={x->(x0+x1 h+x2 h^2+x3 h^3+x4 h^4+x5 h^5+x6 h^6+x7 h^7+x8 h^8),y->(y0+y1 h+y2 h^2+y3 h^3+y4 h^4+y5 h^5+y6 h^6+y7 h^7+y8 h^8),z->(z0+z1 h+z2 h^2+z3 h^3+z4 h^4+z5 h^5+z6 h^6+z7 h^7+z8 h^8)}
(*Print["Taylor expansion of equations: "]
FullSimplify [Series[{e1B,e2B,e3B}/.razNez,{h,0,2}]]*)

Print["Expansion of equations e1=0, e2=0, e3=0 up to h^1: "]
tmp=Simplify[Series[{e1B,e2B,e3B}/.razNez,{h,0,1}]]

NSolve[2-3 (ξ^3)+2 (ξ^6)==0,ξ]

Print["If (Subscript[θ, 1])!=-(Subscript[σ, 0]) (Subscript[τ, 0]), the solution is x0=0."]

Print["Expansion of equations e1=0, e2=0, e3=0 up to h^3 assuming x0=0: "]

tmp=Simplify[Series[{e1B,e2B,e3B}/.razNez/.{x0->0},{h,0,3}]]

Print["If (Subscript[θ, 1])!=-(Subscript[σ, 0]) (Subscript[τ, 0]), the solution is x0=0, y0=0, z0=0."]

Print["Expansion of equations e1=0, e2=0, e3=0 up to h^5 assuming x0=y0=z0=0: "]

tmp=Simplify[Series[{e1B,e2B,e3B}/.razNez/.{x0->0,y0->0,z0->0},{h,0,5}]]

ClearAll[Θ]
Print["We introduce Θ=(Subscript[θ, 1])/((Subscript[σ, 0])(Subscript[τ, 0])) and divide the equations by (h^5) (Subscript[κ, 0]^2) (Subscript[τ, 0]) (Subscript[σ, 0]^5): "]
tmp1=Simplify[(Normal[tmp]/.{(Subscript[θ, 1])->Θ (Subscript[σ, 0]) (Subscript[τ, 0])})/((h^5) (Subscript[κ, 0]^2) (Subscript[τ, 0])(Subscript[σ, 0]^5))]

Collect[#,Θ]&/@FullSimplify[CoefficientList[240 tmp1[[1]],x1]]

Collect[#,Θ]&/@FullSimplify[CoefficientList[240 tmp1[[2]],x1]]

Collect[#,Θ]&/@FullSimplify[CoefficientList[240 tmp1[[3]],x1]]

res1=Solve[(tmp1/.{ξ->1})=={0,0,0},{x1,y1,z1}]

Length[res1]

{x1,y1,z1}/.res1[[1]]
{x1,y1,z1}/.res1[[2]]

Print["We see that for ξ=1 x1=y1=z1=1 is a solution for any Θ."]

Print["Expansion of equations e1=0, e2=0, e3=0 up to h^6 assuming x0=y0=z0=0 and x1=y1=z1=1: "]

tmp=Simplify[Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1},{h,0,6}]]

tmp1=Normal[Simplify[tmp]]/h^6

Print["Equations (Subscript[e, 1, 6])=0, (Subscript[e, 2, 6])=0 and (Subscript[e, 3, 6])=0 represent the linear system for unknown x2,y2,z2. The matrix of this system equals:"]

MM=Transpose[Simplify[{D[tmp1,x2],D[tmp1,y2],D[tmp1,z2]}/.{(Subscript[θ, 1])->Θ (Subscript[σ, 0]) (Subscript[τ, 0])}]];
MM//MatrixForm
MM/((7/240)(Subscript[κ, 0]^2) (Subscript[σ, 0]^5) (Subscript[τ, 0]))//MatrixForm
Print["Determinant of this matrix:"]
Simplify[Det[MM]]

Print["If Θ!=0 or Θ!=-1 the unique solution of equations (Subscript[e, 1, 6])=0, (Subscript[e, 2, 6])=0 and (Subscript[e, 3, 6])=0 equals x2=y2=z2=0. "]
Flatten[Solve[tmp1=={0,0,0},{x2,y2,z2}]]

Print["Equations (Subscript[e, 1, 6])=0, (Subscript[e, 2, 6])=0 and (Subscript[e, 3, 6])=0 for Θ=0: "]
Simplify[tmp1/.{(Subscript[θ, 1])->0}]
Print["The only possible solution is y2=z2=0. This case is considered separately. "]

Print["Equations (Subscript[e, 1, 6])=0, (Subscript[e, 2, 6])=0 and (Subscript[e, 3, 6])=0 for Θ=-1: "]
Simplify[tmp1/.{(Subscript[θ, 1])->Θ (Subscript[σ, 0]) (Subscript[τ, 0])}/.{Θ->-1}]
Print["All three equations are the same. This case is also analysed separately."]

Print["We proceed with assuming x0=y0=z0=0, x1=y1=z1=1, x2=y2=z2=0 and Θ!=0 and Θ!=-1. Expansions of equations e1=0, e2=0, e3=0 up to h^7 are: "]

tmp=Simplify[Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1,x2->0,y2->0,z2->0},{h,0,7}]]

tmp1=Simplify[Normal[tmp]]/h^7 ;

Print["Equations (Subscript[e, 1, 7])=0, (Subscript[e, 2, 7])=0 and (Subscript[e, 3, 7])=0 represent the linear system for unknowns x3,y3,z3. The matrix of this system equals:"]

MM=Transpose[Simplify[{D[tmp1,x3],D[tmp1,y3],D[tmp1,z3]}/.{(Subscript[θ, 1])->Θ (Subscript[σ, 0]) (Subscript[τ, 0])}]];
MM//MatrixForm
MM/((7/240)(Subscript[κ, 0]^2) (Subscript[σ, 0]^5) (Subscript[τ, 0]))//MatrixForm
Print["Determinant of this matrix:"]
Simplify[Det[MM]]

Print["If Θ!=0 or Θ!=-1 the unique solution of equations (Subscript[e, 1, 7])=0, (Subscript[e, 2, 7])=0 and (Subscript[e, 3, 7])=0 equals: "]
res3=FullSimplify[Flatten[Solve[(tmp1)=={0,0,0},{x3,y3,z3}]]];
FullSimplify[res3/.{(Subscript[θ, 1])->Θ (Subscript[σ, 0]) (Subscript[τ, 0])}]

Print["We proceed with observing expansions of equations e1=0, e2=0, e3=0 up to h^8: "]

tmp=Simplify[Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1,x2->0,y2->0,z2->0}/.res3,{h,0,8}]]

tmp1=Normal[tmp]/h^8 ;

Print["Equations (Subscript[e, 1, 8])=0, (Subscript[e, 2, 8])=0 and (Subscript[e, 3, 8])=0 represent the linear system for unknowns x4,y4,z4. The matrix of this system equals:"]

MM=Transpose[Simplify[{D[tmp1,x4],D[tmp1,y4],D[tmp1,z4]}/.{(Subscript[θ, 1])->Θ (Subscript[σ, 0]) (Subscript[τ, 0])}]];
MM//MatrixForm
MM/((7/240)(Subscript[κ, 0]^2) (Subscript[σ, 0]^5) (Subscript[τ, 0]))//MatrixForm
Print["Determinant of this matrix:"]
Simplify[Det[MM]]

Print["If Θ!=0 or Θ!=-1 the unique solution of equations (Subscript[e, 1, 8])=0, (Subscript[e, 2, 8])=0 and (Subscript[e, 3, 8])=0 equals: "]
res4=Simplify[Flatten[Solve[(tmp1)=={0,0,0},{x4,y4,z4}]]];
Simplify[res4/.{(Subscript[θ, 1])->Θ (Subscript[σ, 0]) (Subscript[τ, 0])}]

Print["We proceed with observing expansions of equations e1=0, e2=0, e3=0 up to h^9: "]

tmp=Simplify[Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1,x2->0,y2->0,z2->0}/.res3/.res4,{h,0,9}]]

tmp1=Normal[tmp]/h^9;

Print["Equations (Subscript[e, 1, 9])=0, (Subscript[e, 2, 9])=0 and (Subscript[e, 3, 9])=0 represent the linear system for unknowns x5,y5,z5. The matrix of this system equals:"]

MM=Transpose[Simplify[{D[tmp1,x5],D[tmp1,y5],D[tmp1,z5]}/.{(Subscript[θ, 1])->Θ (Subscript[σ, 0]) (Subscript[τ, 0])}]];
MM//MatrixForm
MM/((7/240)(Subscript[κ, 0]^2) (Subscript[σ, 0]^5) (Subscript[τ, 0]))//MatrixForm
Print["Determinant of this matrix:"]
Simplify[Det[MM]]

Print["If Θ!=0 or Θ!=-1 the unique solution of equations (Subscript[e, 1, 9])=0, (Subscript[e, 2, 9])=0 and (Subscript[e, 3, 9])=0 equals: "]
res5=Simplify[Flatten[Solve[(tmp1)=={0,0,0},{x5,y5,z5}]]];
Simplify[res5/.{(Subscript[θ, 1])->Θ (Subscript[σ, 0]) (Subscript[τ, 0])}]

Print["We proceed with observing expansions of equations e1=0, e2=0, e3=0 up to h^10: "]

tmp=Simplify[Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1,x2->0,y2->0,z2->0}/.res3/.res4/.res5,{h,0,10}]]

tmp1=Normal[tmp]/h^(10);

Print["Equations (Subscript[e, 1, 10])=0, (Subscript[e, 2, 10])=0 and (Subscript[e, 3, 10])=0 represent the linear system for unknowns x6,y6,z6. The matrix of this system equals:"]

MM=Transpose[Simplify[{D[tmp1,x6],D[tmp1,y6],D[tmp1,z6]}/.{(Subscript[θ, 1])->Θ (Subscript[σ, 0]) (Subscript[τ, 0])}]];
MM//MatrixForm
MM/((7/240)(Subscript[κ, 0]^2) (Subscript[σ, 0]^5) (Subscript[τ, 0]))//MatrixForm
Print["Determinant of this matrix:"]
Simplify[Det[MM]]

Print["If Θ!=0 or Θ!=-1 the unique solution of equations (Subscript[e, 1, 10])=0, (Subscript[e, 2, 10])=0 and (Subscript[e, 3, 10])=0 equals: "]
res6=Simplify[Flatten[Solve[(tmp1)=={0,0,0},{x6,y6,z6}]]];
Simplify[res6/.{(Subscript[θ, 1])->Θ (Subscript[σ, 0]) (Subscript[τ, 0])}]

Print["PH interpolant: "]
pol7A=Normal[Series[pol7/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1,x2->0,y2->0,z2->0}/.res3/.res4/.res5/.res6,{h,0,6}]];

Print["Reparameterization function: "]
repA=Normal[Series[rep/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1,x2->0,y2->0,z2->0}/.res3/.res4/.res5/.res6,{h,0,6}]];
Print["Reparameterized curve f:"]
curveRR=Normal[Series[curveR/.{s->repA}/.{ξ->1},{h,0,6}]];

Print["Residual: "]
residual=Simplify[Series[pol7A-curveRR,{h,0,6}]]

normRes=Simplify[Normal[residual].Normal[residual]]

(* ---------------- *)

Print["Quaternion polynomial: "]
KAPol=Plus@@Table[KAp[[i+1]]bernstein[t,3,i],{i,0,3}];
Print["ER frame: "]
ERFrame=1/Norma[KAPol]^2{Rest[OPStar[KAPol,KAPol]],Rest[OPStar2[KAPol,KAPol]],Rest[OPStar3[KAPol,KAPol]]};
Print["Length of the control polygon: "]
KPLen=Plus@@Table[Norma[KP[[i+1]]-KP[[i]]],{i,1,Length[KP]-1}];
KPLen1=Assuming[(h>0)&&((Subscript[σ, 0])>0),Series[KPLen/.{(Subscript[λ, 0])->(Sqrt[x]),(Subscript[λ, 1])->ξ(Sqrt[x]),(Subscript[μ, 0])->y/(Sqrt[x]),(Subscript[μ, 1])->z/(Sqrt[x])}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1},{h,0,1}]];
Print["Function ω: "]
EW=D[ERFrame[[2]],t].ERFrame[[3]]/.{(Subscript[λ, 0])->(Sqrt[x]),(Subscript[λ, 1])->ξ(Sqrt[x]),(Subscript[μ, 0])->y/(Sqrt[x]),(Subscript[μ, 1])->z/(Sqrt[x])}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1};

Series[EW,{h,0,1}]

Series[EW/.{(Subscript[θ, 1])->-(Subscript[σ, 0]) (Subscript[τ, 0])}/.{x2->0,y2->0,z2->0,y3->0,z3->0}/.izbRM,{h,0,4}]

Normal[Simplify[(1/12) (-2 t (Subscript[κ, 0]) (Subscript[κ, 1]) (Subscript[σ, 0]^3) (Subscript[τ, 0])+6 (t^2) (Subscript[κ, 0]) (Subscript[κ, 1]) (Subscript[σ, 0]^3) (Subscript[τ, 0])-4 (t^3) (Subscript[κ, 0]) (Subscript[κ, 1]) (Subscript[σ, 0]^3) (Subscript[τ, 0])-4 t (Subscript[κ, 0]^2) (Subscript[σ, 0]^2) (Subscript[σ, 1]) (Subscript[τ, 0])+12 (t^2) (Subscript[κ, 0]^2) (Subscript[σ, 0]^2) (Subscript[σ, 1]) (Subscript[τ, 0])-8 (t^3) (Subscript[κ, 0]^2) (Subscript[σ, 0]^2) (Subscript[σ, 1]) (Subscript[τ, 0])-t (Subscript[κ, 0]^2) (Subscript[σ, 0]^3) (Subscript[τ, 1])+3 (t^2) (Subscript[κ, 0]^2) (Subscript[σ, 0]^3) (Subscript[τ, 1])-2 (t^3) (Subscript[κ, 0]^2) (Subscript[σ, 0]^3) (Subscript[τ, 1])) (h^4)+((O[h])^(9/2))]]

KPLen1

For data sampled from rotation minimizing frame of the given curve

Print["First we compute the Taylor expansion of the curve with prescribed arc-length, curvature and torsion. "]
ClearAll[c,tt,nn,bb,κ,τ,σ]
do=10;
tt=Plus@@Table[(Subscript[c, 1,i])t^i,{i,0,do}];
nn=Plus@@Table[(Subscript[c, 2,i])t^i,{i,0,do}];
bb=Plus@@Table[(Subscript[c, 3,i])t^i,{i,0,do}];
curv=Plus@@Table[(Subscript[κ, i])/i!t^i,{i,0,do}];
tor=Plus@@Table[(Subscript[τ, i])/i!t^i,{i,0,do}];
sig=Plus@@Table[(Subscript[σ, i])/i!t^i,{i,0,do}];
Mat={{0,curv,0},{-curv,0,tor},{0,-tor,0}};
pomD=CoefficientList[sig (Mat.{tt,nn,bb}),t];
pomL=CoefficientList[D[{tt,nn,bb},t],t];
(* --- first component ---  *)
ddo=8;
pog1={(tt/.{t->0})->1,(nn/.{t->0})->0,(bb/.{t->0})->0};
eq=Flatten[Table[Table[pomD[[i,j]]-pomL[[i,j]],{i,1,3}],{j,1,ddo}]/.pog1];
nez=Flatten[Table[(Subscript[c, i,j]),{i,1,3},{j,1,ddo}]];
res1=Flatten[Solve[(#==0)&/@eq,nez]];
(* --- second component ---  *)
pog2={(tt/.{t->0})->0,(nn/.{t->0})->1,(bb/.{t->0})->0};
eq=Flatten[Table[Table[pomD[[i,j]]-pomL[[i,j]],{i,1,3}],{j,1,ddo}]/.pog2];
nez=Flatten[Table[(Subscript[c, i,j]),{i,1,3},{j,1,ddo}]];
res2=Flatten[Solve[(#==0)&/@eq,nez]];
(* --- third component ---  *)
pog3={(tt/.{t->0})->0,(nn/.{t->0})->0,(bb/.{t->0})->1};
eq=Flatten[Table[Table[pomD[[i,j]]-pomL[[i,j]],{i,1,3}],{j,1,ddo}]/.pog3];
nez=Flatten[Table[(Subscript[c, i,j]),{i,1,3},{j,1,ddo}]];
res3=Flatten[Solve[(#==0)&/@eq,nez]];
(* --- Expansion of Frenet frame --- *)
ttR={tt/.res1/.pog1,tt/.res2/.pog2,tt/.res3/.pog3};
nnR={nn/.res1/.pog1,nn/.res2/.pog2,nn/.res3/.pog3};
bbR={bb/.res1/.pog1,bb/.res2/.pog2,bb/.res3/.pog3};

Print["Given curve:"]
do=7;
tan=Normal[Series[sig ttR,{t,0,ddo}]];
curveR=Normal[Series[Integrate[tan,{t,0,s}],{s,0,do+1}]]

(* Frenet Frame *)
FFrame=Frene[curveR,s];
Print["Frenet frame at s=0: "]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[FFrame/.{s->0}]]
Print["Expansion of curvature κ(s): "]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[Norma[Cross[D[curveR,s],D[curveR,{s,2}]]]/Norma[D[curveR,s]]^3,{s,0,5}]]]
Print["Expansion of torsion τ(s): "]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[Det[{D[curveR,s],D[curveR,{s,2}],D[curveR,{s,3}]}]/Norma[Cross[D[curveR,s],D[curveR,{s,2}]]]^2,{s,0,5}]]]
Print["Expansion of arc-length function: "]
Assuming[((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[Norma[D[curveR,s]],{s,0,5}]]]

ClearAll[θ]
theta=Plus@@Table[(Subscript[θ, i])/i!s^i,{i,0,10}]

cosTh=Normal[Series[Cos[theta],{s,0,do}]]/.{(Subscript[θ, 0])->0};
sinTh=Normal[Series[Sin[theta],{s,0,do}]]/.{(Subscript[θ, 0])->0};

Print["Adapted frame:"]
AFrame=Assuming[(s>0)&&((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Normal[Series[{FFrame[[1]],Cos[theta] FFrame[[2]]+Sin[theta] FFrame[[3]],-Sin[theta] FFrame[[2]]+Cos[theta] FFrame[[3]]},{s,0,do}]/.{(Subscript[θ, 0])->0}]];

Print["Rotation minimizing frame:"]
thetaR=Integrate[Expand[-tor sig],{t,0,s}];
thetaR=Normal[Series[thetaR,{s,0,10}]]

izbRM=Simplify[Flatten[Solve[(#==0)&/@CoefficientList[theta-thetaR,s],Table[(Subscript[θ, i]),{i,0,10}]]]]

Print["We compute a quaternion polynomial U1(s) from the Adapted frame (using the inverse kinematic mapping): "]
MR=Transpose[AFrame]/.izbRM;
curveQ1={1+MR[[1,1]]+MR[[2,2]]+MR[[3,3]],MR[[3,2]]-MR[[2,3]],MR[[1,3]]-MR[[3,1]],MR[[2,1]]-MR[[1,2]]};

curveQ=Assuming[(s>0)&&((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Normal[Series[Sqrt[Norma[D[curveR,s]]] (curveQ1/Norma[curveQ1]),{s,0,do}]]];

Assuming[(s>0)&&((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[curveQ,{s,0,2}]]]

Assuming[(s>0)&&((Subscript[κ, 0])>0)&&((Subscript[σ, 0])>0),Simplify[Series[curveQ,{s,0,3}]]];

Print["We compute the interpolation data: "]
ClearAll[h]
P0=curveR/.{s->0};
P1=curveR/.{s->h};
U0=curveQ/.{s->0};
U1=curveQ/.{s->h};
V0=D[curveQ,s]/.{s->0};
V1=D[curveQ,s]/.{s->h};
Print["P0 = ", P0]
Print["U0 = ", U0]
Print["V0 = ", V0]
Print["P1 = ",Simplify[ Series[P1,{h,0,3}]]]
Print["U1 = ", Simplify[Series[U1,{h,0,3}]]]
Print["V1 = ",Simplify[Series[V1,{h,0,3}]]]

Print["Check:"]
Rest[OPStar[U0,U0]]-D[curveR,s]/.{s->0}
Rest[2OPStar[U0,V0]]-D[curveR,{s,2}]/.{s->0}
Series[Rest[OPStar[U1,U1]]-D[curveR,s]/.{s->h},{h,0,6}]
Series[2Rest[OPStar[U1,V1]]-D[curveR,{s,2}]/.{s->h},{h,0,6}]

Print["Bezier coefficients of a quaternion polynomial: "]
KAp=SolForG2PHInt[U0,U1,V0,V1,x,y,z,ξ];
Print["PH interpolant of degree 7, its control points and its arc-length function: "]
{pol7,KP,loc}=PHCurveOfDegree7[KAp,P0,t];
Print["Reparameterization function: "]
ClearAll[λ,μ]
rep=Simplify[InterpolatingPolynomial[{{0,{0,(Subscript[λ, 0])^2,6(Subscript[λ, 0])((Subscript[μ, 0])-(Subscript[λ, 0]))}},{1,{h,(Subscript[λ, 1])^2,6(Subscript[λ, 1])(-(Subscript[μ, 1])+(Subscript[λ, 1]))}}}/.{(Subscript[λ, 0])->(Sqrt[x]),(Subscript[λ, 1])->ξ(Sqrt[x]),(Subscript[μ, 0])->y/(Sqrt[x]),(Subscript[μ, 1])->z/(Sqrt[x])},t]]

Print["Compute nonlinear equations. "]
ClearAll[x,y,z]
q00=Rest[OPStar[U0,U0]];
q11=Rest[OPStar[U1,U1]];
q01=Rest[OPStar[U0,U1]];
qu00=Rest[OPStar[U0,V0]];
qu11=Rest[OPStar[U1,V1]];
qu10=Rest[OPStar[U1,V0]];
qu01=Rest[OPStar[U0,V1]];
u00=Rest[OPStar[V0,V0]];
u11=Rest[OPStar[V1,V1]];
u01=Rest[OPStar[V0,V1]];
tabKoef={q00,q11,q01,qu00,qu11,qu10,qu01,u00,u11,u01,P1-P0};
Print["(Subscript[γ, i]), i=1,...,11: "]
tabGam={(1/5) (5 (x^2)+5 x y+3 (y^2)),(1/5) (3 (z^2)+5 x z ξ+5 (x^2) (ξ^2)),(1/10) (4 x z+9 y z+(x^2) ξ+4 x y ξ),(1/15) (x^2) (5 x+6 y),-(1/15) (x^2) (ξ^3) (6 z+5 x ξ),(1/30) (x^2) (9 z+4 x ξ),-(1/30) (x^2) (4 x+9 y) (ξ^3),((x^4)/15),(((x^4) (ξ^6))/15),-(1/10) (x^4) (ξ^3),-7 x};
tabGam//MatrixForm

Print["Vectors (Subscript[U, 0]^(2* )), (Subscript[U, 1]^(2* )), (Subscript[U, 0])*(Subscript[U, 1]), (Subscript[U, 0])*(Subscript[V, 0]), (Subscript[U, 1])*(Subscript[V, 1]), (Subscript[U, 1])*(Subscript[V, 0]), (Subscript[U, 0])*(Subscript[V, 1]), (Subscript[V, 0]^(2* )), (Subscript[V, 1]^(2* )), (Subscript[V, 0])*(Subscript[V, 1]), (Subscript[P, 1])-(Subscript[P, 0]): "]
eq=Plus@@Table[tabGam[[i]]tabKoef[[i]],{i,1,11}];

Print["Compute coefficients ζ: "]
ClearAll[q,ζ]
vec1={0,(Subscript[q, 0]) (Subscript[q, 2])-(Subscript[q, 1]) (Subscript[q, 3]),(Subscript[q, 1]) (Subscript[q, 2])+(Subscript[q, 0]) (Subscript[q, 3])}/.{(Subscript[q, 0])->U1[[1]],(Subscript[q, 1])->U1[[2]],(Subscript[q, 2])->U1[[3]],(Subscript[q, 3])->U1[[4]]};
vec2={0,(Subscript[q, 2]),(Subscript[q, 3])}/.{(Subscript[q, 0])->U1[[1]],(Subscript[q, 1])->U1[[2]],(Subscript[q, 2])->U1[[3]],(Subscript[q, 3])->U1[[4]]};
vec3={2 (Subscript[q, 1]) ((Subscript[q, 2]^2)+(Subscript[q, 3]^2)),(Subscript[q, 0]^2) (Subscript[q, 2])-2 (Subscript[q, 0]) (Subscript[q, 1]) (Subscript[q, 3])+(Subscript[q, 2]) (-(Subscript[q, 1]^2)+(Subscript[q, 2]^2)+(Subscript[q, 3]^2)),2 (Subscript[q, 0]) (Subscript[q, 1]) (Subscript[q, 2])+(Subscript[q, 0]^2) (Subscript[q, 3])+(Subscript[q, 3]) (-(Subscript[q, 1]^2)+(Subscript[q, 2]^2)+(Subscript[q, 3]^2))}/.{(Subscript[q, 0])->U1[[1]],(Subscript[q, 1])->U1[[2]],(Subscript[q, 2])->U1[[3]],(Subscript[q, 3])->U1[[4]]};
(Subscript[ζ, 1])=-q01.vec1;
For[j=4,j≤11,j++,
(Subscript[ζ, j-2,1])=tabKoef[[j]].vec1;
(Subscript[ζ, j-2,2])=tabKoef[[j]].vec2;
(Subscript[ζ, j-2,3])=tabKoef[[j]].vec3;
];

tabZetas={{(Subscript[ζ, 1])},Table[(Subscript[ζ, j-2,1]),{j,4,11}],Table[(Subscript[ζ, j-2,2]),{j,4,11}],Table[(Subscript[ζ, j-2,3]),{j,4,11}]};
tabZetas=Normal[Series[tabZetas,{h,0,7}]];

Print["(Subscript[ζ, 1]) = ",Simplify[Series[(Subscript[ζ, 1]),{h,0,4}]]]
Print["{(Subscript[ζ, 2, 1]), (Subscript[ζ, 3, 1]), (Subscript[ζ, 4, 1]), (Subscript[ζ, 5, 1]), (Subscript[ζ, 6, 1]), (Subscript[ζ, 7, 1]), (Subscript[ζ, 8, 1]), (Subscript[ζ, 9, 1])} = ",Table[Simplify[Series[(Subscript[ζ, i,1]),{h,0,3}]],{i,2,9}]]
Print["{(Subscript[ζ, 2, 2]), (Subscript[ζ, 3, 2]), (Subscript[ζ, 4, 2]), (Subscript[ζ, 5, 2]), (Subscript[ζ, 6, 2]), (Subscript[ζ, 7, 2]), (Subscript[ζ, 8, 2]), (Subscript[ζ, 9, 2])} = ",Table[Simplify[Series[(Subscript[ζ, i,2]),{h,0,3}]],{i,2,9}]]
Print["{(Subscript[ζ, 2, 3]), (Subscript[ζ, 3, 3]), (Subscript[ζ, 4, 3]), (Subscript[ζ, 5, 3]), (Subscript[ζ, 6, 3]), (Subscript[ζ, 7, 3]), (Subscript[ζ, 8, 3]), (Subscript[ζ, 9, 3])} = ",Table[Simplify[Series[(Subscript[ζ, i,3]),{h,0,3}]],{i,2,9}]]

FullSimplify[Series[tabZetas[[1]],{h,0,4}]]

Print["Equations expressed with zetas. We multiply the second equation by (Sqrt[(Subscript[σ, 0])]) and divide the third equation by (Sqrt[(Subscript[σ, 0])]). "]
e1B=-(Subscript[ζ, 1])tabGam[[3]]+Plus@@Table[(Subscript[ζ, j-2,1])tabGam[[j]],{j,4,11}];
e2B=(2/U0[[1]] (Subscript[ζ, 1])tabGam[[2]]+Plus@@Table[(Subscript[ζ, j-2,2])tabGam[[j]],{j,4,11}])(Sqrt[(Subscript[σ, 0])]);
e3B=(2 U0[[1]] (Subscript[ζ, 1])tabGam[[1]]+Plus@@Table[(Subscript[ζ, j-2,3])tabGam[[j]],{j,4,11}])/(Sqrt[(Subscript[σ, 0])]);
Print["Taylor expansion of unknowns x,y,z: "]
ClearAll[x0,x1,x2,x3,x4,x5,x6,x7,x8,y0,y1,y2,y3,y4,y5,y6,y7,y8,z0,z1,z2,z3,z4,z5,z6,z7,z8]
razNez={x->(x0+x1 h+x2 h^2+x3 h^3+x4 h^4+x5 h^5+x6 h^6+x7 h^7+x8 h^8),y->(y0+y1 h+y2 h^2+y3 h^3+y4 h^4+y5 h^5+y6 h^6+y7 h^7+y8 h^8),z->(z0+z1 h+z2 h^2+z3 h^3+z4 h^4+z5 h^5+z6 h^6+z7 h^7+z8 h^8)}
(*Print["Taylor expansion of equations: "]
FullSimplify [Series[{e1B,e2B,e3B}/.razNez,{h,0,2}]]*)

Print["We examine in detail the solution x0=y0=z0=0 and x1=y1=z1=1. Expansions of equations e1, e2, e3 up to h^6 are equal to: "]

tmp=Simplify[Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1},{h,0,6}]]

Print["We see that all the coefficients up to h^5 are zero. At h^6 we obtain three equations for x2,y2,z3, but these equations are linearly dependent. We express x2 with y2 and z2: "]
resx2=Flatten[Solve[(#==0)&/@Normal[tmp],{x2}]]

Print["With this solution we further compute the equations at h^7: "]

tmp=Simplify[Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1}/.resx2,{h,0,7}]]

Print["These three equations are again linear equations with respect to x3, y3,z3. The matrix equals: "]
tmp1=Normal[tmp]/h^7;

MM=Simplify[Transpose[Simplify[{D[tmp1,x3],D[tmp1,y3],D[tmp1,z3]}]]];
%//MatrixForm
MM/((7/240) (Subscript[κ, 0]^2) (Subscript[σ, 0]^5)(Subscript[τ, 0]))//MatrixForm
Simplify[Det[MM]]

Print["The right hand side vector includes y2 and z2 and it is equal to: "]
Simplify[-tmp1/.{x3->0,y3->0,z3->0}]

Print["Thus we express x3 with y3,z3,y2,z2: "]
resx3=Simplify[Flatten[Solve[(#==0)&/@Normal[tmp],{x3}]]]

Print["With this solution we further compute the equations at h^8: "]

tmp=Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1}//.resx2//.resx3,{h,0,8}];

tmp1=Normal[tmp]/h^8;

Print["We compute (Subscript[e, 1, 8])-(Subscript[e, 2, 8]) and (Subscript[e, 1, 8])-(Subscript[e, 3, 8]):"]
Simplify[(tmp1[[1]])-tmp1[[2]]]
Simplify[(tmp1[[1]])-tmp1[[3]]]
Print["We see that the solution is y2=z2=0."]

Print["We substitute y2=z2=0 into the first equations and obtain the linear equation for x4 with the leading coefficient: "]
D[tmp1[[1]]/.{y2->0,z2->0},x4]

Print["So we can express x4 with y4, z4, y3 and z3: "]
resx4=Simplify[Flatten[Solve[(tmp1[[1]]/.{y2->0,z2->0})==0,x4]]]

res4=Join[resx4,{y2->0,z2->0}];

Print["With this solution we further compute the equations at h^9: "]

tmp=Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1}//.resx2//.resx3//.res4,{h,0,9}];

tmp1=Normal[tmp]/h^9;

Print["We compute (Subscript[e, 1, 9])-(Subscript[e, 2, 9]) and (Subscript[e, 1, 9])-(Subscript[e, 3, 9]):"]
Simplify[(tmp1[[1]])-tmp1[[2]]]
Simplify[(tmp1[[1]])-tmp1[[3]]]
Print["We see that the solution is y3=z3=0."]

Print["We substitute y3=z3=0 into the first equations and obtain the linear equation for x5 with the leading coefficient: "]
D[tmp1[[1]]/.{y3->0,z3->0},x5]

Print["So we can express x5 with y5, z5, y4 and z4: "]
resx5=Simplify[Flatten[Solve[(tmp1[[1]]/.{y3->0,z3->0})==0,x5]]]

res5=Join[resx5,{y3->0,z3->0}];

Print["With this solution we further compute the equations at h^10: "]

tmp=Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1}//.resx2//.resx3//.res4//.res5,{h,0,10}];

tmp1=Normal[tmp]/h^10;

Print["We compute (Subscript[e, 1, 10])-(Subscript[e, 2, 10]) and (Subscript[e, 1, 10])-(Subscript[e, 3, 10]):"]
pom1=Simplify[(tmp1[[1]])-tmp1[[2]]]
pom2=Simplify[(tmp1[[1]])-tmp1[[3]]]

Print["We get a linear system for y4, z4, which depends only on parameters of the curve. The matrix is equal to:  "]
MM=Simplify[{{D[pom1,y4],D[pom1,z4]},{D[pom2,y4],D[pom2,z4]}}];
MM//MatrixForm
dd=Simplify[-{pom1,pom2}/.{y4->0,z4->0}]
Print["Solution y4,z4:"]
pom3=Simplify[Inverse[MM]].dd;
resyz4={y4->pom3[[1]],z4->pom3[[2]]}

Print["We substitute y4, z4 into the first equations and obtain the linear equation for x6 with the leading coefficient: "]
tmp2=tmp1[[1]]/.resyz4;
D[tmp2,x6]

Print["So we can express x6 with y6, z6, y5 and z5: "]
resx6=Simplify[Flatten[Solve[(tmp1[[1]]/.resyz4)==0,x6]]]

res6=Join[resx6,resyz4];

Print["With this solution we further compute the equations at h^11: "]

tmp=Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1}//.resx2//.resx3//.res4//.res5//.res6,{h,0,11}];

tmp1=Normal[tmp]/h^11;

Print["We compute (Subscript[e, 1, 11])-(Subscript[e, 2, 11]) and (Subscript[e, 1, 11])-(Subscript[e, 3, 11]):"]
pom1=Simplify[(tmp1[[1]])-tmp1[[2]]]
pom2=Simplify[(tmp1[[1]])-tmp1[[3]]]

Print["We get a linear system for y5, z5, which depends only on parameters of the curve. The matrix is equal to:  "]
MM=Simplify[{{D[pom1,y5],D[pom1,z5]},{D[pom2,y5],D[pom2,z5]}}];
MM//MatrixForm
dd=Simplify[-{pom1,pom2}/.{y5->0,z5->0}]
Print["Solution y4,z4:"]
pom3=Simplify[Inverse[MM]].dd;
resyz5={y5->pom3[[1]],z5->pom3[[2]]}

Print["We substitute y4, z4 into the first equations and obtain the linear equation for x6 with the leading coefficient: "]
tmp2=tmp1[[1]]/.resyz5;
D[tmp2,x7]

Print["So we can express x7 with y7, z7, y6 and z6: "]
resx7=Simplify[Flatten[Solve[(tmp1[[1]]/.resyz5)==0,x7]]]

res7=Join[resx7,resyz5];

tmp=Series[{e1B,e2B,e3B}/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1}//.resx2//.resx3//.res4//.res5//.res6//.res7,{h,0,12}];

tmp1=Normal[tmp]/h^12;

Print["We compute (Subscript[e, 1, 12])-(Subscript[e, 2, 12]) and (Subscript[e, 1, 12])-(Subscript[e, 3, 12]):"]
pom1=Simplify[(tmp1[[1]])-tmp1[[2]]]
pom2=Simplify[(tmp1[[1]])-tmp1[[3]]]

Print["We get a linear system for y6, z6, which depends only on parameters of the curve. The matrix is equal to:  "]
MM=Simplify[{{D[pom1,y6],D[pom1,z6]},{D[pom2,y6],D[pom2,z6]}}];
MM//MatrixForm
dd=Simplify[-{pom1,pom2}/.{y6->0,z6->0}]
Print["Solution y4,z4:"]
pom3=Simplify[Inverse[MM]].dd;
resyz6={y6->pom3[[1]],z6->pom3[[2]]}

(* ----------- *)

Print["PH interpolant: "]
pol7A=Normal[Series[pol7/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1}//.resx2//.resx3//.res4//.res5//.res6//.res7,{h,0,6}]];

Print["Reparameterization function: "]
repA=Normal[Series[rep/.razNez/.{ξ->1}/.{x0->0,y0->0,z0->0,x1->1,y1->1,z1->1}//.resx2//.resx3//.res4//.res5//.res6//.res7,{h,0,6}]];
Print["Reparameterized curve f:"]
curveRR=Normal[Series[curveR/.{s->repA}/.{ξ->1},{h,0,6}]];

Print["Residual: "]
residual=Simplify[Series[pol7A-curveRR,{h,0,6}]]

residual1=Simplify[residual/.resyz6]

normRes=Simplify[Normal[residual1].Normal[residual1]]

Examples

Example 1 - data sampled from the Frenet frame

Print["Chosen curve: "]
NAT=60;
curveR=N[{Log[t+3]Sin[Pi t],Log[t+3]Cos[Pi t],Sqrt[t^2+4t+5]},NAT];
aa=0;
bb=1;
ParametricPlot3D[curveR,{t,aa,bb}]

Print["Torsion, curvature and parametric speed: "]
tor=Torsion[curveR,t];
curv=Ukriv[curveR,t];
sig=Norma[D[curveR,t]];
Plot[{tor,curv,sig},{t,0,10},AxesOrigin->{0,0}]
Print["Condition ψ(r,t) (from the paper): "]
cond=AsymptoticCond[curveR,t];
Plot[cond,{t,0,10},PlotRange->All]

Print["Condition ψ(r,0)= ",cond/.{t->0}]

Print["Frenet Frame:"]
FFrame=Frene[curveR,t];
MR=Transpose[FFrame];
DMR=Transpose[D[FFrame,t]];
curveFQ1={1+MR[[1,1]]+MR[[2,2]]+MR[[3,3]],MR[[3,2]]-MR[[2,3]],MR[[1,3]]-MR[[3,1]],MR[[2,1]]-MR[[1,2]]};
DcurveFQ1={DMR[[1,1]]+DMR[[2,2]]+DMR[[3,3]],DMR[[3,2]]-DMR[[2,3]],DMR[[1,3]]-DMR[[3,1]],DMR[[2,1]]-DMR[[1,2]]};
curveFQ=Sqrt[Norma[D[curveR,t]]] (curveFQ1/Norma[curveFQ1]);

Print["Computation of the derivative of Q in a different way:"]
tmp1=D[Sqrt[Norma[D[curveR,t]]],t] (curveFQ1/Norma[curveFQ1]);
tmp2=Sqrt[Norma[D[curveR,t]]] (1/Norma[curveFQ1] DcurveFQ1-(curveFQ1.DcurveFQ1)1/Norma[curveFQ1]^3 curveFQ1);
DcurveFQ=tmp1+tmp2;

Print["Graph of Frenet frame: "]
graf1=Show[DrawGeneralFrame[FFrame[[1]],FFrame[[2]],FFrame[[3]],curveR,t,aa,bb,0.02,0.8,{0.7,0,0},{0,0.7,0},{0,0,0.7}]]

Print["Rotational axis: "]
WF=RotationAxis[FFrame[[1]],FFrame[[2]],FFrame[[3]],t];

Print["We sample the data from the Frenet frame: "]
ClearAll[h]
Print["Interval [0,h]"]
hh=1/2;
Print["Chosen data: "]
P0a=curveR/.{t->aa};
P1a=curveR/.{t->aa+hh};
U0a=curveFQ/.{t->aa}
V0a=DcurveFQ/.{t->aa}
U1a=curveFQ/.{t->aa+hh}
V1a=DcurveFQ/.{t->aa+hh}
If[Sign[U0a.U1a]<0,U1a=-U1a;V1a=-V1a];

Print["Check: "]
(D[curveR,t]/.{t->aa})-Rest[OPStar[U0a,U0a]]
(D[curveR,t]/.{t->aa+hh})-Rest[OPStar[U1a,U1a]]
2*Rest[OPStar[U0a,V0a]]-D[curveR,{t,2}]/.{t->aa}
2*Rest[OPStar[U1a,V1a]]-D[curveR,{t,2}]/.{t->aa+hh}

Print["We need to rotate the data. "]
Print["Rotation matrix: "]
Rot=Inverse[Rotacija[U0a][[3]]];
InvRot=Rotacija[U0a][[3]];
(* ----------- *)
P0=Rot.P0a;
P1=Rot.P1a;
U0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U0a];
U1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U1a];
V0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V0a];
V1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V1a];

Print["Equations: "]
{tabGamF,tabKoefF,tabz,enac2}=ComputeEqForG2PHInt7[U0,U1,V0,V1,P0,P1,x,y,z,ξ];
Print["Chosen ξ: "]
izbKsi=1

Print["Admissible solutions: "]
sol=Quiet[{x,y,z}/.NSolve[(#==0)&/@(enac2/.ξ->izbKsi),{x,y,z},WorkingPrecision->NAT]];
sol=Sort[Select[sol,((Element[#[[1]],Reals]&&(#[[1]]>0))&&(Element[#[[2]],Reals])&&(Element[#[[3]],Reals]))&]];
N[sol,20]//MatrixForm
Print["Number of admissible solutions: "]
Length[sol]

Print["Choose a solution: "]
whichSol=1
solX=sol[[whichSol]];
sol1={(Subscript[λ, 0])->(Sqrt[solX[[1]]]),(Subscript[λ, 1])->izbKsi(Sqrt[solX[[1]]]),(Subscript[μ, 0])->solX[[2]]/(Sqrt[solX[[1]]]),(Subscript[μ, 1])->solX[[3]]/(Sqrt[solX[[1]]])}
Print["Compute quaternion coefficients: "]
KA=SolForG2PHInt[U0,U1,V0,V1,solX[[1]],solX[[2]],solX[[3]],izbKsi];
KA=Table[KvaternionProd[U0a/Norma[U0a],KA[[i]]],{i,1,Length[KA]}];
KAPol=Plus@@Table[KA[[i+1]]bernstein[t,3,i],{i,0,3}];
ERFrame=1/Norma[KAPol]^2{Rest[OPStar[KAPol,KAPol]],Rest[OPStar2[KAPol,KAPol]],Rest[OPStar3[KAPol,KAPol]]};
funW=D[ERFrame[[2]],t].ERFrame[[3]];
maxFunW=Max[Table[Abs[funW]/.{t->i},{i,0,1,1/1000}]];
WER=RotationAxis[ERFrame[[1]],ERFrame[[2]],ERFrame[[3]],t];
Print["Compute PH interpolant: "]
{pol7,KP,loc}=PHCurveOfDegree7[KA,Inverse[Rot].P0,t];
Print["Length of a control polygon: "]
Plus@@Table[Norma[KP[[i+1]]-KP[[i]]],{i,1,Length[KP]-1}]
VP={-2,3,3};
Show[{Graphics3D[{GrayLevel[0.4],PointSize[0.02],Point[KP],Dashed,Line[KP]}],ParametricPlot3D[curveR,{t,aa,aa+hh},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[pol7,{t,0,1},PlotStyle->GrayLevel[0.4],PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

(* Let us draw the frame *)
FFi=FFrame;
ff1=FFi[[1]];
ff2=FFi[[2]];
ff3=FFi[[3]];
vel=hh;
kor=0.02;
g1=DrawGeneralFrame[ff1,ff2,ff3,curveR,t,aa,aa+hh,kor,vel,{0,0,0},{0,0,0},{0,0,0}];
FFi=ERFrame;
ff1=FFi[[1]];
ff2=FFi[[2]];
ff3=FFi[[3]];
par=EqualParameters[KAPol,t,50];
g2=DrawGeneralFrame1[ff1,ff2,ff3,pol7,t,par,vel,{0.7,0,0},{0,0.7,0},{0,0,0.7},0.018,0.002];

Show[{g2,ParametricPlot3D[curveR,{t,aa,aa+hh},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[pol7,{t,0,1},PlotStyle->GrayLevel[0.4]]},ViewPoint->VP,Boxed->False]

Print["ω(t): "]
Plot[Abs[funW],{t,0,1},PlotRange->All]
Print["(Subscript[E, ω]) = ",maxFunW]

Print["Compute the reparameterization function and reparameterize the given curve:"]
rep=Simplify[InterpolatingPolynomial[{{0,{aa,(Subscript[λ, 0])^2,6(Subscript[λ, 0])((Subscript[μ, 0])-(Subscript[λ, 0]))}},{1,{aa+hh,(Subscript[λ, 1])^2 ,6(Subscript[λ, 1])(-(Subscript[μ, 1])+(Subscript[λ, 1]))}}}/.sol1,t]]
curveRR=Simplify[curveR/.{t->rep}];
Print["Check if the G^2 conditions are satisfied: "]
Chop[{{curveRR-pol7/.{t->0},curveRR-pol7/.{t->1}},
{D[curveRR-pol7,t]/.{t->0},D[curveRR-pol7,t]/.{t->1}},
{D[curveRR-pol7,{t,2}]/.{t->0},D[curveRR-pol7,{t,2}]/.{t->1}}},10^(-NAT+10)]

Print["Compute the error. Error function: "]
errFun=Norma[curveRR-pol7];
Plot[errFun,{t,0,1}]
Print["Max error:"]
MyFindMax1[errFun,t,0,1,20]

Print["Check: "]
(ERFrame/.{t->0})-(FFrame/.{t->aa,θ->0})
(ERFrame/.{t->1})-(FFrame/.{t->aa+hh,θ->th})
Norma[D[curveR,t]/.{t->aa}]/Norma[D[curveR,t]/.{t->aa+hh}]-Norma[D[pol7,t]/.{t->0}]/Norma[D[pol7,t]/.{t->1}]

(* --- table of errors as h decreases *)

tabH=Table[2^(-k),{k,1,10}]
tabSol={};
tabPol={};
tabKP={};
tabErr={};
TABW={};
izbKsi=1;
For[kk=1,kk≤Length[tabH],kk++,
hh=tabH[[kk]];
a=0;
b=a+hh;
(*th=Quiet[NIntegrate[-sig tor,{t,a,b},WorkingPrecision->NAT]];*)
P0a=curveR/.{t->a};
P1a=curveR/.{t->b};
U0a=curveFQ/.{t->a};
V0a=DcurveFQ/.{t->a};
U1a=curveFQ/.{t->b};
V1a=DcurveFQ/.{t->b};
If[Sign[U0a.U1a]<0,U1a=-U1a;V1a=-V1a];
Print["********** h = ", hh, " **********"];
Print["Interval (a,b) = ",{a,b}];
(*Print["theta = ",th];*)
Print["Chosen data: "];
Rot=Inverse[Rotacija[U0a][[3]]];
InvRot=Rotacija[U0a][[3]];
(* ----------- *)
P0=Rot.P0a;
P1=Rot.P1a;
U0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U0a];
U1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U1a];
V0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V0a];
V1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V1a];
(* -------------------- *)
Print["Equations: "];
{tabGamF,tabKoefF,tabz,enac2}=ComputeEqForG2PHInt7[U0,U1,V0,V1,P0,P1,x,y,z,ξ];
Print["Admissible solutions x,y,z: "];
sol=Quiet[{x,y,z}/.NSolve[(#==0)&/@(enac2/.ξ->izbKsi),{x,y,z},WorkingPrecision->NAT]];
sol=Sort[Select[sol,((Element[#[[1]],Reals]&&(#[[1]]>0))&&(Element[#[[2]],Reals])&&(Element[#[[3]],Reals]))&]];
Print["Number of solutions: ", Length[sol]];
tabSol=Append[tabSol,sol];
tabpol={};
tabe={};
tabKPa={};
tabEW={};
For[jj=1,jj≤Length[sol],jj++,
Print["---------------------"];
solX=sol[[jj]];
sol1={(Subscript[λ, 0])->(Sqrt[solX[[1]]]),(Subscript[λ, 1])->izbKsi(Sqrt[solX[[1]]]),(Subscript[μ, 0])->solX[[2]]/(Sqrt[solX[[1]]]),(Subscript[μ, 1])->solX[[3]]/(Sqrt[solX[[1]]])};
KA=SolForG2PHInt[U0,U1,V0,V1,solX[[1]],solX[[2]],solX[[3]],izbKsi];
KA=Table[KvaternionProd[U0a/Norma[U0a],KA[[i]]],{i,1,Length[KA]}];
Print["Compute PH interpolants: "];
{pol7,KP,loc}=PHCurveOfDegree7[KA,Inverse[Rot].P0,t];
(*--------*)
KAPol=Plus@@Table[KA[[i+1]]bernstein[t,3,i],{i,0,3}];
ERFrame=1/Norma[KAPol]^2{Rest[OPStar[KAPol,KAPol]],Rest[OPStar2[KAPol,KAPol]],Rest[OPStar3[KAPol,KAPol]]};
funW=D[ERFrame[[2]],t].ERFrame[[3]];
maxFunW1=Max[Table[Abs[funW]/.{t->i},{i,0,1,1/1000}]];
maxFunW=FindMaximum[Abs[funW],{t,0,1},PrecisionGoal->20,WorkingPrecision->20][[1]];
Print["E_w = ",Max[{maxFunW1,maxFunW}]];
tabEW=Append[tabEW,Max[{maxFunW,maxFunW1}]];
(* --------------- *)
tabpol=Append[tabpol,pol7];
tabKPa=Append[tabKPa,KP];
Print["Compute the reparameterization function and reparameterize the given curve:"];
rep=Simplify[InterpolatingPolynomial[{{0,{a,(Subscript[λ, 0])^2,6(Subscript[λ, 0])((Subscript[μ, 0])-(Subscript[λ, 0]))}},{1,{b,(Subscript[λ, 1])^2 ,6(Subscript[λ, 1])(-(Subscript[μ, 1])+(Subscript[λ, 1]))}}}/.sol1,t]];
curveRR=Simplify[curveR/.{t->rep}];
Print["Check if the G^2 conditions are satisfied: "];
Print[Norm[Flatten[Chop[{{curveRR-pol7/.{t->0},curveRR-pol7/.{t->1}},
{D[curveRR-pol7,t]/.{t->0},D[curveRR-pol7,t]/.{t->1}},
{D[curveRR-pol7,{t,2}]/.{t->0},D[curveRR-pol7,{t,2}]/.{t->1}}},10^(-NAT+10)]]]<10^(-NAT+30)];
(* Compute the error. *);
errFun=Chop[Norma[curveRR-pol7],10^(-NAT+10)];
err=MyFindMax1[errFun,t,0,1,NAT-10];
tabe=Append[tabe,err[[1]]];
Print["error = ",N[err[[1]],20]];
];
Print["***********************"];
tabPol=Append[tabPol,tabpol];
tabKP=Append[tabKP,tabKPa];
tabErr=Append[tabErr,tabe];
TABW=Append[TABW,tabEW];
]

Print["Number of admissible solutions for different values of h: "]
Length[#]&/@tabSol
OD=1;

Print["Values x/h of the first four solutions for h=2^(-k), k=1,2,3,...,10: "]
N[Transpose[Table[Table[tabSol[[i,j,1]]/(tabH[[i]]),{i,OD,Length[tabH]}],{j,1,4}]],8]//MatrixForm

Print["Table of errors for the first solution:"]
kat=1;
OD=1;
Transpose[Join[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],{Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]},{N[Last[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[TABW[[i,kat]],16],{i,OD,Length[TABW]}]]]],4]}]]//MatrixForm
Transpose[Append[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]]]//MatrixForm
Print["solution {x,y,z}/h="]
N[Table[tabSol[[i,kat]]/tabH[[i]],{i,OD,Length[tabH]}],16]//MatrixForm

Print["Table of errors for the second solution:"]
kat=2;
OD=1;
Transpose[Join[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],{Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]},{N[Last[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[TABW[[i,kat]],16],{i,OD,Length[TABW]}]]]],4]}]]//MatrixForm
Transpose[Append[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]]]//MatrixForm
Print["solution {x,y,z}/h="]
N[Table[tabSol[[i,kat]]/tabH[[i]],{i,OD,Length[tabH]}],16]//MatrixForm

Print["Table of errors for the third solution:"]
kat=3;
OD=1;
Transpose[Join[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],{Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]},{N[Last[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[TABW[[i,kat]],16],{i,OD,Length[TABW]}]]]],4]}]]//MatrixForm
Transpose[Append[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]]]//MatrixForm
Print["solution {x,y,z}/h="]
N[Table[tabSol[[i,kat]]/tabH[[i]],{i,OD,Length[tabH]}],16]//MatrixForm

Print["Table of errors for the fourth solution:"]
kat=4;
OD=1;
Transpose[Join[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],{Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]},{N[Last[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[TABW[[i,kat]],16],{i,OD,Length[TABW]}]]]],4]}]]//MatrixForm
Transpose[Append[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]]]//MatrixForm
Print["solution {x,y,z}/h="]
N[Table[tabSol[[i,kat]]/tabH[[i]],{i,OD,Length[tabH]}],16]//MatrixForm

(* -------------------- *)

Print["We plot solutions x/h for k ∈ {1,2,...,10}"]
OD=1;
pom1=Table[{i,tabSol[[i,1,1]]/tabH[[i]]},{i,OD,Length[tabSol]}];
pom2=Table[{i,tabSol[[i,2,1]]/tabH[[i]]},{i,OD,Length[tabSol]}];
pom3=Table[{i,tabSol[[i,3,1]]/tabH[[i]]},{i,OD,Length[tabSol]}];
pom4=Table[{i,tabSol[[i,4,1]]/tabH[[i]]},{i,OD,Length[tabSol]}];

Graphics[{PointSize[0.02],RGBColor[0.8,0,0],Point[pom1],Line[pom1],RGBColor[0,0.8,0],Point[pom2],Line[pom2],RGBColor[0,0,0.8],Point[pom3],Line[pom3],Orange,Point[pom4],Line[pom4]},AspectRatio->1,Axes->True,AxesOrigin->{0,0}]

OD=1;pom1=Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[tabErr[[i,1]],{i,OD,Length[tabErr]}]]];
pom2=Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[tabErr[[i,2]],{i,OD,Length[tabErr]}]]];
pom3=Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[tabErr[[i,3]],{i,OD,Length[tabErr]}]]];
pom4=Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[tabErr[[i,4]],{i,OD,Length[tabErr]}]]];

tabGL=GrayLevel[#]&/@{0,0.4,0.6,0.2,0.7}

tabGL=RGBColor[#]&/@{{0.9,0,0},{0,0,0.9},{1,1/2,0},{0,0.9,0},{1/2,1/2,1/2}}

Print["Graph of (Subscript[Log, 2])[err] in dependence of k for all four solutions: "];Show[{Graphics[{PointSize[0.025],tabGL[[1]],Point[Transpose[{Table[k,{k,1,Length[tabH]}],Log[Rest[pom1[[2]]]]/Log[2]}]],Line[Transpose[{Table[k,{k,1,Length[tabH]}],Log[Rest[pom1[[2]]]]/Log[2]}]],PointSize[0.03],tabGL[[2]],Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom2[[2]]]]/Log[2]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom2[[2]]]]/Log[2]}]],PointSize[0.02],tabGL[[3]],Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom3[[2]]]]/Log[2]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom3[[2]]]]/Log[2]}]],PointSize[0.025],tabGL[[4]],Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom4[[2]]]]/Log[2]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom4[[2]]]]/Log[2]}]]},AspectRatio->1,Axes->True,AxesOrigin->{0.5,0},BaseStyle->15,Ticks->{Table[i,{i,1,10}],All},Frame->{{True,False},{True,False}},FrameLabel->{"k","(Subscript[Log, 2])[(Subscript[E, err])]"}]},Ticks->{Table[i,{i,1,10}],All}]

ClearAll[h]
nap1=0.0001 h^4; 
line1={Line[{{4,Log[nap1/.{h->2^(-4)}]/Log[10]},{7,Log[nap1/.{h->2^(-7)}]/Log[10]}}]};
nap2= 0.1h^2; 
line2={Line[{{4,Log[nap2/.{h->2^(-4)}]/Log[10]},{7,Log[nap2/.{h->2^(-7)}]/Log[10]}}]};

Print["Graph of (Subscript[Log, 10])[err] in dependence of k for all four solutions: "];Show[{Graphics[{line1,line2,PointSize[0.025],tabGL[[1]],Point[Transpose[{Table[k,{k,1,Length[tabH]}],Log[Rest[pom1[[2]]]]/Log[10]}]],Line[Transpose[{Table[k,{k,1,Length[tabH]}],Log[Rest[pom1[[2]]]]/Log[10]}]],PointSize[0.03],tabGL[[2]],Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom2[[2]]]]/Log[10]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom2[[2]]]]/Log[10]}]],PointSize[0.02],tabGL[[3]],Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom3[[2]]]]/Log[10]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom3[[2]]]]/Log[10]}]],PointSize[0.025],tabGL[[4]],Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom4[[2]]]]/Log[10]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom4[[2]]]]/Log[10]}]],RGBColor[0,0,0],Text["(h^4)",{5,-11.1}],Text["(h^2)",{5,-5}]},AspectRatio->1,Axes->True,AxesOrigin->{0.5,0},BaseStyle->22,Ticks->{Table[i,{i,1,10}],All},Frame->{{True,False},{True,False}},FrameLabel->{"k","(Subscript[Log, 10])[(Subscript[E, err])]"}]},Ticks->{Table[i,{i,1,10}],All},PlotRange->{All,{0,-16}}]

(* ----------------------------- *)

Print["Choose 'k': "]
kat=2
Print["We plot all the solutions: "]
VP={-2,3,3};;
Show[{Graphics3D[{GrayLevel[0],PointSize[0.02],Point[tabKP[[kat,1]]],Line[tabKP[[kat,1]]]}],ParametricPlot3D[curveR,{t,aa,aa+tabH[[kat]]},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[tabPol[[kat,1]],{t,0,1},PlotStyle->{GrayLevel[0.4]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

Show[{Graphics3D[{GrayLevel[0],PointSize[0.02],Point[tabKP[[kat,2]]],Line[tabKP[[kat,2]]]}],ParametricPlot3D[curveR,{t,aa,aa+tabH[[kat]]},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[tabPol[[kat,2]],{t,0,1},PlotStyle->{GrayLevel[0.4]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

Show[{Graphics3D[{GrayLevel[0],PointSize[0.02],Point[tabKP[[kat,3]]],Line[tabKP[[kat,3]]]}],ParametricPlot3D[curveR,{t,aa,aa+tabH[[kat]]},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[tabPol[[kat,3]],{t,0,1},PlotStyle->{GrayLevel[0.4]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

Show[{Graphics3D[{GrayLevel[0],PointSize[0.02],Point[tabKP[[kat,4]]],Line[tabKP[[kat,4]]]}],ParametricPlot3D[curveR,{t,aa,aa+tabH[[kat]]},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[tabPol[[kat,4]],{t,0,1},PlotStyle->{GrayLevel[0.4]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

VP={-2,3,3};
Show[{
ParametricPlot3D[tabPol[[kat,2]],{t,0,1},PlotStyle->{tabGL[[2]]},PlotRange->All],ParametricPlot3D[tabPol[[kat,3]],{t,0,1},PlotStyle->{tabGL[[3]]},PlotRange->All],ParametricPlot3D[tabPol[[kat,4]],{t,0,1},PlotStyle->{tabGL[[4]]},PlotRange->All],ParametricPlot3D[tabPol[[kat,1]],{t,0,1},PlotStyle->{tabGL[[1]]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False,Axes->False]

Example 2 - data sampled from rotation minimizing frame

Print["Chosen curve: "]
NAT=60;
curveR=N[{Log[t+3]Sin[Pi t],Log[t+3]Cos[Pi t],Sqrt[t^2+4t+5]},NAT];
aa=0;
bb=1;
ParametricPlot3D[curveR,{t,aa,bb}]

Print["Torsion, curvature and parametric speed: "]
tor=Torsion[curveR,t];
curv=Ukriv[curveR,t];
sig=Norma[D[curveR,t]];
Plot[{tor,curv,sig},{t,0,10},AxesOrigin->{0,0}]
Print["Condition ψ(r,t) (from the paper): "]
cond=AsymptoticCond[curveR,t];
Plot[cond,{t,0,10},PlotRange->All]

Print["Condition ψ(r,0)= ",cond/.{t->0}]

Print["Frenet Frame:"]
FFrame=Frene[curveR,t];
MR=Transpose[FFrame];
DMR=Transpose[D[FFrame,t]];
curveFQ1={1+MR[[1,1]]+MR[[2,2]]+MR[[3,3]],MR[[3,2]]-MR[[2,3]],MR[[1,3]]-MR[[3,1]],MR[[2,1]]-MR[[1,2]]};
DcurveFQ1={DMR[[1,1]]+DMR[[2,2]]+DMR[[3,3]],DMR[[3,2]]-DMR[[2,3]],DMR[[1,3]]-DMR[[3,1]],DMR[[2,1]]-DMR[[1,2]]};
curveFQ=Sqrt[Norma[D[curveR,t]]] (curveFQ1/Norma[curveFQ1]);

Print["Computation of the derivative of Q in a different way:"]
tmp1=D[Sqrt[Norma[D[curveR,t]]],t] (curveFQ1/Norma[curveFQ1]);
tmp2=Sqrt[Norma[D[curveR,t]]] (1/Norma[curveFQ1] DcurveFQ1-(curveFQ1.DcurveFQ1)1/Norma[curveFQ1]^3 curveFQ1);
DcurveFQ=tmp1+tmp2;

Print["Graph of Frenet frame: "]
graf1=Show[DrawGeneralFrame[FFrame[[1]],FFrame[[2]],FFrame[[3]],curveR,t,aa,bb,0.02,0.8,{0.7,0,0},{0,0.7,0},{0,0,0.7}]]

Print["Rotational axis: "]
WF=RotationAxis[FFrame[[1]],FFrame[[2]],FFrame[[3]],t];

(* ----------- *)

Print["Rotation minimizing frame:"]
AFrame={FFrame[[1]],Cos[θ]FFrame[[2]]+Sin[θ]FFrame[[3]],-Sin[θ]FFrame[[2]]+Cos[θ]FFrame[[3]]};
DAFrame={D[FFrame[[1]],t],-tor sig AFrame[[3]]+Cos[θ]D[FFrame[[2]],t]+Sin[θ]D[FFrame[[3]],t],tor sig AFrame[[2]]-Sin[θ]D[FFrame[[2]],t]+Cos[θ]D[FFrame[[3]],t]};

MR=Transpose[AFrame];
DMR=Transpose[DAFrame];
curveQ1={1+MR[[1,1]]+MR[[2,2]]+MR[[3,3]],MR[[3,2]]-MR[[2,3]],MR[[1,3]]-MR[[3,1]],MR[[2,1]]-MR[[1,2]]};
DcurveQ1={DMR[[1,1]]+DMR[[2,2]]+DMR[[3,3]],DMR[[3,2]]-DMR[[2,3]],DMR[[1,3]]-DMR[[3,1]],DMR[[2,1]]-DMR[[1,2]]};
curveQ=Sqrt[Norma[D[curveR,t]]] (curveQ1/Norma[curveQ1]);

tmp1=D[Sqrt[Norma[D[curveR,t]]],t] (curveQ1/Norma[curveQ1]);
tmp2=Sqrt[Norma[D[curveR,t]]] (1/Norma[curveQ1] DcurveQ1-(curveQ1.DcurveQ1)1/Norma[curveQ1]^3 curveQ1);
DcurveQ=tmp1+tmp2;

tabp=Table[aa+i (bb-aa)/20,{i,0,20}];
tabp=Table[i,{i,aa,bb,2/100}];
tabTh=Table[NIntegrate[-sig tor,{t,0,tabp[[i]]},WorkingPrecision->NAT-10],{i,1,Length[tabp]}];

tabAFrame=Table[AFrame/.{θ->tabTh[[i]],t->tabp[[i]]},{i,1,Length[tabTh]}];
tabCurve=Table[curveR/.{t->tabp[[kat]]},{kat,1,Length[tabp]}];

Print["Graph of rotation minimizing frame: "]
graf2=DrawGeneralFrameTab[tabAFrame,tabCurve,0.8,{1,0,0},{0,1,0},{0,0,1}]

Print["Let us check:"]
omegaAF=DAFrame[[2]].AFrame[[3]];
Norm[Table[omegaAF/.{θ->tabTh[[i]],t->tabp[[i]]},{i,1,Length[tabTh]}]]

Norm[Table[DAFrame[[2]].AFrame[[2]]/.{θ->tabTh[[i]],t->tabp[[i]]},{i,1,Length[tabTh]}]]

Norm[Table[DAFrame[[3]].AFrame[[3]]/.{θ->tabTh[[i]],t->tabp[[i]]},{i,1,Length[tabTh]}]]

Show[{graf1,graf2}]

ClearAll[h]
Print["Interval [0,h]"]
hh=1/4;
th=Quiet[NIntegrate[-sig tor,{t,aa,aa+hh},WorkingPrecision->NAT]];
Print["θ(h) = ", th]
Print["Chosen data: "]
P0a=curveR/.{t->aa};
P1a=curveR/.{t->aa+hh};
U0a=curveQ/.{t->aa,θ->0}
V0a=DcurveQ/.{t->aa,θ->0}
U1a=curveQ/.{t->aa+hh,θ->th}
V1a=DcurveQ/.{t->aa+hh,θ->th}
If[Sign[U0a.U1a]<0,U1a=-U1a;V1a=-V1a];

Print["Check: "]
(D[curveR,t]/.{t->aa})-Rest[OPStar[U0a,U0a]]
(D[curveR,t]/.{t->aa+hh})-Rest[OPStar[U1a,U1a]]
2*Rest[OPStar[U0a,V0a]]-D[curveR,{t,2}]/.{t->aa}
2*Rest[OPStar[U1a,V1a]]-D[curveR,{t,2}]/.{t->aa+hh}

Print["We need to rotate the data. "]
Print["Rotation matrix: "]
Rot=Inverse[Rotacija[U0a][[3]]];
InvRot=Rotacija[U0a][[3]];
(* ----------- *)
P0=Rot.P0a;
P1=Rot.P1a;
U0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U0a];
U1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U1a];
V0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V0a];
V1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V1a];

Print["Equations: "]
{tabGamF,tabKoefF,tabz,enac2}=ComputeEqForG2PHInt7[U0,U1,V0,V1,P0,P1,x,y,z,ξ];
Print["Chosen ξ: "]
izbKsi=1

Print["Admissible solutions: "]
sol=Quiet[{x,y,z}/.NSolve[(#==0)&/@(enac2/.ξ->izbKsi),{x,y,z},WorkingPrecision->NAT]];
sol=Sort[Select[sol,((Element[#[[1]],Reals]&&(#[[1]]>0))&&(Element[#[[2]],Reals])&&(Element[#[[3]],Reals]))&]];
N[sol,20]//MatrixForm
Print["Number of admissible solutions: "]
Length[sol]

Print["Choose a solution: "]
whichSol=1
solX=sol[[whichSol]];
sol1={(Subscript[λ, 0])->(Sqrt[solX[[1]]]),(Subscript[λ, 1])->izbKsi(Sqrt[solX[[1]]]),(Subscript[μ, 0])->solX[[2]]/(Sqrt[solX[[1]]]),(Subscript[μ, 1])->solX[[3]]/(Sqrt[solX[[1]]])}
Print["Compute quaternion coefficients: "]
KA=SolForG2PHInt[U0,U1,V0,V1,solX[[1]],solX[[2]],solX[[3]],izbKsi];
KA=Table[KvaternionProd[U0a/Norma[U0a],KA[[i]]],{i,1,Length[KA]}];
KAPol=Plus@@Table[KA[[i+1]]bernstein[t,3,i],{i,0,3}];
ERFrame=1/Norma[KAPol]^2{Rest[OPStar[KAPol,KAPol]],Rest[OPStar2[KAPol,KAPol]],Rest[OPStar3[KAPol,KAPol]]};
funW=D[ERFrame[[2]],t].ERFrame[[3]];
maxFunW=Max[Table[Abs[funW]/.{t->i},{i,0,1,1/1000}]];
WER=RotationAxis[ERFrame[[1]],ERFrame[[2]],ERFrame[[3]],t];
Print["Compute PH interpolant: "]
{pol7,KP,loc}=PHCurveOfDegree7[KA,Inverse[Rot].P0,t];
Print["Length of a control polygon: "]
Plus@@Table[Norma[KP[[i+1]]-KP[[i]]],{i,1,Length[KP]-1}]
VP={-2,3,3};
Show[{Graphics3D[{GrayLevel[0.4],PointSize[0.02],Point[KP],Dashed,Line[KP]}],ParametricPlot3D[curveR,{t,aa,aa+hh},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[pol7,{t,0,1},PlotStyle->GrayLevel[0.4],PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

(* Let us draw the frame *)
FFi=FFrame;
ff1=FFi[[1]];
ff2=FFi[[2]];
ff3=FFi[[3]];
vel=hh;
kor=0.02;
g1=DrawGeneralFrame[ff1,ff2,ff3,curveR,t,aa,aa+hh,kor,vel,{0,0,0},{0,0,0},{0,0,0}];
FFi=ERFrame;
ff1=FFi[[1]];
ff2=FFi[[2]];
ff3=FFi[[3]];
par=EqualParameters[KAPol,t,50];
g2=DrawGeneralFrame1[ff1,ff2,ff3,pol7,t,par,vel,{0.7,0,0},{0,0.7,0},{0,0,0.7},0.018,0.002];

Show[{g2,ParametricPlot3D[curveR,{t,aa,aa+hh},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[pol7,{t,0,1},PlotStyle->GrayLevel[0.4]]},ViewPoint->VP,Boxed->False]

Print["ω(t): "]
Plot[Abs[funW],{t,0,1},PlotRange->All]
Print["(Subscript[E, ω]) = ",maxFunW]

Print["Compute the reparameterization function and reparameterize the given curve:"]
rep=Simplify[InterpolatingPolynomial[{{0,{aa,(Subscript[λ, 0])^2,6(Subscript[λ, 0])((Subscript[μ, 0])-(Subscript[λ, 0]))}},{1,{aa+hh,(Subscript[λ, 1])^2 ,6(Subscript[λ, 1])(-(Subscript[μ, 1])+(Subscript[λ, 1]))}}}/.sol1,t]]
curveRR=Simplify[curveR/.{t->rep}];
Print["Check if the G^2 conditions are satisfied: "]
Chop[{{curveRR-pol7/.{t->0},curveRR-pol7/.{t->1}},
{D[curveRR-pol7,t]/.{t->0},D[curveRR-pol7,t]/.{t->1}},
{D[curveRR-pol7,{t,2}]/.{t->0},D[curveRR-pol7,{t,2}]/.{t->1}}},10^(-NAT+10)]

Print["Compute the error. Error function: "]
errFun=Norma[curveRR-pol7];
Plot[errFun,{t,0,1}]
Print["Max error:"]
MyFindMax1[errFun,t,0,1,20]

Print["Check: "]
(ERFrame/.{t->0})-(AFrame/.{t->aa,θ->0})
(ERFrame/.{t->1})-(AFrame/.{t->aa+hh,θ->th})
Norma[D[curveR,t]/.{t->aa}]/Norma[D[curveR,t]/.{t->aa+hh}]-Norma[D[pol7,t]/.{t->0}]/Norma[D[pol7,t]/.{t->1}]

(* --- table of errors as h decreases *)

tabH=Table[2^(-k),{k,1,10}]
tabSol={};
tabPol={};
tabKP={};
tabErr={};
TABW={};
izbKsi=1;
For[kk=1,kk≤Length[tabH],kk++,
hh=tabH[[kk]];
a=0;
b=a+hh;
th=Quiet[NIntegrate[-sig tor,{t,a,b},WorkingPrecision->NAT]];
P0a=curveR/.{t->a};
P1a=curveR/.{t->b};
U0a=curveQ/.{t->a,θ->0};
V0a=DcurveQ/.{t->a,θ->0};
U1a=curveQ/.{t->b,θ->th};
V1a=DcurveQ/.{t->b,θ->th};
If[Sign[U0a.U1a]<0,U1a=-U1a;V1a=-V1a];
Print["********** h = ", hh, " **********"];
Print["Interval (a,b) = ",{a,b}];
Print["θ(h) = ",th];
Print["Chosen data: "];
Rot=Inverse[Rotacija[U0a][[3]]];
InvRot=Rotacija[U0a][[3]];
(* ----------- *)
P0=Rot.P0a;
P1=Rot.P1a;
U0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U0a];
U1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U1a];
V0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V0a];
V1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V1a];
(* -------------------- *)
Print["Equations: "];
{tabGamF,tabKoefF,tabz,enac2}=ComputeEqForG2PHInt7[U0,U1,V0,V1,P0,P1,x,y,z,ξ];
Print["Admissible solutions x,y,z: "];
sol=Quiet[{x,y,z}/.NSolve[(#==0)&/@(enac2/.ξ->izbKsi),{x,y,z},WorkingPrecision->NAT]];
sol=Sort[Select[sol,((Element[#[[1]],Reals]&&(#[[1]]>0))&&(Element[#[[2]],Reals])&&(Element[#[[3]],Reals]))&]];
Print["Number of solutions: ", Length[sol]];
tabSol=Append[tabSol,sol];
tabpol={};
tabe={};
tabKPa={};
tabEW={};
For[jj=1,jj≤Length[sol],jj++,
Print["---------------------"];
solX=sol[[jj]];
sol1={(Subscript[λ, 0])->(Sqrt[solX[[1]]]),(Subscript[λ, 1])->izbKsi(Sqrt[solX[[1]]]),(Subscript[μ, 0])->solX[[2]]/(Sqrt[solX[[1]]]),(Subscript[μ, 1])->solX[[3]]/(Sqrt[solX[[1]]])};
KA=SolForG2PHInt[U0,U1,V0,V1,solX[[1]],solX[[2]],solX[[3]],izbKsi];
KA=Table[KvaternionProd[U0a/Norma[U0a],KA[[i]]],{i,1,Length[KA]}];
Print["Compute PH interpolants: "];
{pol7,KP,loc}=PHCurveOfDegree7[KA,Inverse[Rot].P0,t];
(*--------*)
KAPol=Plus@@Table[KA[[i+1]]bernstein[t,3,i],{i,0,3}];
ERFrame=1/Norma[KAPol]^2{Rest[OPStar[KAPol,KAPol]],Rest[OPStar2[KAPol,KAPol]],Rest[OPStar3[KAPol,KAPol]]};
funW=D[ERFrame[[2]],t].ERFrame[[3]];
maxFunW1=Max[Table[Abs[funW]/.{t->i},{i,0,1,1/1000}]];
maxFunW=FindMaximum[Abs[funW],{t,0,1},PrecisionGoal->20,WorkingPrecision->20][[1]];
Print["E_w = ",Max[{maxFunW1,maxFunW}]];
tabEW=Append[tabEW,Max[{maxFunW,maxFunW1}]];
(* --------------- *)
tabpol=Append[tabpol,pol7];
tabKPa=Append[tabKPa,KP];
Print["Compute the reparameterization function and reparameterize the given curve:"];
rep=Simplify[InterpolatingPolynomial[{{0,{a,(Subscript[λ, 0])^2,6(Subscript[λ, 0])((Subscript[μ, 0])-(Subscript[λ, 0]))}},{1,{b,(Subscript[λ, 1])^2 ,6(Subscript[λ, 1])(-(Subscript[μ, 1])+(Subscript[λ, 1]))}}}/.sol1,t]];
curveRR=Simplify[curveR/.{t->rep}];
Print["Check if the G^2 conditions are satisfied: "];
Print[Norm[Flatten[Chop[{{curveRR-pol7/.{t->0},curveRR-pol7/.{t->1}},
{D[curveRR-pol7,t]/.{t->0},D[curveRR-pol7,t]/.{t->1}},
{D[curveRR-pol7,{t,2}]/.{t->0},D[curveRR-pol7,{t,2}]/.{t->1}}},10^(-NAT+10)]]]<10^(-NAT+30)];
(* Compute the error. *);
errFun=Chop[Norma[curveRR-pol7],10^(-NAT+10)];
err=MyFindMax1[errFun,t,0,1,NAT-10];
tabe=Append[tabe,err[[1]]];
Print["error = ",N[err[[1]],20]];
];
Print["***********************"];
tabPol=Append[tabPol,tabpol];
tabKP=Append[tabKP,tabKPa];
tabErr=Append[tabErr,tabe];
TABW=Append[TABW,tabEW];
]

Print["For h=1/2 we get one solution, while for other values of h we get five admissible solutions: "]
Length[#]&/@tabSol
OD=2;

Print["The solution (x,y,z)/h for h=1/2: "]
N[tabSol[[1]]/tabH[[1]],8]//MatrixForm

Print["Values x/h of the first four solutions for h=2^(-k), k=2,3,...,10: "]
N[Transpose[Table[Table[tabSol[[i,j,1]]/(tabH[[i]]),{i,OD,Length[tabH]}],{j,1,4}]],8]//MatrixForm

Print["Table of errors for the first solution:"]
kat=1;
OD=1;
Transpose[Join[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],{Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]},{N[Last[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[TABW[[i,kat]],16],{i,OD,Length[TABW]}]]]],4]}]]//MatrixForm
Transpose[Append[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]]]//MatrixForm
Print["solution {x,y,z}/h="]
N[Table[tabSol[[i,kat]]/tabH[[i]],{i,OD,Length[tabH]}],16]//MatrixForm

Print["Table of errors for the second solution:"]
kat=2;
OD=2;
Transpose[Join[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],{Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]},{N[Last[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[TABW[[i,kat]],16],{i,OD,Length[TABW]}]]]],4]}]]//MatrixForm
Transpose[Append[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]]]//MatrixForm
Print["solution {x,y,z}/h="]
N[Table[tabSol[[i,kat]]/tabH[[i]],{i,OD,Length[tabH]}],16]//MatrixForm

Print["Table of errors for the third solution:"]
kat=3;
OD=2;
Transpose[Join[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],{Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]},{N[Last[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[TABW[[i,kat]],16],{i,OD,Length[TABW]}]]]],4]}]]//MatrixForm
Transpose[Append[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]]]//MatrixForm
Print["solution {x,y,z}/h="]
N[Table[tabSol[[i,kat]]/tabH[[i]],{i,OD,Length[tabH]}],16]//MatrixForm

Print["Table of errors for the fourth solution:"]
kat=4;
OD=2;
Transpose[Join[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],{Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]},{N[Last[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[TABW[[i,kat]],16],{i,OD,Length[TABW]}]]]],4]}]]//MatrixForm
Transpose[Append[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]]]//MatrixForm
Print["solution {x,y,z}/h="]
N[Table[tabSol[[i,kat]]/tabH[[i]],{i,OD,Length[tabH]}],16]//MatrixForm

Print["Table of errors for the fifth solution:"]
kat=5;
OD=2;
Transpose[Join[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],{Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]},{N[Last[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[TABW[[i,kat]],16],{i,OD,Length[TABW]}]]]],4]}]]//MatrixForm
Print["solution {x,y,z}="]
N[Table[tabSol[[i,kat]],{i,OD,Length[tabH]}],16]//MatrixForm

(* -------------------- *)

Print["We plot solutions x/h for k ∈ {1,2,...,10}"]
pom1=Table[{i,tabSol[[i,1,1]]/tabH[[i]]},{i,1,Length[tabSol]}];
pom2=Table[{i,tabSol[[i,2,1]]/tabH[[i]]},{i,OD,Length[tabSol]}];
pom3=Table[{i,tabSol[[i,3,1]]/tabH[[i]]},{i,OD,Length[tabSol]}];
pom4=Table[{i,tabSol[[i,4,1]]/tabH[[i]]},{i,OD,Length[tabSol]}];

Graphics[{PointSize[0.02],RGBColor[0.8,0,0],Point[pom1],Line[pom1],RGBColor[0,0.8,0],Point[pom2],Line[pom2],RGBColor[0,0,0.8],Point[pom3],Line[pom3],Orange,Point[pom4],Line[pom4]},AspectRatio->1,Axes->True,AxesOrigin->{0,0}]

OD=1;pom1=Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[tabErr[[i,1]],{i,OD,Length[tabErr]}]]];
OD=2;
pom2=Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[tabErr[[i,2]],{i,OD,Length[tabErr]}]]];
pom3=Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[tabErr[[i,3]],{i,OD,Length[tabErr]}]]];
pom4=Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[tabErr[[i,4]],{i,OD,Length[tabErr]}]]];

tabGL=GrayLevel[#]&/@{0,0.4,0.6,0.2,0.7}

tabGL=RGBColor[#]&/@{{0.9,0,0},{1,1/2,0},{0,0.9,0},{0,0,0.9},{1/2,1/2,1/2}}

Print["Graph of (Subscript[Log, 2])[err] in dependence of k for all four solutions: "];Show[{Graphics[{PointSize[0.025],tabGL[[1]],Point[Transpose[{Table[k,{k,1,Length[tabH]}],Log[Rest[pom1[[2]]]]/Log[2]}]],Line[Transpose[{Table[k,{k,1,Length[tabH]}],Log[Rest[pom1[[2]]]]/Log[2]}]],PointSize[0.03],tabGL[[2]],Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom2[[2]]]]/Log[2]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom2[[2]]]]/Log[2]}]],PointSize[0.02],tabGL[[3]],Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom3[[2]]]]/Log[2]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom3[[2]]]]/Log[2]}]],PointSize[0.025],tabGL[[4]],Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom4[[2]]]]/Log[2]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom4[[2]]]]/Log[2]}]]},AspectRatio->1,Axes->True,AxesOrigin->{0.5,0},BaseStyle->15,Ticks->{Table[i,{i,1,10}],All},Frame->{{True,False},{True,False}},FrameLabel->{"k","(Subscript[Log, 2])[(Subscript[E, err])]"}]},Ticks->{Table[i,{i,1,10}],All}]

ClearAll[h]
nap1=0.05 h^6; 
line1={Line[{{4,Log[nap1/.{h->2^(-4)}]/Log[10]},{7,Log[nap1/.{h->2^(-7)}]/Log[10]}}]};
nap2= 0.3h^2; 
line2={Line[{{4,Log[nap2/.{h->2^(-4)}]/Log[10]},{7,Log[nap2/.{h->2^(-7)}]/Log[10]}}]};
nap3=15h^1; 
line3={Line[{{4,Log[nap3/.{h->2^(-4)}]/Log[10]},{7,Log[nap3/.{h->2^(-7)}]/Log[10]}}]};

Print["Graph of (Subscript[Log, 10])[err] in dependence of k for all four solutions: "];Show[{Graphics[{line1,line2,line3,PointSize[0.025],tabGL[[1]],Point[Transpose[{Table[k,{k,1,Length[tabH]}],Log[Rest[pom1[[2]]]]/Log[10]}]],Line[Transpose[{Table[k,{k,1,Length[tabH]}],Log[Rest[pom1[[2]]]]/Log[10]}]],PointSize[0.03],tabGL[[2]],Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom2[[2]]]]/Log[10]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom2[[2]]]]/Log[10]}]],PointSize[0.02],tabGL[[3]],Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom3[[2]]]]/Log[10]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom3[[2]]]]/Log[10]}]],PointSize[0.025],tabGL[[4]],Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom4[[2]]]]/Log[10]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom4[[2]]]]/Log[10]}]],RGBColor[0,0,0],Text["(h^6)",{6,-11}],Text["(h^2)",{6,-5}],Text["h",{6,-0.1}]},AspectRatio->1,Axes->True,AxesOrigin->{0.5,0},BaseStyle->22,Ticks->{Table[i,{i,1,10}],All},Frame->{{True,False},{True,False}},FrameLabel->{"k","(Subscript[Log, 10])[(Subscript[E, err])]"}]},Ticks->{Table[i,{i,1,10}],All}]

(* ----------------------------- *)

Print["Choose 'k': "]
kat=2
Print["We plot all the solutions: "]
VP={-2,3,3};;
Show[{Graphics3D[{GrayLevel[0],PointSize[0.02],Point[tabKP[[kat,1]]],Line[tabKP[[kat,1]]]}],ParametricPlot3D[curveR,{t,aa,aa+tabH[[kat]]},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[tabPol[[kat,1]],{t,0,1},PlotStyle->{GrayLevel[0.4]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

Show[{Graphics3D[{GrayLevel[0],PointSize[0.02],Point[tabKP[[kat,2]]],Line[tabKP[[kat,2]]]}],ParametricPlot3D[curveR,{t,aa,aa+tabH[[kat]]},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[tabPol[[kat,2]],{t,0,1},PlotStyle->{GrayLevel[0.4]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

Show[{Graphics3D[{GrayLevel[0],PointSize[0.02],Point[tabKP[[kat,3]]],Line[tabKP[[kat,3]]]}],ParametricPlot3D[curveR,{t,aa,aa+tabH[[kat]]},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[tabPol[[kat,3]],{t,0,1},PlotStyle->{GrayLevel[0.4]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

Show[{Graphics3D[{GrayLevel[0],PointSize[0.02],Point[tabKP[[kat,4]]],Line[tabKP[[kat,4]]]}],ParametricPlot3D[curveR,{t,aa,aa+tabH[[kat]]},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[tabPol[[kat,4]],{t,0,1},PlotStyle->{GrayLevel[0.4]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

Show[{Graphics3D[{GrayLevel[0],PointSize[0.02],Point[tabKP[[kat,5]]],Line[tabKP[[kat,5]]]}],ParametricPlot3D[curveR,{t,aa,aa+tabH[[kat]]},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[tabPol[[kat,5]],{t,0,1},PlotStyle->{GrayLevel[0.4]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

VP={-2,3,3};
Show[{
ParametricPlot3D[tabPol[[kat,2]],{t,0,1},PlotStyle->{tabGL[[2]]},PlotRange->All],ParametricPlot3D[tabPol[[kat,3]],{t,0,1},PlotStyle->{tabGL[[3]]},PlotRange->All],ParametricPlot3D[tabPol[[kat,4]],{t,0,1},PlotStyle->{tabGL[[4]]},PlotRange->All],ParametricPlot3D[tabPol[[kat,5]],{t,0,1},PlotStyle->{tabGL[[5]]},PlotRange->All],ParametricPlot3D[tabPol[[kat,1]],{t,0,1},PlotStyle->{tabGL[[1]]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False,Axes->False]

Example - data sampled from adapted frame

Print["Chosen curve: "]
NAT=60;
curveR=N[{Log[t+3]Sin[Pi t],Log[t+3]Cos[Pi t],Sqrt[t^2+4t+5]},NAT];
aa=0;
bb=1;
ParametricPlot3D[curveR,{t,aa,bb}]

Print["Torsion, curvature and parametric speed: "]
tor=Torsion[curveR,t];
curv=Ukriv[curveR,t];
sig=Norma[D[curveR,t]];
Plot[{tor,curv,sig},{t,0,10},AxesOrigin->{0,0}]
Print["Condition ψ(r,t) (from the paper): "]
cond=AsymptoticCond[curveR,t];
Plot[cond,{t,0,10},PlotRange->All]

Print["Condition ψ(r,0)= ",cond/.{t->0}]

Print["Frenet Frame:"]
FFrame=Frene[curveR,t];
MR=Transpose[FFrame];
DMR=Transpose[D[FFrame,t]];
curveFQ1={1+MR[[1,1]]+MR[[2,2]]+MR[[3,3]],MR[[3,2]]-MR[[2,3]],MR[[1,3]]-MR[[3,1]],MR[[2,1]]-MR[[1,2]]};
DcurveFQ1={DMR[[1,1]]+DMR[[2,2]]+DMR[[3,3]],DMR[[3,2]]-DMR[[2,3]],DMR[[1,3]]-DMR[[3,1]],DMR[[2,1]]-DMR[[1,2]]};
curveFQ=Sqrt[Norma[D[curveR,t]]] (curveFQ1/Norma[curveFQ1]);

Print["Computation of the derivative of Q in a different way:"]
tmp1=D[Sqrt[Norma[D[curveR,t]]],t] (curveFQ1/Norma[curveFQ1]);
tmp2=Sqrt[Norma[D[curveR,t]]] (1/Norma[curveFQ1] DcurveFQ1-(curveFQ1.DcurveFQ1)1/Norma[curveFQ1]^3 curveFQ1);
DcurveFQ=tmp1+tmp2;

graf1=Show[DrawGeneralFrame[FFrame[[1]],FFrame[[2]],FFrame[[3]],curveR,t,aa,bb,0.02,0.8,{0.7,0,0},{0,0.7,0},{0,0,0.7}]]

Print["Rotational axis: "]
WF=RotationAxis[FFrame[[1]],FFrame[[2]],FFrame[[3]],t];

(* ----------- *)

-tor sig/.{t->0}

Print["Chosen adapted frame:"]
theta=1/2t+t^2/4;
AFrame={FFrame[[1]],Cos[θ]FFrame[[2]]+Sin[θ]FFrame[[3]],-Sin[θ]FFrame[[2]]+Cos[θ]FFrame[[3]]}/.{θ->theta};
DAFrame=D[AFrame,t];

MR=Transpose[AFrame];
DMR=Transpose[DAFrame];
curveQ1={1+MR[[1,1]]+MR[[2,2]]+MR[[3,3]],MR[[3,2]]-MR[[2,3]],MR[[1,3]]-MR[[3,1]],MR[[2,1]]-MR[[1,2]]};
DcurveQ1={DMR[[1,1]]+DMR[[2,2]]+DMR[[3,3]],DMR[[3,2]]-DMR[[2,3]],DMR[[1,3]]-DMR[[3,1]],DMR[[2,1]]-DMR[[1,2]]};
curveQ=Sqrt[Norma[D[curveR,t]]] (curveQ1/Norma[curveQ1]);

tmp1=D[Sqrt[Norma[D[curveR,t]]],t] (curveQ1/Norma[curveQ1]);
tmp2=Sqrt[Norma[D[curveR,t]]] (1/Norma[curveQ1] DcurveQ1-(curveQ1.DcurveQ1)1/Norma[curveQ1]^3 curveQ1);
DcurveQ=tmp1+tmp2;

tabp=Table[i,{i,aa,bb,2/100}];

tabAFrame=Table[AFrame/.{t->tabp[[i]]},{i,1,Length[tabp]}];
tabCurve=Table[curveR/.{t->tabp[[kat]]},{kat,1,Length[tabp]}];

graf2=DrawGeneralFrameTab[tabAFrame,tabCurve,0.8,{1,0,0},{0,1,0},{0,0,1}]

Show[{graf1,graf2}]

ClearAll[h]
Print["Interval [0,h]"]
hh=1/4;
Print["Chosen data: "]
P0a=curveR/.{t->aa};
P1a=curveR/.{t->aa+hh};
U0a=curveQ/.{t->aa}
V0a=DcurveQ/.{t->aa}
U1a=curveQ/.{t->aa+hh}
V1a=DcurveQ/.{t->aa+hh}
If[Sign[U0a.U1a]<0,U1a=-U1a;V1a=-V1a];

Print["Check: "]
(D[curveR,t]/.{t->aa})-Rest[OPStar[U0a,U0a]]
(D[curveR,t]/.{t->aa+hh})-Rest[OPStar[U1a,U1a]]
2*Rest[OPStar[U0a,V0a]]-D[curveR,{t,2}]/.{t->aa}
2*Rest[OPStar[U1a,V1a]]-D[curveR,{t,2}]/.{t->aa+hh}

(* ---------- *)

Print["We need to rotate the data. "]
Print["Rotation matrix: "]
Rot=Inverse[Rotacija[U0a][[3]]];
InvRot=Rotacija[U0a][[3]];
(* ----------- *)
P0=Rot.P0a;
P1=Rot.P1a;
U0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U0a];
U1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U1a];
V0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V0a];
V1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V1a];

Print["Equations: "]
{tabGamF,tabKoefF,tabz,enac2}=ComputeEqForG2PHInt7[U0,U1,V0,V1,P0,P1,x,y,z,ξ];
Print["Chosen ξ: "]
izbKsi=1

Print["Admissible solutions: "]
sol=Quiet[{x,y,z}/.NSolve[(#==0)&/@(enac2/.ξ->izbKsi),{x,y,z},WorkingPrecision->NAT]];
sol=Sort[Select[sol,((Element[#[[1]],Reals]&&(#[[1]]>0))&&(Element[#[[2]],Reals])&&(Element[#[[3]],Reals]))&]];
N[sol/hh,20]//MatrixForm
Print["Number of admissible solutions: "]
Length[sol]

Print["Choose a solution: "]
whichSol=5
solX=sol[[whichSol]];
sol1={(Subscript[λ, 0])->(Sqrt[solX[[1]]]),(Subscript[λ, 1])->izbKsi(Sqrt[solX[[1]]]),(Subscript[μ, 0])->solX[[2]]/(Sqrt[solX[[1]]]),(Subscript[μ, 1])->solX[[3]]/(Sqrt[solX[[1]]])}
Print["Compute quaternion coefficients: "]
KA=SolForG2PHInt[U0,U1,V0,V1,solX[[1]],solX[[2]],solX[[3]],izbKsi];
KA=Table[KvaternionProd[U0a/Norma[U0a],KA[[i]]],{i,1,Length[KA]}];
KAPol=Plus@@Table[KA[[i+1]]bernstein[t,3,i],{i,0,3}];
ERFrame=1/Norma[KAPol]^2{Rest[OPStar[KAPol,KAPol]],Rest[OPStar2[KAPol,KAPol]],Rest[OPStar3[KAPol,KAPol]]};
funW=D[ERFrame[[2]],t].ERFrame[[3]];
maxFunW=Max[Table[Abs[funW]/.{t->i},{i,0,1,1/1000}]];
WER=RotationAxis[ERFrame[[1]],ERFrame[[2]],ERFrame[[3]],t];
Print["Compute PH interpolant: "]
{pol7,KP,loc}=PHCurveOfDegree7[KA,Inverse[Rot].P0,t];
Print["Length of a control polygon: "]
Plus@@Table[Norma[KP[[i+1]]-KP[[i]]],{i,1,Length[KP]-1}]
VP={-2,3,3};
Show[{Graphics3D[{GrayLevel[0.4],PointSize[0.02],Point[KP],Dashed,Line[KP]}],ParametricPlot3D[curveR,{t,aa,aa+hh},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[pol7,{t,0,1},PlotStyle->GrayLevel[0.4],PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

(* Let us draw the frame *)
FFi=FFrame;
ff1=FFi[[1]];
ff2=FFi[[2]];
ff3=FFi[[3]];
vel=hh;
kor=0.02;
g1=DrawGeneralFrame[ff1,ff2,ff3,curveR,t,aa,aa+hh,kor,vel,{0,0,0},{0,0,0},{0,0,0}];
FFi=ERFrame;
ff1=FFi[[1]];
ff2=FFi[[2]];
ff3=FFi[[3]];
par=EqualParameters[KAPol,t,50];
g2=DrawGeneralFrame1[ff1,ff2,ff3,pol7,t,par,vel,{0.7,0,0},{0,0.7,0},{0,0,0.7},0.018,0.002];

Show[{g2,ParametricPlot3D[curveR,{t,aa,aa+hh},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[pol7,{t,0,1},PlotStyle->GrayLevel[0.4]]},ViewPoint->VP,Boxed->False]

Print["ω(t): "]
Plot[Abs[funW],{t,0,1},PlotRange->All]
Print["(Subscript[E, ω]) = ",maxFunW]

Print["Compute the reparameterization function and reparameterize the given curve:"]
rep=Simplify[InterpolatingPolynomial[{{0,{aa,(Subscript[λ, 0])^2,6(Subscript[λ, 0])((Subscript[μ, 0])-(Subscript[λ, 0]))}},{1,{aa+hh,(Subscript[λ, 1])^2 ,6(Subscript[λ, 1])(-(Subscript[μ, 1])+(Subscript[λ, 1]))}}}/.sol1,t]]
curveRR=Simplify[curveR/.{t->rep}];
Print["Check if the G^2 conditions are satisfied: "]
Chop[{{curveRR-pol7/.{t->0},curveRR-pol7/.{t->1}},
{D[curveRR-pol7,t]/.{t->0},D[curveRR-pol7,t]/.{t->1}},
{D[curveRR-pol7,{t,2}]/.{t->0},D[curveRR-pol7,{t,2}]/.{t->1}}},10^(-NAT+10)]

Print["Compute the error. Error function: "]
errFun=Norma[curveRR-pol7];
Plot[errFun,{t,0,1}]
Print["Max error:"]
MyFindMax1[errFun,t,0,1,20]

Print["Check: "]
(ERFrame/.{t->0})-(AFrame/.{t->aa,θ->0})
(ERFrame/.{t->1})-(AFrame/.{t->aa+hh,θ->th})
Norma[D[curveR,t]/.{t->aa}]/Norma[D[curveR,t]/.{t->aa+hh}]-Norma[D[pol7,t]/.{t->0}]/Norma[D[pol7,t]/.{t->1}]

(* --- table of errors as h decreases *)

tabH=Table[2^(-k),{k,1,10}]
tabSol={};
tabPol={};
tabKP={};
tabErr={};
TABW={};
izbKsi=1;
For[kk=1,kk≤Length[tabH],kk++,
hh=tabH[[kk]];
a=0;
b=a+hh;
th=Quiet[NIntegrate[-sig tor,{t,a,b},WorkingPrecision->NAT]];
P0a=curveR/.{t->a};
P1a=curveR/.{t->b};
U0a=curveQ/.{t->a,θ->0};
V0a=DcurveQ/.{t->a,θ->0};
U1a=curveQ/.{t->b,θ->th};
V1a=DcurveQ/.{t->b,θ->th};
If[Sign[U0a.U1a]<0,U1a=-U1a;V1a=-V1a];
Print["********** h = ", hh, " **********"];
Print["Interval (a,b) = ",{a,b}];
Print["theta = ",th];
Print["Chosen data: "];
Rot=Inverse[Rotacija[U0a][[3]]];
InvRot=Rotacija[U0a][[3]];
(* ----------- *)
P0=Rot.P0a;
P1=Rot.P1a;
U0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U0a];
U1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U1a];
V0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V0a];
V1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V1a];
(* -------------------- *)
Print["Equations: "];
{tabGamF,tabKoefF,tabz,enac2}=ComputeEqForG2PHInt7[U0,U1,V0,V1,P0,P1,x,y,z,ξ];
Print["Admissible solutions x,y,z: "];
sol=Quiet[{x,y,z}/.NSolve[(#==0)&/@(enac2/.ξ->izbKsi),{x,y,z},WorkingPrecision->NAT]];
sol=Sort[Select[sol,((Element[#[[1]],Reals]&&(#[[1]]>0))&&(Element[#[[2]],Reals])&&(Element[#[[3]],Reals]))&]];
Print["Number of solutions: ", Length[sol]];
tabSol=Append[tabSol,sol];
tabpol={};
tabe={};
tabKPa={};
tabEW={};
For[jj=1,jj≤Length[sol],jj++,
Print["---------------------"];
solX=sol[[jj]];
sol1={(Subscript[λ, 0])->(Sqrt[solX[[1]]]),(Subscript[λ, 1])->izbKsi(Sqrt[solX[[1]]]),(Subscript[μ, 0])->solX[[2]]/(Sqrt[solX[[1]]]),(Subscript[μ, 1])->solX[[3]]/(Sqrt[solX[[1]]])};
KA=SolForG2PHInt[U0,U1,V0,V1,solX[[1]],solX[[2]],solX[[3]],izbKsi];
KA=Table[KvaternionProd[U0a/Norma[U0a],KA[[i]]],{i,1,Length[KA]}];
Print["Compute PH interpolants: "];
{pol7,KP,loc}=PHCurveOfDegree7[KA,Inverse[Rot].P0,t];
(*--------*)
KAPol=Plus@@Table[KA[[i+1]]bernstein[t,3,i],{i,0,3}];
ERFrame=1/Norma[KAPol]^2{Rest[OPStar[KAPol,KAPol]],Rest[OPStar2[KAPol,KAPol]],Rest[OPStar3[KAPol,KAPol]]};
funW=D[ERFrame[[2]],t].ERFrame[[3]];
maxFunW1=Max[Table[Abs[funW]/.{t->i},{i,0,1,1/1000}]];
maxFunW=FindMaximum[Abs[funW],{t,0,1},PrecisionGoal->20,WorkingPrecision->20][[1]];
Print["E_w = ",Max[{maxFunW1,maxFunW}]];
tabEW=Append[tabEW,Max[{maxFunW,maxFunW1}]];
(* --------------- *)
tabpol=Append[tabpol,pol7];
tabKPa=Append[tabKPa,KP];
Print["Compute the reparameterization function and reparameterize the given curve:"];
rep=Simplify[InterpolatingPolynomial[{{0,{a,(Subscript[λ, 0])^2,6(Subscript[λ, 0])((Subscript[μ, 0])-(Subscript[λ, 0]))}},{1,{b,(Subscript[λ, 1])^2 ,6(Subscript[λ, 1])(-(Subscript[μ, 1])+(Subscript[λ, 1]))}}}/.sol1,t]];
curveRR=Simplify[curveR/.{t->rep}];
Print["Check if the G^2 conditions are satisfied: "];
Print[Norm[Flatten[Chop[{{curveRR-pol7/.{t->0},curveRR-pol7/.{t->1}},
{D[curveRR-pol7,t]/.{t->0},D[curveRR-pol7,t]/.{t->1}},
{D[curveRR-pol7,{t,2}]/.{t->0},D[curveRR-pol7,{t,2}]/.{t->1}}},10^(-NAT+10)]]]<10^(-NAT+30)];
(* Compute the error. *);
errFun=Norma[curveRR-pol7];
err=MyFindMax1[errFun,t,0,1,NAT-10];
tabe=Append[tabe,err[[1]]];
Print["error = ",N[err[[1]],20]];
];
Print["***********************"];
tabPol=Append[tabPol,tabpol];
tabKP=Append[tabKP,tabKPa];
tabErr=Append[tabErr,tabe];
TABW=Append[TABW,tabEW];
]

Print["For h=1/2 we get one solution, for h=1/4 and h=1/8 we get five solutions, while for other values of h we get four admissible solutions: "]
Length[#]&/@tabSol
OD=2;

Print["The solution (x,y,z)/h for h=1/2: "]
N[tabSol[[1]]/tabH[[1]],8]//MatrixForm

Print["Values x/h of the first 4 solutions for h=2^(-k), k=2,3,...,10: "]
N[Transpose[Table[Table[tabSol[[i,j,1]]/(tabH[[i]]),{i,OD,Length[tabH]}],{j,1,4}]],8]//MatrixForm

Print["Approximation order for the first solution:"]
kat=1;
OD=1;
(*Transpose[Join[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],{Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]},{N[Last[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[TABW[[i,kat]],16],{i,OD,Length[TABW]}]]]],4]}]]//MatrixForm*)
Transpose[Append[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]]]//MatrixForm
Print["solution {x,y,z}/h="]
N[Table[tabSol[[i,kat]]/tabH[[i]],{i,OD,Length[tabH]}],16]//MatrixForm

Print["Approximation order for the second solution:"]
kat=2;
OD=2;
(*Transpose[Join[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],{Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]},{N[Last[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[TABW[[i,kat]],16],{i,OD,Length[TABW]}]]]],4]}]]//MatrixForm*)
Transpose[Append[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]]]//MatrixForm
Print["solution {x,y,z}/h="]
N[Table[tabSol[[i,kat]]/tabH[[i]],{i,OD,Length[tabH]}],16]//MatrixForm

Print["Approximation order for the third solution:"]
kat=3;
OD=2;
(*Transpose[Join[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],{Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]},{N[Last[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[TABW[[i,kat]],16],{i,OD,Length[TABW]}]]]],4]}]]//MatrixForm*)
Transpose[Append[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]]]//MatrixForm
Print["solution {x,y,z}/h="]
N[Table[tabSol[[i,kat]]/tabH[[i]],{i,OD,Length[tabH]}],16]//MatrixForm

Print["Approximation order for the fourth solution:"]
kat=4;
OD=2;
(*Transpose[Join[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],{Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]},{N[Last[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[TABW[[i,kat]],16],{i,OD,Length[TABW]}]]]],4]}]]//MatrixForm*)
Transpose[Append[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]]]//MatrixForm
Print["solution {x,y,z}/h="]
N[Table[tabSol[[i,kat]]/tabH[[i]],{i,OD,Length[tabH]}],16]//MatrixForm

(* -------------------- *)

Print["We plot solutions x/h for k ∈ {1,2,...,10}"]
pom1=Table[{i,tabSol[[i,1,1]]/tabH[[i]]},{i,1,Length[tabSol]}];
pom2=Table[{i,tabSol[[i,2,1]]/tabH[[i]]},{i,OD,Length[tabSol]}];
pom3=Table[{i,tabSol[[i,3,1]]/tabH[[i]]},{i,OD,Length[tabSol]}];
pom4=Table[{i,tabSol[[i,4,1]]/tabH[[i]]},{i,OD,Length[tabSol]}];

Graphics[{PointSize[0.02],RGBColor[0.8,0,0],Point[pom1],Line[pom1],RGBColor[0,0.8,0],Point[pom2],Line[pom2],RGBColor[0,0,0.8],Point[pom3],Line[pom3],Orange,Point[pom4],Line[pom4]},AspectRatio->1,Axes->True,AxesOrigin->{0,0}]

OD=1;pom1=Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[tabErr[[i,1]],{i,OD,Length[tabErr]}]]];
OD=2;
pom2=Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[tabErr[[i,2]],{i,OD,Length[tabErr]}]]];
pom3=Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[tabErr[[i,3]],{i,OD,Length[tabErr]}]]];
pom4=Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[tabErr[[i,4]],{i,OD,Length[tabErr]}]]];

Print["Graph of (Subscript[Log, 2])[err] in dependence of k for all four solutions: "];Show[{Graphics[{PointSize[0.025],RGBColor[0.8,0,0],Point[Transpose[{Table[k,{k,1,Length[tabH]}],Log[Rest[pom1[[2]]]]/Log[2]}]],Line[Transpose[{Table[k,{k,1,Length[tabH]}],Log[Rest[pom1[[2]]]]/Log[2]}]],PointSize[0.03],Orange,Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom2[[2]]]]/Log[2]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom2[[2]]]]/Log[2]}]],PointSize[0.02],RGBColor[0,0.8,0],Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom3[[2]]]]/Log[2]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom3[[2]]]]/Log[2]}]],PointSize[0.025],RGBColor[0,0,0.8],Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom4[[2]]]]/Log[2]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom4[[2]]]]/Log[2]}]]},AspectRatio->1,Axes->True,AxesOrigin->{0.5,0},BaseStyle->15,Ticks->{Table[i,{i,1,10}],All},Frame->{{True,False},{True,False}},FrameLabel->{"k","(Subscript[Log, 2])[err]"}]},Ticks->{Table[i,{i,1,10}],All}]

ClearAll[h]
nap1=0.05 h^6; 
line1={Line[{{4,Log[nap1/.{h->2^(-4)}]/Log[10]},{7,Log[nap1/.{h->2^(-7)}]/Log[10]}}]};
nap2= 0.3h^2; 
line2={Line[{{4,Log[nap2/.{h->2^(-4)}]/Log[10]},{7,Log[nap2/.{h->2^(-7)}]/Log[10]}}]};
nap3=15h^1; 
line3={Line[{{4,Log[nap3/.{h->2^(-4)}]/Log[10]},{7,Log[nap3/.{h->2^(-7)}]/Log[10]}}]};

Print["Graph of (Subscript[Log, 10])[err] in dependence of k for all four solutions: "];Show[{Graphics[{line1,line2,line3,PointSize[0.025],RGBColor[0.8,0,0],Point[Transpose[{Table[k,{k,1,Length[tabH]}],Log[Rest[pom1[[2]]]]/Log[10]}]],Line[Transpose[{Table[k,{k,1,Length[tabH]}],Log[Rest[pom1[[2]]]]/Log[10]}]],PointSize[0.03],Orange,Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom2[[2]]]]/Log[10]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom2[[2]]]]/Log[10]}]],PointSize[0.02],RGBColor[0,0.8,0],Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom3[[2]]]]/Log[10]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom3[[2]]]]/Log[10]}]],PointSize[0.025],RGBColor[0,0,0.8],Point[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom4[[2]]]]/Log[10]}]],Line[Transpose[{Table[k,{k,OD,Length[tabH]}],Log[Rest[pom4[[2]]]]/Log[10]}]],RGBColor[0,0,0],Text["(h^6)",{6,-11}],Text["(h^2)",{6,-5}],Text["h",{6,-0.1}]},AspectRatio->1,Axes->True,AxesOrigin->{0.5,0},BaseStyle->22,Ticks->{Table[i,{i,1,10}],All},Frame->{{True,False},{True,False}},FrameLabel->{"k","(Subscript[Log, 10])[err]"}]},Ticks->{Table[i,{i,1,10}],All}]

(* ----------------------------- *)

Print["Choose 'k': "]
kat=2
Print["We plot all the solutions: "]
VP={-2,3,3};;
Show[{Graphics3D[{GrayLevel[0],PointSize[0.02],Point[tabKP[[kat,1]]],Line[tabKP[[kat,1]]]}],ParametricPlot3D[curveR,{t,aa,aa+tabH[[kat]]},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[tabPol[[kat,1]],{t,0,1},PlotStyle->{GrayLevel[0.4]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

Show[{Graphics3D[{GrayLevel[0],PointSize[0.02],Point[tabKP[[kat,2]]],Line[tabKP[[kat,2]]]}],ParametricPlot3D[curveR,{t,aa,aa+tabH[[kat]]},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[tabPol[[kat,2]],{t,0,1},PlotStyle->{GrayLevel[0.4]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

Show[{Graphics3D[{GrayLevel[0],PointSize[0.02],Point[tabKP[[kat,3]]],Line[tabKP[[kat,3]]]}],ParametricPlot3D[curveR,{t,aa,aa+tabH[[kat]]},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[tabPol[[kat,3]],{t,0,1},PlotStyle->{GrayLevel[0.4]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

Show[{Graphics3D[{GrayLevel[0],PointSize[0.02],Point[tabKP[[kat,4]]],Line[tabKP[[kat,4]]]}],ParametricPlot3D[curveR,{t,aa,aa+tabH[[kat]]},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[tabPol[[kat,4]],{t,0,1},PlotStyle->{GrayLevel[0.4]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

Show[{Graphics3D[{GrayLevel[0],PointSize[0.02],Point[tabKP[[kat,5]]],Line[tabKP[[kat,5]]]}],ParametricPlot3D[curveR,{t,aa,aa+tabH[[kat]]},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[tabPol[[kat,5]],{t,0,1},PlotStyle->{GrayLevel[0.4]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

VP={-2,3,3};
Show[{
ParametricPlot3D[tabPol[[kat,2]],{t,0,1},PlotStyle->{GrayLevel[0.25]},PlotRange->All],ParametricPlot3D[tabPol[[kat,3]],{t,0,1},PlotStyle->{GrayLevel[0.45]},PlotRange->All],ParametricPlot3D[tabPol[[kat,4]],{t,0,1},PlotStyle->{GrayLevel[0.55]},PlotRange->All],ParametricPlot3D[tabPol[[kat,5]],{t,0,1},PlotStyle->{GrayLevel[0.75]},PlotRange->All],ParametricPlot3D[tabPol[[kat,1]],{t,0,1},PlotStyle->{GrayLevel[0]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False,Axes->False]

Example 3a - data sampled from Frenet frame

Print["Chosen curve: "]
NAT=60;
curveR=N[{t-Sin[Pi t],t+Cos[Pi t],5 Sqrt[t^2+1]},NAT];
aa=0;
bb=1;
ParametricPlot3D[curveR,{t,aa,bb}]

Print["Torsion, curvature and parametric speed: "]
tor=Torsion[curveR,t];
curv=Ukriv[curveR,t];
sig=Norma[D[curveR,t]];
Plot[{tor,curv,sig},{t,aa,bb},AxesOrigin->{0,0}]
Print["Condition ψ(r,t) (from the paper): "]
cond=AsymptoticCond[curveR,t];
Plot[cond,{t,aa,bb},PlotRange->All]

Print["Condition ψ(r,0)= ",cond/.{t->0}]

Print["Frenet Frame:"]
FFrame=Frene[curveR,t];
MR=Transpose[FFrame];
curveQ1={1+MR[[1,1]]+MR[[2,2]]+MR[[3,3]],MR[[3,2]]-MR[[2,3]],MR[[1,3]]-MR[[3,1]],MR[[2,1]]-MR[[1,2]]};
curveQ=Sqrt[Norma[D[curveR,t]]] (curveQ1/Norma[curveQ1]);

Show[DrawGeneralFrame[FFrame[[1]],FFrame[[2]],FFrame[[3]],curveR,t,aa,bb,0.02,0.5,{0.7,0,0},{0,0.7,0},{0,0,0.7}]]

Print["Rotational axis: "]
WF=RotationAxis[FFrame[[1]],FFrame[[2]],FFrame[[3]],t];

ClearAll[h]
Print["Interval [0,h]"]
hh=2^(-5);
Print["Chosen data: "]
P0a=curveR/.{t->aa};
P1a=curveR/.{t->aa+hh};
U0a=curveQ/.{t->aa};
U1a=curveQ/.{t->aa+hh};
V0a=D[curveQ,t]/.{t->aa};
V1a=D[curveQ,t]/.{t->aa+hh};
If[Sign[U0a.U1a]<0,U1a=-U1a;V1a=-V1a];

Print["We need to rotate the data. "]
Print["Rotation matrix: "]
Rot=Inverse[Transpose[FFrame/.{t->aa}]];
(*Inverse[Rotacija[curveQ/.{t->aa}][[3]]]-Rot*)
Print["Rotated data: "]
P0=Rot.P0a;
P1=Rot.P1a;
U0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U0a];
U1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U1a];
V0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V0a];
V1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V1a];

Print["Equations: "]
{tabGamF,tabKoefF,tabz,enac2}=ComputeEqForG2PHInt7[U0,U1,V0,V1,P0,P1,x,y,z,ξ];
Print["Chosen ξ: "]
izbKsi=1

Print["Admissible solutions: "]
sol=Quiet[{x,y,z}/.NSolve[(#==0)&/@(enac2/.ξ->izbKsi),{x,y,z},WorkingPrecision->NAT]];
sol=Sort[Select[sol,((Element[#[[1]],Reals]&&(#[[1]]>0))&&(Element[#[[2]],Reals])&&(Element[#[[3]],Reals]))&]]
Print["Number of admissible solutions: "]
Length[sol]

Print["Compare the solutions with asymptotic results: "]
N[sol/hh,20]//MatrixForm

Print["Choose a solution: "]
whichSol=2
solX=sol[[whichSol]];
sol1={(Subscript[λ, 0])->(Sqrt[solX[[1]]]),(Subscript[λ, 1])->izbKsi(Sqrt[solX[[1]]]),(Subscript[μ, 0])->solX[[2]]/(Sqrt[solX[[1]]]),(Subscript[μ, 1])->solX[[3]]/(Sqrt[solX[[1]]])}
Print["Compute quaternion coefficients: "]
KA=SolForG2PHInt[U0,U1,V0,V1,solX[[1]],solX[[2]],solX[[3]],izbKsi];
KA=Table[KvaternionProd[U0a/Norma[U0a],KA[[i]]],{i,1,Length[KA]}];
KAPol=Plus@@Table[KA[[i+1]]bernstein[t,3,i],{i,0,3}];
ERFrame=1/Norma[KAPol]^2{Rest[OPStar[KAPol,KAPol]],Rest[OPStar2[KAPol,KAPol]],Rest[OPStar3[KAPol,KAPol]]};
funW=D[ERFrame[[2]],t].ERFrame[[3]];
maxFunW=Max[Table[Abs[funW]/.{t->i},{i,0,1,1/1000}]];
WER=RotationAxis[ERFrame[[1]],ERFrame[[2]],ERFrame[[3]],t];
Print["Compute PH interpolant: "]
{pol7,KP,loc}=PHCurveOfDegree7[KA,Inverse[Rot].P0,t];
Print["Length of a control polygon: "]
Plus@@Table[Norma[KP[[i+1]]-KP[[i]]],{i,1,Length[KP]-1}]
VP={1,1,1};
Show[{Graphics3D[{GrayLevel[0.4],PointSize[0.02],Point[KP],Dashed,Line[KP]}],ParametricPlot3D[curveR,{t,aa,aa+hh},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[pol7,{t,0,1},PlotStyle->GrayLevel[0.4],PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

(* Let us draw the frame *)
FFi=FFrame;
ff1=FFi[[1]];
ff2=FFi[[2]];
ff3=FFi[[3]];
vel=hh;
kor=0.02;
g1=DrawGeneralFrame[ff1,ff2,ff3,curveR,t,aa,aa+hh,kor,vel,{0,0,0},{0,0,0},{0,0,0}];
FFi=ERFrame;
ff1=FFi[[1]];
ff2=FFi[[2]];
ff3=FFi[[3]];
par=EqualParameters[KAPol,t,50];
g2=DrawGeneralFrame1[ff1,ff2,ff3,pol7,t,par,vel,{0.7,0,0},{0,0.7,0},{0,0,0.7},0.018,0.002];

Show[{g2,ParametricPlot3D[curveR,{t,aa,aa+hh},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[pol7,{t,0,1},PlotStyle->GrayLevel[0.4]]},ViewPoint->VP,Boxed->False]

Print["ω(t): "]
Plot[Abs[funW],{t,0,1},PlotRange->All]
Print["(Subscript[E, ω]) = ",maxFunW]

Print["Compute the reparameterization function and reparameterize the given curve:"]
rep=Simplify[InterpolatingPolynomial[{{0,{aa,(Subscript[λ, 0])^2,6(Subscript[λ, 0])((Subscript[μ, 0])-(Subscript[λ, 0]))}},{1,{aa+hh,(Subscript[λ, 1])^2 ,6(Subscript[λ, 1])(-(Subscript[μ, 1])+(Subscript[λ, 1]))}}}/.sol1,t]]
curveRR=Simplify[curveR/.{t->rep}];
Print["Check if the G^2 conditions are satisfied: "]
Chop[{{curveRR-pol7/.{t->0},curveRR-pol7/.{t->1}},
{D[curveRR-pol7,t]/.{t->0},D[curveRR-pol7,t]/.{t->1}},
{D[curveRR-pol7,{t,2}]/.{t->0},D[curveRR-pol7,{t,2}]/.{t->1}}},10^(-NAT+10)]

Print["Compute the error. Error function: "]
errFun=Norma[curveRR-pol7];
Plot[errFun,{t,0,1}]
Print["Max error:"]
MyFindMax1[errFun,t,0,1,20]

(* --- table of errors as h decreases *)

tabH={1,1/2,1/4,1/8,1/16,1/32};
tabH=Table[2^(-k),{k,1,10}]
(*tabH={1,1/2,1/4,1/6,1/8,1/10,1/12,1/14,1/16};*)
tabSol={};
tabPol={};
tabKP={};
tabErr={};
TABW={};
izbKsi=1;
For[kk=1,kk≤Length[tabH],kk++,
hh=tabH[[kk]];
a=0;
b=a+hh;
Print["********** h = ", hh, " **********"];
Print["Interval (a,b) = ",{a,b}];
Print["Chosen data: "];
P0a=curveR/.{t->a};
P1a=curveR/.{t->b};
U0a=curveQ/.{t->a};
U1a=curveQ/.{t->b};
V0a=D[curveQ,t]/.{t->a};
V1a=D[curveQ,t]/.{t->b};
If[Sign[U0a.U1a]<0,U1a=-U1a;V1a=-V1a];
Rot=Inverse[Rotacija[U0a][[3]]];
InvRot=Rotacija[U0a][[3]];
(* ----------- *)
P0=Rot.P0a;
P1=Rot.P1a;
U0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U0a];
U1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U1a];
V0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V0a];
V1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V1a];
(* -------------------- *)
Print["Equations: "];
{tabGamF,tabKoefF,tabz,enac2}=ComputeEqForG2PHInt7[U0,U1,V0,V1,P0,P1,x,y,z,izbKsi];
Print["Admissible solutions x,y,z: "];
sol={x,y,z}/.Quiet[Solve[(#==0)&/@enac2,{x,y,z}]];
sol=Sort[Select[sol,((Element[#[[1]],Reals]&&(#[[1]]≠0))&&(Element[#[[2]],Reals])&&(Element[#[[3]],Reals]))&]];
Print["Number of solutions: ", Length[sol]];
tabSol=Append[tabSol,sol];
tabpol={};
tabe={};
tabKPa={};
tabEW={};
For[jj=1,jj≤Length[sol],jj++,
Print["---------------------"];
solX=sol[[jj]];
sol1={(Subscript[λ, 0])->(Sqrt[solX[[1]]]),(Subscript[λ, 1])->izbKsi(Sqrt[solX[[1]]]),(Subscript[μ, 0])->solX[[2]]/(Sqrt[solX[[1]]]),(Subscript[μ, 1])->solX[[3]]/(Sqrt[solX[[1]]])};
KA=SolForG2PHInt[U0,U1,V0,V1,solX[[1]],solX[[2]],solX[[3]],izbKsi];
KA=Table[KvaternionProd[U0a/Norma[U0a],KA[[i]]],{i,1,Length[KA]}];
Print["Compute PH interpolants: "];
{pol7,KP,loc}=PHCurveOfDegree7[KA,Inverse[Rot].P0,t];
(*--------*)
KAPol=Plus@@Table[KA[[i+1]]bernstein[t,3,i],{i,0,3}];
ERFrame=1/Norma[KAPol]^2{Rest[OPStar[KAPol,KAPol]],Rest[OPStar2[KAPol,KAPol]],Rest[OPStar3[KAPol,KAPol]]};
funW=D[ERFrame[[2]],t].ERFrame[[3]];
maxFunW1=Max[Table[Abs[funW]/.{t->i},{i,0,1,1/1000}]];
maxFunW=FindMaximum[Abs[funW],{t,0,1},PrecisionGoal->20,WorkingPrecision->20][[1]];
Print["E_w = ",Max[{maxFunW1,maxFunW}]];
tabEW=Append[tabEW,Max[{maxFunW,maxFunW1}]];
(* --------------- *)
tabpol=Append[tabpol,pol7];
tabKPa=Append[tabKPa,KP];
(*Compute the reparameterization function and reparameterize the given curve:*)
rep=Chop[Simplify[InterpolatingPolynomial[{{0,{0,(Subscript[λ, 0])^2,6(Subscript[λ, 0])((Subscript[μ, 0])-(Subscript[λ, 0]))}},{1,{hh,(Subscript[λ, 1])^2 ,6(Subscript[λ, 1])(-(Subscript[μ, 1])+(Subscript[λ, 1]))}}}/.sol1,t]],10^(-NAT)];
curveRR=Simplify[curveR/.{t->rep}];
Print["Check if the G^2 conditions are satisfied: ",
Norm[Flatten[{{curveRR-pol7/.{t->0},curveRR-pol7/.{t->1}},
{D[curveRR-pol7,t]/.{t->0},D[curveRR-pol7,t]/.{t->1}},
{D[curveRR-pol7,{t,2}]/.{t->0},D[curveRR-pol7,{t,2}]/.{t->1}}}]]<10^(-NAT+10)];
(* Compute the error. *);
errFun=Chop[Norma[curveRR-pol7],10^(-NAT+10)];
err=MyFindMax1[errFun,t,0,1,NAT-10];
tabe=Append[tabe,err[[1]]];
Print["error = ",N[err[[1]],20]];
];
Print["***********************"];
tabPol=Append[tabPol,tabpol];
tabKP=Append[tabKP,tabKPa];
tabErr=Append[tabErr,tabe];
TABW=Append[TABW,tabEW];
]

Print["We reverse the tables: "]
tabSol1=Reverse[#]&/@tabSol;
tabErr1=Reverse[#]&/@tabErr;
TABW1=Reverse[#]&/@TABW;

Print["Number of solutions for k=1,2,...,10:"]
Length[#]&/@tabSol1

Print["Table of erors for the first solution ordered by solution x)"]
RedAproksimacije[tabH,N[#[[2]]&/@tabErr1,16]]//MatrixForm
Print["solution {x,y,z}/h="]
N[Table[tabSol1[[i,2]]/tabH[[i]],{i,1,Length[tabH]}],16]//MatrixForm

Print["Table of errors for the second solution (ordered by solution x)"]
RedAproksimacije[tabH,N[#[[1]]&/@tabErr1,16]]//MatrixForm
Print["solution {x,y,z}/h="]
N[Table[tabSol1[[i,1]]/tabH[[i]],{i,1,Length[tabH]}],16]//MatrixForm

(* -------------------- *)

pom1=Table[{kat,tabSol1[[kat,1,1]]/tabH[[kat]]},{kat,1,Length[tabSol1]}];
pom2=Table[{kat,tabSol1[[kat,2,1]]/tabH[[kat]]},{kat,1,Length[tabSol1]}];

Print["We plot solutions x for k ∈ {1,2,...,10}"]
Graphics[{PointSize[0.02],RGBColor[0.8,0,0],Point[pom1],Line[pom1],RGBColor[0,0.8,0],Point[pom2],Line[pom2]},AspectRatio->1,Axes->True,AxesOrigin->{0,0}]

pom1=Transpose[RedAproksimacije[tabH,#[[2]]&/@tabErr1]];
pom2=Transpose[RedAproksimacije[tabH,#[[1]]&/@tabErr1]];
Print["Table of errors, decay exponent and (Subscript[E, ω]) for the first and the second solution: "];Transpose[Join[{pom1[[1]],N[pom1[[2]],6],N[pom1[[3]],4],Prepend[N[#[[2]]&/@TABW1,4],"(Subscript[E, ω])"],N[pom2[[2]],6],N[pom2[[3]],4],Prepend[N[#[[1]]&/@TABW1,4],"(Subscript[E, ω])"]}]]//MatrixForm

tabGL=GrayLevel[#]&/@{0,0.4,0.6,0.2,0.7}

tabGL=RGBColor[#]&/@{{0.9,0,0},{0,0,0.9},{1,1/2,0},{0,0.9,0},{1/2,1/2,1/2}}

nap2= 0.1h^2; 
line2={Line[{{4,Log[nap2/.{h->2^(-4)}]/Log[10]},{7,Log[nap2/.{h->2^(-7)}]/Log[10]}}]};

Print["Graph of (Subscript[Log, 10])[err] in dependence of k for all solutions: "];
Graphics[{line2,PointSize[0.025],tabGL[[1]],Point[{3,Log[tabErr1[[3,3]]]/Log[10]}],tabGL[[2]],Point[{3,Log[tabErr1[[3,4]]]/Log[10]}],tabGL[[3]],Point[Transpose[{Table[k,{k,1,10}],Log[Rest[pom1[[2]]]]/Log[10]}]],Line[Transpose[{Table[k,{k,1,10}],Log[Rest[pom1[[2]]]]/Log[10]}]],tabGL[[4]],Point[Transpose[{Table[k,{k,1,10}],Log[Rest[pom2[[2]]]]/Log[10]}]],Line[Transpose[{Table[k,{k,1,10}],Log[Rest[pom2[[2]]]]/Log[10]}]],RGBColor[0,0,0],Text["(h^2)",{5,-5}]},AspectRatio->1,Axes->True,AxesOrigin->{0.5,0},BaseStyle->22,Frame->{{True,False},{True,False}},FrameLabel->{"k","(Subscript[Log, 10])[(Subscript[E, err])]"},PlotRange->{All,{-16,0}},Ticks->{Table[i,{i,1,10}],All}]

Print["Choose 'k': "]
kat=4
Print["We plot all the solutions: "]
VP={1,1,1};
Show[{Graphics3D[{GrayLevel[0],PointSize[0.02],Point[tabKP[[kat,1]]],Line[tabKP[[kat,1]]],GrayLevel[0.5],Point[tabKP[[kat,2]]],Dashed,Line[tabKP[[kat,2]]]}],ParametricPlot3D[curveR,{t,aa,aa+tabH[[kat]]},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[tabPol[[kat,1]],{t,0,1},PlotStyle->{Dashed,GrayLevel[0]},PlotRange->All],ParametricPlot3D[tabPol[[kat,2]],{t,0,1},PlotStyle->{Dashed,GrayLevel[0.5]},PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

Example 3b - data sampled from adapted frame

Print["Chosen curve: "]
NAT=60;
curveR=N[{t-Sin[Pi t],t+Cos[Pi t],5 Sqrt[t^2+1]},NAT];
aa=0;
bb=1;
ParametricPlot3D[curveR,{t,aa,bb}]

Print["Torsion, curvature and parametric speed: "]
tor=Torsion[curveR,t];
curv=Ukriv[curveR,t];
sig=Norma[D[curveR,t]];
Plot[{tor,curv,sig},{t,0,10},AxesOrigin->{0,0}]
Print["Condition ψ(r,t) (from the paper): "]
cond=AsymptoticCond[curveR,t];
Plot[cond,{t,0,10},PlotRange->All]

Print["Condition ψ(r,0)= ",cond/.{t->0}]

Print["Frenet Frame:"]
FFrame=Frene[curveR,t];
MR=Transpose[FFrame];
DMR=Transpose[D[FFrame,t]];
curveFQ1={1+MR[[1,1]]+MR[[2,2]]+MR[[3,3]],MR[[3,2]]-MR[[2,3]],MR[[1,3]]-MR[[3,1]],MR[[2,1]]-MR[[1,2]]};
DcurveFQ1={DMR[[1,1]]+DMR[[2,2]]+DMR[[3,3]],DMR[[3,2]]-DMR[[2,3]],DMR[[1,3]]-DMR[[3,1]],DMR[[2,1]]-DMR[[1,2]]};
curveQF=Sqrt[Norma[D[curveR,t]]] (curveFQ1/Norma[curveFQ1]);

Print["Computation of the derivative of Q in a different way:"]
tmp1=D[Sqrt[Norma[D[curveR,t]]],t] (curveFQ1/Norma[curveFQ1]);
tmp2=Sqrt[Norma[D[curveR,t]]] (1/Norma[curveFQ1] DcurveFQ1-(curveFQ1.DcurveFQ1)1/Norma[curveFQ1]^3 curveFQ1);
DcurveQF=tmp1+tmp2;

Print["Graph of Frenet frame:"]
graf1=Show[DrawGeneralFrame[FFrame[[1]],FFrame[[2]],FFrame[[3]],curveR,t,aa,bb,0.02,0.8,{0.7,0,0},{0,0.7,0},{0,0,0.7}]]

Print["Rotational axis: "]
WF=RotationAxis[FFrame[[1]],FFrame[[2]],FFrame[[3]],t];

(* ----------- *)

Print["Rotation minimizing frame:"]
RMFrame={FFrame[[1]],Cos[θ]FFrame[[2]]+Sin[θ]FFrame[[3]],-Sin[θ]FFrame[[2]]+Cos[θ]FFrame[[3]]};
DRMFrame={D[FFrame[[1]],t],-tor sig RMFrame[[3]]+Cos[θ]D[FFrame[[2]],t]+Sin[θ]D[FFrame[[3]],t],tor sig RMFrame[[2]]-Sin[θ]D[FFrame[[2]],t]+Cos[θ]D[FFrame[[3]],t]};

MR=Transpose[RMFrame];
DMR=Transpose[DRMFrame];
curveQ1={1+MR[[1,1]]+MR[[2,2]]+MR[[3,3]],MR[[3,2]]-MR[[2,3]],MR[[1,3]]-MR[[3,1]],MR[[2,1]]-MR[[1,2]]};
DcurveQ1={DMR[[1,1]]+DMR[[2,2]]+DMR[[3,3]],DMR[[3,2]]-DMR[[2,3]],DMR[[1,3]]-DMR[[3,1]],DMR[[2,1]]-DMR[[1,2]]};
curveQRM=Sqrt[Norma[D[curveR,t]]] (curveQ1/Norma[curveQ1]);

tmp1=D[Sqrt[Norma[D[curveR,t]]],t] (curveQ1/Norma[curveQ1]);
tmp2=Sqrt[Norma[D[curveR,t]]] (1/Norma[curveQ1] DcurveQ1-(curveQ1.DcurveQ1)1/Norma[curveQ1]^3 curveQ1);
DcurveQRM=tmp1+tmp2;

tabp=Table[i,{i,aa,bb,2/100}];
tabTh=Table[NIntegrate[-sig tor,{t,0,tabp[[i]]},WorkingPrecision->NAT-10],{i,1,Length[tabp]}];

tabRMFrame=Table[RMFrame/.{θ->tabTh[[i]],t->tabp[[i]]},{i,1,Length[tabTh]}];
tabCurve=Table[curveR/.{t->tabp[[kat]]},{kat,1,Length[tabp]}];

Print["Graph of rotation minimizing frame:"]
graf2=DrawGeneralFrameTab[tabRMFrame,tabCurve,0.8,{1,0,0},{0,1,0},{0,0,1}]

Print["(Subscript[σ, 0])(Subscript[τ, 0]) = ",-tor sig/.{t->0}]

Print["Adapted frame:"]
ClearAll[θ,CC]
theta=CC t;
AFrame={FFrame[[1]],Cos[θ]FFrame[[2]]+Sin[θ]FFrame[[3]],-Sin[θ]FFrame[[2]]+Cos[θ]FFrame[[3]]}/.{θ->theta};
DAFrame=D[AFrame,t];

MR=Transpose[AFrame];
DMR=Transpose[DAFrame];
curveQ1={1+MR[[1,1]]+MR[[2,2]]+MR[[3,3]],MR[[3,2]]-MR[[2,3]],MR[[1,3]]-MR[[3,1]],MR[[2,1]]-MR[[1,2]]};
DcurveQ1={DMR[[1,1]]+DMR[[2,2]]+DMR[[3,3]],DMR[[3,2]]-DMR[[2,3]],DMR[[1,3]]-DMR[[3,1]],DMR[[2,1]]-DMR[[1,2]]};
curveQA=Sqrt[Norma[D[curveR,t]]] (curveQ1/Norma[curveQ1]);

tmp1=D[Sqrt[Norma[D[curveR,t]]],t] (curveQ1/Norma[curveQ1]);
tmp2=Sqrt[Norma[D[curveR,t]]] (1/Norma[curveQ1] DcurveQ1-(curveQ1.DcurveQ1)1/Norma[curveQ1]^3 curveQ1);
DcurveQA=tmp1+tmp2;

tabp=Table[i,{i,aa,bb,2/100}];

tabAFrame=Table[AFrame/.{t->tabp[[i]]},{i,1,Length[tabp]}]/.{CC->-1/2};
tabCurve=Table[curveR/.{t->tabp[[kat]]},{kat,1,Length[tabp]}];

Print["Graph of adapted frame for θ(s)=-1/2s:"]
graf3=DrawGeneralFrameTab[tabAFrame,tabCurve,0.8,{1,0,0},{0,1,0},{0,0,1}]

omegaRMF=DRMFrame[[2]].RMFrame[[3]];
Print["Check: "]
pom1=Norma[Table[omegaRMF/.{θ->tabTh[[i]],t->tabp[[i]]},{i,1,Length[tabTh]}]]

Show[{graf1,graf2,graf3}]

Print["Data sampled from rotation minimizing frame: "]
ClearAll[h]
hh=1/2^4;
Print["Interval [0,h], h = ",hh]
th=Quiet[NIntegrate[-sig tor,{t,aa,aa+hh},WorkingPrecision->NAT]];
Print["Chosen data: "]
P0a=curveR/.{t->aa};
P1a=curveR/.{t->aa+hh};
U0a=curveQRM/.{t->aa,θ->0}
V0a=DcurveQRM/.{t->aa,θ->0}
U1a=curveQRM/.{t->aa+hh,θ->th}
V1a=DcurveQRM/.{t->aa+hh,θ->th}
If[Sign[U0a.U1a]<0,U1a=-U1a;V1a=-V1a];

Print["Check: "]
(D[curveR,t]/.{t->aa})-Rest[OPStar[U0a,U0a]]
(D[curveR,t]/.{t->aa+hh})-Rest[OPStar[U1a,U1a]]
2*Rest[OPStar[U0a,V0a]]-D[curveR,{t,2}]/.{t->aa}
2*Rest[OPStar[U1a,V1a]]-D[curveR,{t,2}]/.{t->aa+hh}

(* ---------- *)

Print["We need to rotate the data. "]
Print["Rotation matrix: "]
Rot=Inverse[Rotacija[U0a][[3]]];
InvRot=Rotacija[U0a][[3]];
(* ----------- *)
P0=Rot.P0a;
P1=Rot.P1a;
U0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U0a];
U1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U1a];
V0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V0a];
V1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V1a];

Print["Equations: "]
{tabGamF,tabKoefF,tabz,enac2}=ComputeEqForG2PHInt7[U0,U1,V0,V1,P0,P1,x,y,z,ξ];
Print["Chosen ξ: "]
izbKsi=1

Print["The best asymptotic solution: "]
solX={x,y,z}/.Quiet[FindRoot[(#==0)&/@(enac2/.ξ->izbKsi),{{x,hh},{y,hh},{z,hh}},WorkingPrecision->NAT]]
N[solX,20]//MatrixForm

sol1={(Subscript[λ, 0])->(Sqrt[solX[[1]]]),(Subscript[λ, 1])->izbKsi(Sqrt[solX[[1]]]),(Subscript[μ, 0])->solX[[2]]/(Sqrt[solX[[1]]]),(Subscript[μ, 1])->solX[[3]]/(Sqrt[solX[[1]]])}
Print["Compute quaternion coefficients: "]
KA=SolForG2PHInt[U0,U1,V0,V1,solX[[1]],solX[[2]],solX[[3]],izbKsi];
KA=Table[KvaternionProd[U0a/Norma[U0a],KA[[i]]],{i,1,Length[KA]}];
KAPol=Plus@@Table[KA[[i+1]]bernstein[t,3,i],{i,0,3}];
ERFrame=1/Norma[KAPol]^2{Rest[OPStar[KAPol,KAPol]],Rest[OPStar2[KAPol,KAPol]],Rest[OPStar3[KAPol,KAPol]]};
funW=D[ERFrame[[2]],t].ERFrame[[3]];
maxFunW=Max[Table[Abs[funW]/.{t->i},{i,0,1,1/1000}]];
WER=RotationAxis[ERFrame[[1]],ERFrame[[2]],ERFrame[[3]],t];
Print["Compute PH interpolant: "]
{pol7,KP,loc}=PHCurveOfDegree7[KA,Inverse[Rot].P0,t];
Print["Length of a control polygon: "]
Plus@@Table[Norma[KP[[i+1]]-KP[[i]]],{i,1,Length[KP]-1}]
VP={1,1,1};
g0=Show[{Graphics3D[{GrayLevel[0.4],PointSize[0.02],Point[KP],Dashed,Line[KP]}],ParametricPlot3D[curveR,{t,aa,aa+hh},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[pol7,{t,0,1},PlotStyle->GrayLevel[0.4],PlotRange->All]},PlotRange->All,ViewPoint->VP,Boxed->False]

(* Let us draw the frame *)
FFi=FFrame;
ff1=FFi[[1]];
ff2=FFi[[2]];
ff3=FFi[[3]];
vel=hh;
kor=0.02;
g1=DrawGeneralFrame[ff1,ff2,ff3,curveR,t,aa,aa+hh,kor,vel,{0,0,0},{0,0,0},{0,0,0}];
FFi=ERFrame;
ff1=FFi[[1]];
ff2=FFi[[2]];
ff3=FFi[[3]];
par=EqualParameters[KAPol,t,50];
g2=DrawGeneralFrame1[ff1,ff2,ff3,pol7,t,par,vel,{0.7,0,0},{0,0.7,0},{0,0,0.7},0.018,0.002];

Show[{g2,ParametricPlot3D[curveR,{t,aa,aa+hh},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[pol7,{t,0,1},PlotStyle->GrayLevel[0.4]]},ViewPoint->VP,Boxed->False]

Print["ω(t): "]
Plot[Abs[funW],{t,0,1},PlotRange->All]
Print["(Subscript[E, ω]) = ",maxFunW]

Print["Compute the reparameterization function and reparameterize the given curve:"]
rep=Simplify[InterpolatingPolynomial[{{0,{aa,(Subscript[λ, 0])^2,6(Subscript[λ, 0])((Subscript[μ, 0])-(Subscript[λ, 0]))}},{1,{aa+hh,(Subscript[λ, 1])^2 ,6(Subscript[λ, 1])(-(Subscript[μ, 1])+(Subscript[λ, 1]))}}}/.sol1,t]]
curveRR=Simplify[curveR/.{t->rep}];
Print["Check if the G^2 conditions are satisfied: "]
Chop[{{curveRR-pol7/.{t->0},curveRR-pol7/.{t->1}},
{D[curveRR-pol7,t]/.{t->0},D[curveRR-pol7,t]/.{t->1}},
{D[curveRR-pol7,{t,2}]/.{t->0},D[curveRR-pol7,{t,2}]/.{t->1}}},10^(-NAT+10)]

Print["Compute the error. Error function: "]
errFun=Norma[curveRR-pol7];
Plot[errFun,{t,0,1}]
Print["Max error:"]
MyFindMax1[errFun,t,0,1,20]

Print["Check: "]
(ERFrame/.{t->0})-(RMFrame/.{t->aa,θ->0})
(ERFrame/.{t->1})-(RMFrame/.{t->aa+hh,θ->th})
Norma[D[curveR,t]/.{t->aa}]/Norma[D[curveR,t]/.{t->aa+hh}]-Norma[D[pol7,t]/.{t->0}]/Norma[D[pol7,t]/.{t->1}]

(* --- Table of errors as h decreases to zero. Data are sampled from rotation minimizing frame.  *)

Print["We compute the interpolants for data sampled from rotation minimizing frame. We use Newton-Raphson iteration method with initial values for x,y,z equal to h; h = 2^(-k), k=1,2,...,10. "]

Print["Values for h: "]
tabH=Table[2^(-k),{k,1,10}]
tabSol={};
tabPol={};
tabKP={};
tabErr={};
TABW={};
izbKsi=1;
For[kk=1,kk≤Length[tabH],kk++,
hh=tabH[[kk]];
a=0;
b=a+hh;
th=Quiet[NIntegrate[-sig tor,{t,a,b},WorkingPrecision->NAT]];
P0a=curveR/.{t->a};
P1a=curveR/.{t->b};
U0a=curveQRM/.{t->a,θ->0};
V0a=DcurveQRM/.{t->a,θ->0};
U1a=curveQRM/.{t->b,θ->th};
V1a=DcurveQRM/.{t->b,θ->th};
If[Sign[U0a.U1a]<0,U1a=-U1a;V1a=-V1a];
Print["********** h = ", hh, " **********"];
Print["Interval (a,b) = ",{a,b}];
Print["theta = ",th];
(*Print["Chosen data: "];*)
Rot=Inverse[Rotacija[U0a][[3]]];
InvRot=Rotacija[U0a][[3]];
(* ----------- *)
P0=Rot.P0a;
P1=Rot.P1a;
U0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U0a];
U1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U1a];
V0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V0a];
V1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V1a];
(* -------------------- *)
(*Print["Equations: "];*)
{tabGamF,tabKoefF,tabz,enac2}=ComputeEqForG2PHInt7[U0,U1,V0,V1,P0,P1,x,y,z,ξ];
Print["The best asymptotic solution: "];
sol={{x,y,z}/.Quiet[FindRoot[(#==0)&/@(enac2/.ξ->izbKsi),{{x,hh},{y,hh},{z,hh}},WorkingPrecision->NAT]]};
Print[N[sol,20]//MatrixForm];
Print["The best asymptotic solution divided by h: "];
Print[N[sol/hh,20]//MatrixForm];
tabSol=Append[tabSol,sol];
tabpol={};
tabe={};
tabKPa={};
tabEW={};
For[jj=1,jj≤Length[sol],jj++,
(*Print["---------------------"];*)
solX=sol[[jj]];
sol1={(Subscript[λ, 0])->(Sqrt[solX[[1]]]),(Subscript[λ, 1])->izbKsi(Sqrt[solX[[1]]]),(Subscript[μ, 0])->solX[[2]]/(Sqrt[solX[[1]]]),(Subscript[μ, 1])->solX[[3]]/(Sqrt[solX[[1]]])};
KA=SolForG2PHInt[U0,U1,V0,V1,solX[[1]],solX[[2]],solX[[3]],izbKsi];
KA=Table[KvaternionProd[U0a/Norma[U0a],KA[[i]]],{i,1,Length[KA]}];
(*Print["Compute PH interpolants: "];*)
{pol7,KP,loc}=PHCurveOfDegree7[KA,Inverse[Rot].P0,t];
(*--------*)
KAPol=Plus@@Table[KA[[i+1]]bernstein[t,3,i],{i,0,3}];
ERFrame=1/Norma[KAPol]^2{Rest[OPStar[KAPol,KAPol]],Rest[OPStar2[KAPol,KAPol]],Rest[OPStar3[KAPol,KAPol]]};
funW=D[ERFrame[[2]],t].ERFrame[[3]];
maxFunW1=Max[Table[Abs[funW]/.{t->i},{i,0,1,1/1000}]];
maxFunW=FindMaximum[Abs[funW],{t,0,1},PrecisionGoal->20,WorkingPrecision->20][[1]];
Print["E_w = ",Max[{maxFunW1,maxFunW}]];
tabEW=Append[tabEW,Max[{maxFunW,maxFunW1}]];
(* --------------- *)
tabpol=Append[tabpol,pol7];
tabKPa=Append[tabKPa,KP];
(*Print["Compute the reparameterization function and reparameterize the given curve:"];*)
rep=Simplify[InterpolatingPolynomial[{{0,{a,(Subscript[λ, 0])^2,6(Subscript[λ, 0])((Subscript[μ, 0])-(Subscript[λ, 0]))}},{1,{b,(Subscript[λ, 1])^2 ,6(Subscript[λ, 1])(-(Subscript[μ, 1])+(Subscript[λ, 1]))}}}/.sol1,t]];
curveRR=Simplify[curveR/.{t->rep}];
Print["Check if the G^2 conditions are satisfied: "];
Print[Norm[Flatten[Chop[{{curveRR-pol7/.{t->0},curveRR-pol7/.{t->1}},
{D[curveRR-pol7,t]/.{t->0},D[curveRR-pol7,t]/.{t->1}},
{D[curveRR-pol7,{t,2}]/.{t->0},D[curveRR-pol7,{t,2}]/.{t->1}}},10^(-NAT+10)]]]<10^(-NAT+30)];
(* Compute the error. *);
errFun=Chop[Norma[curveRR-pol7],10^(-NAT+10)];
err=MyFindMax1[errFun,t,0,1,NAT-10];
tabe=Append[tabe,err[[1]]];
Print["error = ",N[err[[1]],20]];
];
(*Print["***********************"];*)
tabPol=Append[tabPol,tabpol];
tabKP=Append[tabKP,tabKPa];
tabErr=Append[tabErr,tabe];
TABW=Append[TABW,tabEW];
]

Print["Approximation order for the computed solution:"]
kat=1;
OD=1;
Transpose[Join[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],{Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]},{N[Last[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[TABW[[i,kat]],16],{i,OD,Length[TABW]}]]]],4]}]]//MatrixForm
Print["solution {x,y,z}/h="]
N[Table[tabSol[[i,kat]]/tabH[[i]],{i,OD,Length[tabH]}],16]//MatrixForm

Print["Graph of errors (Subscript[Log, 10])[(Subscript[E, err])] in dependence of k, where h=2^(-k): "]
OD=1;pom1RMF=Transpose[{Table[k,{k,OD,Length[tabH]}],Log[#]/Log[10]&/@Rest[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[tabErr[[i,1]],{i,OD,Length[tabErr]}]]][[2]]]}];

grafRMF=Show[{Graphics[{PointSize[0.025],Dashing[0.02],RGBColor[0,0,0],Point[pom1RMF],Line[pom1RMF]}]},AspectRatio->1,Axes->True,AxesOrigin->{0.5,0},BaseStyle->22,Ticks->{Table[i,{i,1,10}],All},Frame->{{True,False},{True,False}},FrameLabel->{"k","(Subscript[Log, 10])[(Subscript[E, err])]"},Ticks->{Table[i,{i,1,10}],All}]

Print["Graph of (Subscript[Log, 10])[(Subscript[E, ω])] in dependence of k, where h=2^(-k): "]
OD=1;pom2RMF=Transpose[{Table[k,{k,OD,Length[tabH]}],Log[#]/Log[10]&/@Rest[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[TABW[[i,1]],{i,OD,Length[TABW]}]]][[2]]]}];

ClearAll[h]
nap1=0.07 h^4; 
line1={Line[{{4,Log[nap1/.{h->2^(-4)}]/Log[10]},{7,Log[nap1/.{h->2^(-7)}]/Log[10]}}]};
graf2RMF=Show[{Graphics[{line1,Text["(h^4)",{5,-8.2}]}],Graphics[{PointSize[0.025],Dashing[0.02],RGBColor[0,0,0],Point[pom2RMF],Line[pom2RMF]}]},AspectRatio->1,Axes->True,AxesOrigin->{0.5,0},BaseStyle->22,Ticks->{Table[i,{i,1,10}],All},Frame->{{True,False},{True,False}},FrameLabel->{"k","(Subscript[Log, 10])[(Subscript[E, ω])]"},Ticks->{Table[i,{i,1,10}],All}]

(* ----------------------------- *)

Print["We compute the interpolants for data sampled from adapted frame with θ(s)=c*s for different constants c. We use Newton-Raphson iteration method with initial values for x,y,z equal to h; h = 2^(-k), k=1,2,...,10. "]

Print["Values for c:"]
tabCC=Join[Table[i,{i,-4,-1/2,1/2}],Table[i,{i,1/2,4,1/2}]]
Print["Values for h: "]
tabH=Table[2^(-k),{k,1,10}]
tabSol={};
tabPol={};
tabKP={};
tabErr={};
TABW={};
izbKsi=1;
For[kk=1,kk≤Length[tabH],kk++,
tabSol1={};
tabpol={};
tabe={};
tabKPa={};
tabEW={};
hh=tabH[[kk]];
a=0;
b=a+hh;
Print["********** h = ", hh, " **********"];
(*Print["Interval (a,b) = ",{a,b}];*)
For[ic=1,ic≤Length[tabCC],ic++,
izbC=tabCC[[ic]];
(*Print["-----------------"];*)
Print["Chosen c = ", tabCC[[ic]]];
(*th=Quiet[NIntegrate[-sig tor,{t,a,b},WorkingPrecision->NAT]];*)
P0a=curveR/.{t->a};
P1a=curveR/.{t->b};
U0a=curveQA/.{t->a,CC->izbC};
V0a=DcurveQA/.{t->a,CC->izbC};
U1a=curveQA/.{t->b,CC->izbC};
V1a=DcurveQA/.{t->b,CC->izbC};
If[Sign[U0a.U1a]<0,U1a=-U1a;V1a=-V1a];
(*Print["Chosen data: "];*)
Rot=Inverse[Rotacija[U0a][[3]]];
InvRot=Rotacija[U0a][[3]];
(* ----------- *)
P0=Rot.P0a;
P1=Rot.P1a;
U0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U0a];
U1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],U1a];
V0=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V0a];
V1=KvaternionProd[KvaternionConj[U0a]/Norma[U0a],V1a];
(* -------------------- *)
(*Print["Equations: "];*)
{tabGamF,tabKoefF,tabz,enac2}=ComputeEqForG2PHInt7[U0,U1,V0,V1,P0,P1,x,y,z,ξ];
(*Print["The best asymptotic solution: "];*)
sol={{x,y,z}/.Quiet[FindRoot[(#==0)&/@(enac2/.ξ->izbKsi),{{x,hh},{y,hh},{z,hh}},WorkingPrecision->NAT]]};
Print["Computed solution divided by h: "];
Print[N[sol/hh,20]//MatrixForm];
tabSol1=Append[tabSol1,sol[[1]]];
For[jj=1,jj≤1,jj++,
(*Print["---------------------"];*)
solX=sol[[jj]];
sol1={(Subscript[λ, 0])->(Sqrt[solX[[1]]]),(Subscript[λ, 1])->izbKsi(Sqrt[solX[[1]]]),(Subscript[μ, 0])->solX[[2]]/(Sqrt[solX[[1]]]),(Subscript[μ, 1])->solX[[3]]/(Sqrt[solX[[1]]])};
KA=SolForG2PHInt[U0,U1,V0,V1,solX[[1]],solX[[2]],solX[[3]],izbKsi];
KA=Table[KvaternionProd[U0a/Norma[U0a],KA[[i]]],{i,1,Length[KA]}];
(*Print["Compute PH interpolants: "];*)
{pol7,KP,loc}=PHCurveOfDegree7[KA,Inverse[Rot].P0,t];
(*--------*)
KAPol=Plus@@Table[KA[[i+1]]bernstein[t,3,i],{i,0,3}];
ERFrame=1/Norma[KAPol]^2{Rest[OPStar[KAPol,KAPol]],Rest[OPStar2[KAPol,KAPol]],Rest[OPStar3[KAPol,KAPol]]};
funW=D[ERFrame[[2]],t].ERFrame[[3]];
maxFunW1=Max[Table[Abs[funW]/.{t->i},{i,0,1,1/1000}]];
maxFunW=FindMaximum[Abs[funW],{t,0,1},PrecisionGoal->20,WorkingPrecision->20][[1]];
(*Print["E_w = ",Max[{maxFunW1,maxFunW}]];*)
tabEW=Append[tabEW,Max[{maxFunW,maxFunW1}]];
(* --------------- *)
tabpol=Append[tabpol,pol7];
tabKPa=Append[tabKPa,KP];
(*Print["Compute the reparameterization function and reparameterize the given curve:"];*)
rep=Simplify[InterpolatingPolynomial[{{0,{a,(Subscript[λ, 0])^2,6(Subscript[λ, 0])((Subscript[μ, 0])-(Subscript[λ, 0]))}},{1,{b,(Subscript[λ, 1])^2 ,6(Subscript[λ, 1])(-(Subscript[μ, 1])+(Subscript[λ, 1]))}}}/.sol1,t]];
curveRR=Simplify[curveR/.{t->rep}];
Print["Check if the G^2 conditions are satisfied: "];
Print[Norm[Flatten[Chop[{{curveRR-pol7/.{t->0},curveRR-pol7/.{t->1}},
{D[curveRR-pol7,t]/.{t->0},D[curveRR-pol7,t]/.{t->1}},
{D[curveRR-pol7,{t,2}]/.{t->0},D[curveRR-pol7,{t,2}]/.{t->1}}},10^(-NAT+10)]]]<10^(-NAT+40)];
(* Compute the error. *);
errFun=Chop[Norma[curveRR-pol7],10^(-NAT+10)];
err=MyFindMax1[errFun,t,0,1,NAT-10];
tabe=Append[tabe,err[[1]]];
(*Print["error = ",N[err[[1]],20]];*)
];
];
Print["***********************"];
tabSol=Append[tabSol,tabSol1];
tabPol=Append[tabPol,tabpol];
tabKP=Append[tabKP,tabKPa];
tabErr=Append[tabErr,tabe];
TABW=Append[TABW,tabEW];
]

Print["Table of errors for a chosen constant c."]
kat=1;
Print["c = ", tabCC[[kat]]]
OD=1;
Transpose[Join[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[tabErr[[i,kat]],16],{i,OD,Length[tabErr]}]]],{Prepend[Table[N[TABW[[i,kat]],6],{i,OD,Length[TABW]}],"E_w"]},{N[Last[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[N[TABW[[i,kat]],16],{i,OD,Length[TABW]}]]]],4]}]]//MatrixForm
Print["solution {x,y,z}/h="]
N[Table[tabSol[[i,kat]]/tabH[[i]],{i,OD,Length[tabH]}],16]//MatrixForm

tabGL=Table[i,{i,0.3,0.75,0.03}]
Length[tabGL]

tabRGB=Table[RGBColor[1-i,0.2,i],{i,0.1,0.6,0.03}]
Length[tabRGB]

tabRGB=Reverse[Table[RGBColor[0.2,0.6i,i],{i,0.2,0.9,0.04}]]
Length[tabRGB]

Print["Graph of errors (Subscript[Log, 10])[(Subscript[E, err])] in dependence of k, where h=2^(-k), for different values c. "]
pom1=Table[Transpose[{Table[k,{k,1,Length[tabH]}],Log[#]/Log[10]&/@Rest[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[tabErr[[i,kat]],{i,OD,Length[tabErr]}]]][[2]]]}],{kat,1,Length[tabCC]}];
tabGL=Table[i,{i,0.1,0.6,0.03}];
ClearAll[h]
nap1=0.03 h^6; 
line1={Line[{{4,Log[nap1/.{h->2^(-4)}]/Log[10]},{7,Log[nap1/.{h->2^(-7)}]/Log[10]}}]};
grafA1=Show[{Table[Graphics[{PointSize[0.025],GrayLevel[tabGL[[kat]]],Point[pom1[[kat]]],Line[pom1[[kat]]]}],{kat,1,Length[pom1]}],Graphics[{line1,Text["(h^6)",{5,-12}]}]},AspectRatio->1,Axes->True,AxesOrigin->{0.5,0},BaseStyle->22,Ticks->{Table[i,{i,1,10}],All},Frame->{{True,False},{True,False}},FrameLabel->{"k","(Subscript[Log, 10])[(Subscript[E, err])]"},PlotRange->{{0,10},{-2,-20}}]
grafA1a=Show[{Table[Graphics[{PointSize[0.025],tabRGB[[kat]],Point[pom1[[kat]]],Line[pom1[[kat]]]}],{kat,1,Length[pom1]}],Graphics[{line1,Text["(h^6)",{5,-12}]}]},AspectRatio->1,Axes->True,AxesOrigin->{0.5,0},BaseStyle->22,Ticks->{Table[i,{i,1,10}],All},Frame->{{True,False},{True,False}},FrameLabel->{"k","(Subscript[Log, 10])[(Subscript[E, err])]"},PlotRange->{{0,10},{-2,-20}}]

Show[grafA1,grafRMF,PlotRange->{All,{1,-20}}]
Show[grafA1a,grafRMF,PlotRange->{All,{1,-20}}]

Print["Graph of (Subscript[Log, 10])[(Subscript[E, ω])] in dependence of k, where h=2^(-k), for different values c. "]
pom2=Table[Transpose[{Table[k,{k,1,Length[tabH]}],Log[#]/Log[10]&/@Rest[Transpose[RedAproksimacije[Table[tabH[[i]],{i,OD,Length[tabH]}],Table[TABW[[i,kat]],{i,OD,Length[TABW]}]]][[2]]]}],{kat,1,Length[tabCC]}];
ClearAll[h]
nap2=0.1h^1; 
line2={Line[{{4,Log[nap2/.{h->2^(-4)}]/Log[10]},{7,Log[nap2/.{h->2^(-7)}]/Log[10]}}]};

grafA2=Show[{Table[Graphics[{PointSize[0.025],GrayLevel[tabGL[[kat]]],Point[pom2[[kat]]],Line[pom2[[kat]]]}],{kat,1,Length[pom2]}],Graphics[{line2,Text["(h^1)",{5,-3.4}]}]},AspectRatio->1,Axes->True,AxesOrigin->{0.5,1},BaseStyle->22,Ticks->{Table[i,{i,1,10}],All},Frame->{{True,False},{True,False}},FrameLabel->{"k","(Subscript[Log, 10])[(Subscript[E, ω])]"}];
grafA2a=Show[{Table[Graphics[{PointSize[0.025],tabRGB[[kat]],Point[pom2[[kat]]],Line[pom2[[kat]]]}],{kat,1,Length[pom2]}],Graphics[{line2,Text["(h^1)",{5,-3.4}]}]},AspectRatio->1,Axes->True,AxesOrigin->{0.5,1},BaseStyle->22,Ticks->{Table[i,{i,1,10}],All},Frame->{{True,False},{True,False}},FrameLabel->{"k","(Subscript[Log, 10])[(Subscript[E, ω])]"}];

Show[graf2RMF,grafA2,PlotRange->{All,{1,-20}}]
Show[graf2RMF,grafA2a,PlotRange->{All,{1,-20}}]

Example 4

NAT=60;
Print["Chosen data: "]
P0=N[{0,0,0},NAT];
P1=N[{6,7,4},NAT];
U0=N[{1,0,0,0},NAT];
U1={1,2,0,2};
U1=N[U1/Norma[U1],NAT];
V0=N[{0,0,1,0},NAT];
V1=N[{0,0,0,1},NAT];
MatrixRank[{U0,U1,V0,V1}];
Print["(Subscript[P, 0]) = ", P0]
Print["(Subscript[P, 1]) = ", P1]
Print["(Subscript[U, 0]) = ", U0]
Print["(Subscript[U, 1]) = ", U1]
Print["(Subscript[V, 0]) = ", V0]
Print["(Subscript[V, 1]) = ", V1]

izbKsi=1;
Print["Chosen ξ = ",izbKsi]
weight=1/2; (* weight for the functional E *)
Print["We compute the interpolant: "]
{sol,tabpol,tabKP,tabpolA,tabERF,tabE}=SepticPHInterpolant1[t,P0,P1,U0,U1,V0,V1,izbKsi,NAT];
Print["{(Subscript[E, len]),(Subscript[E, ω])} for all of the solutions: "]
tabE

Print["Choose a solution: "]
ind=1
pol7=tabpol[[ind]];
pol7A=tabpolA[[ind]];
KP=tabKP[[ind]];
ERFrame=tabERF[[ind]];
Print["Value of the functional E: "]
(1-weight)tabE[[ind,1]]+weight tabE[[ind,2]]

Show[{Graphics3D[{GrayLevel[0.4],PointSize[0.02],Point[KP],Dashed,Line[KP]}],ParametricPlot3D[pol7,{t,0,1},PlotStyle->GrayLevel[0.4],PlotRange->All]},PlotRange->All,Boxed->False]

(* Let us draw the frame *)
FFi=ERFrame;
ff1=FFi[[1]];
ff2=FFi[[2]];
ff3=FFi[[3]];
kor=0.02;
vel=1;
par=EqualParameters[pol7A,t,50];
g2=DrawGeneralFrame1[ff1,ff2,ff3,pol7,t,par,vel,{0.7,0,0},{0,0.7,0},{0,0,0.7},0.02,0.002];

Show[{g2,ParametricPlot3D[pol7,{t,0,1},PlotStyle->GrayLevel[0.4]]},Boxed->False]

Print["We compute the interpolants with the smallest value (Subscript[E, 1/2])(ξ;p) for different values of ξ."]

TABP={};
TABKP={};
TABERF={};
TABV={};
NN=500;
TABKSI=Table[1/5+((5-1/10)/NN )i,{i,0,NN}];
For[i=1,i≤Length [TABKSI],i++,
(*Print["For a chosen ksi we choose the interpolant with the smallest E_w: "];*)
izbKsi=TABKSI[[i]];
{sol,tabpol,tabKP,tabERF,tabE}=SepticPHInterpolant[t,P0,P1,U0,U1,V0,V1,izbKsi,NAT];
pol7={};
KP={};
ERFrame={};
valF={};
If[Length[sol]≠0,
ind=1;
For[j=2,j<=Length[sol],j++,
(* we choose the interpolant with the smallest length and smallest w (with respect to given weight) *)
If[((1-weight)tabE[[j,1]]+weight tabE[[j,2]])<((1-weight)tabE[[ind,1]]+weight tabE[[ind,2]]),
ind=j;
];
];
pol7=tabpol[[ind]];
KP=tabKP[[ind]];
ERFrame=tabERF[[ind]];
valF=(1-weight)tabE[[ind,1]]+weight tabE[[ind,2]];
];
TABP=Append[TABP,pol7];
TABKP=Append[TABKP,KP];
TABERF=Append[TABERF,ERFrame];
TABV=Append[TABV,valF];
]

{ind,mn}=MinOfSet[TABV];
Print["Value ξ for which (Subscript[E, 1/2])(ξ;p) is minimal = ", TABKSI[[ind]]]

Show[{Table[ParametricPlot3D[TABP[[i]],{t,0,1},PlotStyle->{GrayLevel[0.3],Opacity[0.5]}],{i,1,Length[TABP]}]},PlotRange->All,BaseForm->20,ViewPoint->Right]

Show[{Table[ParametricPlot3D[TABP[[i]],{t,0,1},PlotStyle->{GrayLevel[0.3],Opacity[0.5]}],{i,1,Length[TABP]-300}]},PlotRange->All,BaseForm->20,ViewPoint->{2,-2,0}]

(* We use this ξ and plot the interpolant and its ER frame: *)
izbKsi=(99/250);
Print["Chosen ξ = ",N[izbKsi]]
weight=1/2; (* weight for the functional E *)
Print["We compute the interpolant: "]
{sol,tabpol,tabKP,tabpolA,tabERF,tabE}=SepticPHInterpolant1[t,P0,P1,U0,U1,V0,V1,izbKsi,NAT];
Print["{(Subscript[E, len]), (Subscript[E, ω])} for all of the solutions: "]
tabE

Print["Choose a solution: "]
ind=1
pol7=tabpol[[ind]];
pol7A=tabpolA[[ind]];
KP=tabKP[[ind]];
ERFrame=tabERF[[ind]];
Print["\!\(\*SubscriptBox[\(E\), \(\(1/2\)\(\\ \)\)]\) = ",(1-weight)tabE[[ind,1]]+weight tabE[[ind,2]]]

Show[{Graphics3D[{GrayLevel[0.4],PointSize[0.02],Point[KP],Dashed,Line[KP]}],ParametricPlot3D[pol7,{t,0,1},PlotStyle->GrayLevel[0.4],PlotRange->All]},PlotRange->All,Boxed->False]

(* Let us draw the frame *)
FFi=ERFrame;
ff1=FFi[[1]];
ff2=FFi[[2]];
ff3=FFi[[3]];
kor=0.02;
vel=1;
par=EqualParameters[pol7A,t,50];
g2=DrawGeneralFrame1[ff1,ff2,ff3,pol7,t,par,vel,{0.7,0,0},{0,0.7,0},{0,0,0.7},0.02,0.002];

Show[{g2,Graphics3D[{GrayLevel[0.4],PointSize[0.02],Point[KP],Dashed,Line[KP]}],ParametricPlot3D[pol7,{t,0,1},PlotStyle->GrayLevel[0.4]]},Boxed->False]

Spline example 1

Print["Chosen curve: "]
NAT=60;
curveR=N[{Log[t+3]Sin[Pi t],Log[t+3]Cos[Pi t],Sqrt[t^2+4t+5]},NAT];
aa=0;
bb=10;
aai=0;
ParametricPlot3D[curveR,{t,aa,bb}]

Print["Torsion, curvature and parametric speed: "]
tor=Torsion[curveR,t];
curv=Ukriv[curveR,t];
sig=Norma[D[curveR,t]];
Plot[{tor,curv,sig},{t,aa,bb},AxesOrigin->{0,0}]
Print["Condition ψ(r,t) (from the paper): "]
cond=AsymptoticCond[curveR,t];
Plot[cond,{t,aa,bb},PlotRange->All]

(* Frenet Frame *)
FFrame=Frene[curveR,t];
MR=Transpose[FFrame];
curveQ1={1+MR[[1,1]]+MR[[2,2]]+MR[[3,3]],MR[[3,2]]-MR[[2,3]],MR[[1,3]]-MR[[3,1]],MR[[2,1]]-MR[[1,2]]};
curveQ=Sqrt[Norma[D[curveR,t]]] (curveQ1/Norma[curveQ1]);

Show[DrawGeneralFrame[FFrame[[1]],FFrame[[2]],FFrame[[3]],curveR,t,aa,bb,0.02,1,{0.7,0,0},{0,0.7,0},{0,0,0.7}]]

Print["Rotation minimizing frame:"]
AFrame={FFrame[[1]],Cos[θ]FFrame[[2]]+Sin[θ]FFrame[[3]],-Sin[θ]FFrame[[2]]+Cos[θ]FFrame[[3]]};
DAFrame={D[FFrame[[1]],t],-tor sig AFrame[[3]]+Cos[θ]D[FFrame[[2]],t]+Sin[θ]D[FFrame[[3]],t],tor sig AFrame[[2]]-Sin[θ]D[FFrame[[2]],t]+Cos[θ]D[FFrame[[3]],t]};

MR=Transpose[AFrame];
DMR=Transpose[DAFrame];
curveQ1={1+MR[[1,1]]+MR[[2,2]]+MR[[3,3]],MR[[3,2]]-MR[[2,3]],MR[[1,3]]-MR[[3,1]],MR[[2,1]]-MR[[1,2]]};
DcurveQ1={DMR[[1,1]]+DMR[[2,2]]+DMR[[3,3]],DMR[[3,2]]-DMR[[2,3]],DMR[[1,3]]-DMR[[3,1]],DMR[[2,1]]-DMR[[1,2]]};
curveQ=Sqrt[Norma[D[curveR,t]]] (curveQ1/Norma[curveQ1]);

tmp1=D[Sqrt[Norma[D[curveR,t]]],t] (curveQ1/Norma[curveQ1]);
tmp2=Sqrt[Norma[D[curveR,t]]] (1/Norma[curveQ1] DcurveQ1-(curveQ1.DcurveQ1)1/Norma[curveQ1]^3 curveQ1);
DcurveQ=tmp1+tmp2;

tabp=Table[i,{i,aa,bb,1/10}];
tabTh=Table[NIntegrate[-sig tor,{t,0,tabp[[i]]},WorkingPrecision->NAT-10],{i,1,Length[tabp]}];

tabAFrame=Table[AFrame/.{θ->tabTh[[i]],t->tabp[[i]]},{i,1,Length[tabTh]}];
tabCurve=Table[curveR/.{t->tabp[[kat]]},{kat,1,Length[tabp]}];

graf=DrawGeneralFrameTab[tabAFrame,tabCurve,0.8,{1,0,0},{0,1,0},{0,0,1}]

tabA=Table[aa,{aa,0,6,1/2}];
Print["Chosen parameters ξ on consecutive polynomial segments: "]
tabK=Table[1,{i,1,Length[tabA]}]
tabSpline={};
tabSplineA={};
tabSplineKP={};
tabSplineERF={};
tabSplineE={};
tabSplineRot={};
weight=1/2; (* chosen weight for the functional (Subscript[E, δ]) *)
ClearAll[t];
For[kk=1,kk≤Length[tabA]-1,kk++,
aa=tabA[[kk]];
bb=tabA[[kk+1]];
th0=Quiet[NIntegrate[-sig tor,{t,aai,aa},WorkingPrecision->NAT]];
th1=Quiet[NIntegrate[-sig tor,{t,aai,bb},WorkingPrecision->NAT]];
izbKsi=tabK[[kk]];
Print["Interval = ",{aa,bb}];
(* Chosen data: *)
P0a=curveR/.{t->aa};
P1a=curveR/.{t->bb};
U0a=curveQ/.{t->aa,θ->th0};
U1a=curveQ/.{t->bb,θ->th1};
V0a=DcurveQ/.{t->aa,θ->th0};
V1a=DcurveQ/.{t->bb,θ->th1};
If[Sign[U0a.U1a]<0,U1a=-U1a;V1a=-V1a];
(* ------------- *)
{sol,tabpol,tabKP,tabpolA,tabERF,tabE}=SepticPHInterpolant1[t,P0a,P1a,U0a,U1a,V0a,V1a,izbKsi,NAT];
Print["Number of solutions: ",Length[sol]];
Print["Values of {(Subscript[E, len]), (Subscript[E, ω])}: ",tabE//MatrixForm];
If[Length[sol]≠0,
ind=1;
For[j=2,j<=Length[sol],j++,
(* we choose the interpolant with the smallest length and smallest w *)
If[((1-weight)tabE[[j,1]]+weight tabE[[j,2]])<((1-weight)tabE[[ind,1]]+weight tabE[[ind,2]]),
ind=j;
];
];
pol7=tabpol[[ind]];
pol7A=tabpolA[[ind]];
KP=tabKP[[ind]];
ERFrame=tabERF[[ind]];
(*Rotational axis: *)
WF=RotationAxis[ERFrame[[1]],ERFrame[[2]],ERFrame[[3]],t];
FunE=tabE[[ind]];
];
Print["\!\(\*SubscriptBox[\(E\), \(\(1/2\)\(\\ \)\)]\) = ", FunE];
tabSpline=Append[tabSpline,pol7];
tabSplineA=Append[tabSplineA,pol7A];
tabSplineKP=Append[tabSplineKP,KP];
tabSplineERF=Append[tabSplineERF,ERFrame];
tabSplineRot=Append[tabSplineRot,WF];
tabSplineE=Append[tabSplineE,FunE];
]

Print["Control polygons: "]
Show[{Table[Graphics3D[{GrayLevel[0.4],PointSize[0.01],Point[tabSplineKP[[i]]],Dashed,Line[tabSplineKP[[i]]]}],{i,1,Length[tabSplineKP]}]}]
Print["Curve and its PH spline interpolant: "]
Show[{ParametricPlot3D[curveR,{t,tabA[[1]],Last[tabA]},PlotStyle->{RGBColor[{0,0,0}]}],Table[ParametricPlot3D[tabSpline[[i]],{t,0,1},PlotStyle->GrayLevel[0.4],PlotRange->All],{i,1,Length[tabSpline]}]},PlotRange->All]

Print["Rotational axis: "]
Graphics3D[{Arrowheads[0.01],Flatten[Table[Table[Arrow[{tabSpline[[i]],tabSpline[[i]]+tabSplineRot[[i]]/Norma[tabSplineRot[[i]]]}/.{t->j}],{j,0,1,0.02}],{i,1,Length[tabSpline]}]]}]

Print["We compute the parameters: "]
tabSplinePar=Table[{},{i,1,Length[tabSplineA]}];
For[i=1,i≤Length[tabSplineA],i++,
tabSplinePar[[i]]=EqualParameters[tabSplineA[[i]],t,35];
]

Show[{Table[DrawGeneralFrame1[tabSplineERF[[i,1]],tabSplineERF[[i,2]],tabSplineERF[[i,3]],tabSpline[[i]],t,tabSplinePar[[i]],1,{0.7,0,0},{0,0.7,0},{0,0,0.7},0.01,0.0008],{i,1,Length[tabSplineERF]}],Table[DrawGeneralFrame1[tabSplineERF[[i,1]],tabSplineERF[[i,2]],tabSplineERF[[i,3]],tabSpline[[i]],t,{0,1},1,{0,0,0},{0,0,0},{0,0,0},0.015,0.006],{i,1,Length[tabSplineERF]}],Table[ParametricPlot3D[tabSpline[[i]],{t,0,1},PlotStyle->GrayLevel[0.4],PlotRange->All],{i,1,Length[tabSpline]}]},Axes->True,BaseStyle->16,Ticks->{{-2,0,2},All,All}]

Show[{Table[DrawGeneralFrame1[tabSplineERF[[i,1]],tabSplineERF[[i,2]],tabSplineERF[[i,3]],tabSpline[[i]],t,tabSplinePar[[i]],1,{0.7,0,0},{0,0.7,0},{0,0,0.7},0.01,0.0008],{i,1,Length[tabSplineERF]}],Table[DrawGeneralFrame1[tabSplineERF[[i,1]],tabSplineERF[[i,2]],tabSplineERF[[i,3]],tabSpline[[i]],t,{0,1},1,{0,0,0},{0,0,0},{0,0,0},0.017,0.006],{i,1,Length[tabSplineERF]}],Table[ParametricPlot3D[tabSpline[[i]],{t,0,1},PlotStyle->GrayLevel[0.4],PlotRange->All],{i,1,Length[tabSpline]}]},BaseStyle->16,Ticks->{{-2,0,2},All,All}]

Show[Table[DrawGeneralFrame[tabSplineERF[[i,1]],tabSplineERF[[i,2]],tabSplineERF[[i,3]],tabSpline[[i]],t,0,1,0.025,1,{0.7,0,0},{0,0.7,0},{0,0,0.7}],{i,1,Length[tabSplineERF]}],Axes->True]

Print["Motion of a cube: "]
tabSplinePar=Table[{},{i,1,Length[tabSplineA]}];
For[i=1,i≤Length[tabSplineA],i++,
tabSplinePar[[i]]=EqualParameters[tabSplineA[[i]],t,15];
]
vel=0.7;
Show[{Graphics3D[{Table[Table[DrawRB[vel Kocka,tabSpline[[ii]]/.{t->tabSplinePar[[ii,k]]},tabSplineA[[ii]]/.{t->tabSplinePar[[ii,k]]}],{k,1,Length[tabSplinePar[[ii]]]}],{ii,1,Length[tabSplineA]}]}],Graphics3D[{Table[Table[DrawRB1[vel Kocka,tabSpline[[ii]]/.{t->k},tabSplineA[[ii]]/.{t->k}],{k,0,1}],{ii,1,Length[tabSplineA]}]}]},ViewPoint->VP]

Spine example 2

Print["Chosen curve: "]
NAT=60;
curveR=N[{t-Sin[Pi t],t+Cos[Pi t],5 Sqrt[t^2+1]},NAT];
aa=0;
aaZ=aa;
bb=5;
ParametricPlot3D[curveR,{t,aa,bb}]

Print["Torsion, curvature and parametric speed: "]
tor=Torsion[curveR,t];
curv=Ukriv[curveR,t];
sig=Norma[D[curveR,t]];
Plot[{tor,curv,sig},{t,0,10},AxesOrigin->{0,0}]
Print["Condition ψ(r,t) (from the paper): "]
cond=AsymptoticCond[curveR,t];
Plot[cond,{t,0,10},PlotRange->All]

Print["Condition ψ(r,0)= ",cond/.{t->0}]

Print["Frenet Frame:"]
FFrame=Frene[curveR,t];
MR=Transpose[FFrame];
DMR=Transpose[D[FFrame,t]];
curveFQ1={1+MR[[1,1]]+MR[[2,2]]+MR[[3,3]],MR[[3,2]]-MR[[2,3]],MR[[1,3]]-MR[[3,1]],MR[[2,1]]-MR[[1,2]]};
DcurveFQ1={DMR[[1,1]]+DMR[[2,2]]+DMR[[3,3]],DMR[[3,2]]-DMR[[2,3]],DMR[[1,3]]-DMR[[3,1]],DMR[[2,1]]-DMR[[1,2]]};
curveQF=Sqrt[Norma[D[curveR,t]]] (curveFQ1/Norma[curveFQ1]);

Print["Computation of the derivative of Q in a different way:"]
tmp1=D[Sqrt[Norma[D[curveR,t]]],t] (curveFQ1/Norma[curveFQ1]);
tmp2=Sqrt[Norma[D[curveR,t]]] (1/Norma[curveFQ1] DcurveFQ1-(curveFQ1.DcurveFQ1)1/Norma[curveFQ1]^3 curveFQ1);
DcurveQF=tmp1+tmp2;

Print["Graph of Frenet frame:"]
graf1=Show[DrawGeneralFrame[FFrame[[1]],FFrame[[2]],FFrame[[3]],curveR,t,aa,bb,0.02,1,{0.7,0,0},{0,0.7,0},{0,0,0.7}]]

Print["Rotational axis: "]
WF=RotationAxis[FFrame[[1]],FFrame[[2]],FFrame[[3]],t];

(* ----------- *)

Print["Rotation minimizing frame:"]
RMFrame={FFrame[[1]],Cos[θ]FFrame[[2]]+Sin[θ]FFrame[[3]],-Sin[θ]FFrame[[2]]+Cos[θ]FFrame[[3]]};
DRMFrame={D[FFrame[[1]],t],-tor sig RMFrame[[3]]+Cos[θ]D[FFrame[[2]],t]+Sin[θ]D[FFrame[[3]],t],tor sig RMFrame[[2]]-Sin[θ]D[FFrame[[2]],t]+Cos[θ]D[FFrame[[3]],t]};

MR=Transpose[RMFrame];
DMR=Transpose[DRMFrame];
curveQ1={1+MR[[1,1]]+MR[[2,2]]+MR[[3,3]],MR[[3,2]]-MR[[2,3]],MR[[1,3]]-MR[[3,1]],MR[[2,1]]-MR[[1,2]]};
DcurveQ1={DMR[[1,1]]+DMR[[2,2]]+DMR[[3,3]],DMR[[3,2]]-DMR[[2,3]],DMR[[1,3]]-DMR[[3,1]],DMR[[2,1]]-DMR[[1,2]]};
curveQRM=Sqrt[Norma[D[curveR,t]]] (curveQ1/Norma[curveQ1]);

tmp1=D[Sqrt[Norma[D[curveR,t]]],t] (curveQ1/Norma[curveQ1]);
tmp2=Sqrt[Norma[D[curveR,t]]] (1/Norma[curveQ1] DcurveQ1-(curveQ1.DcurveQ1)1/Norma[curveQ1]^3 curveQ1);
DcurveQRM=tmp1+tmp2;

tabp=Table[i,{i,aa,bb,2/100}];
tabTh=Table[NIntegrate[-sig tor,{t,0,tabp[[i]]},WorkingPrecision->NAT-10],{i,1,Length[tabp]}];

tabRMFrame=Table[RMFrame/.{θ->tabTh[[i]],t->tabp[[i]]},{i,1,Length[tabTh]}];
tabCurve=Table[curveR/.{t->tabp[[kat]]},{kat,1,Length[tabp]}];

Print["Graph of rotation minimizing frame:"]
graf2=DrawGeneralFrameTab[tabRMFrame,tabCurve,1,{1,0,0},{0,1,0},{0,0,1}]

Print["(Subscript[σ, 0])(Subscript[τ, 0]) = ",-tor sig/.{t->0}]

Print["Adapted frame:"]
ClearAll[θ,CC]
theta=CC t;
AFrame={FFrame[[1]],Cos[θ]FFrame[[2]]+Sin[θ]FFrame[[3]],-Sin[θ]FFrame[[2]]+Cos[θ]FFrame[[3]]}/.{θ->theta};
DAFrame=D[AFrame,t];

MR=Transpose[AFrame];
DMR=Transpose[DAFrame];
curveQ1={1+MR[[1,1]]+MR[[2,2]]+MR[[3,3]],MR[[3,2]]-MR[[2,3]],MR[[1,3]]-MR[[3,1]],MR[[2,1]]-MR[[1,2]]};
DcurveQ1={DMR[[1,1]]+DMR[[2,2]]+DMR[[3,3]],DMR[[3,2]]-DMR[[2,3]],DMR[[1,3]]-DMR[[3,1]],DMR[[2,1]]-DMR[[1,2]]};
curveQA=Sqrt[Norma[D[curveR,t]]] (curveQ1/Norma[curveQ1]);

tmp1=D[Sqrt[Norma[D[curveR,t]]],t] (curveQ1/Norma[curveQ1]);
tmp2=Sqrt[Norma[D[curveR,t]]] (1/Norma[curveQ1] DcurveQ1-(curveQ1.DcurveQ1)1/Norma[curveQ1]^3 curveQ1);
DcurveQA=tmp1+tmp2;

tabp=Table[i,{i,aa,bb,2/100}];

tabAFrame=Table[AFrame/.{t->tabp[[i]]},{i,1,Length[tabp]}]/.{CC->-1/2};
tabCurve=Table[curveR/.{t->tabp[[kat]]},{kat,1,Length[tabp]}];

Print["Graph of adapted frame for θ(s)=-1/2s:"]
graf3=DrawGeneralFrameTab[tabAFrame,tabCurve,1,{1,0,0},{0,1,0},{0,0,1}]

omegaRMF=DRMFrame[[2]].RMFrame[[3]];
pom1=Norm[Table[omegaRMF/.{θ->tabTh[[i]],t->tabp[[i]]},{i,1,Length[tabTh]}]]

Show[{graf1,graf2,graf3}]

Print["One chosen polynomial segment "]
aa=3+3/4;
bb=4;
Print["Interval [a,b] = ",{aa,bb}]
Print["Chosen data: "]
th0=Quiet[NIntegrate[-sig tor,{t,aaZ,aa},WorkingPrecision->NAT]];
th1=Quiet[NIntegrate[-sig tor,{t,aaZ,bb},WorkingPrecision->NAT]];
Print["Chosen data: "]
P0a=curveR/.{t->aa};
P1a=curveR/.{t->bb};
U0a=curveQRM/.{t->aa,θ->th0}
U1a=curveQRM/.{t->bb,θ->th1}
V0a=DcurveQRM/.{t->aa,θ->th0}
V1a=DcurveQRM/.{t->bb,θ->th1}
If[Sign[U0a.U1a]<0,U1a=-U1a;V1a=-V1a]

Print["Set of diffenet values of ξ: "]
SetK=Join[Reverse[Table[8/(8+i),{i,1,8}]],Table[(i+8)/8,{i,0,8}]]

Print["We compute from this set the parameter ξ for which (Subscript[E, 1/2]) is minimal: "]
weight=1/2;
{ik,pom}=SelectKsi1[SetK,weight,P0a,P1a,U0a,U1a,V0a,V1a,NAT]
Print["Chosen ξ = ", ik]

izbKsi=1;
Print["Chosen ξ = ",izbKsi]
weight=1; (* weight for the functional E *)
Print["We compute the interpolant: "]
{sol,tabpol,tabKP,tabpolA,tabERF,tabE}=SepticPHInterpolant1[t,P0a,P1a,U0a,U1a,V0a,V1a,izbKsi,NAT];
Print["{(Subscript[E, len]),(Subscript[E, ω])} for all of the solutions: "]
tabE
If[Length[sol]≠0,
ind=1;
For[j=2,j<=Length[sol],j++,
(* we choose the interpolant with the smallest (Subscript[E, δ]) (with respect to given weight δ) *)
If[((1-weight)tabE[[j,1]]+weight tabE[[j,2]])<((1-weight)tabE[[ind,1]]+weight tabE[[ind,2]]),
ind=j;
];
];
];
pol7=tabpol[[ind]];
polA=tabpolA[[ind]];
KP=tabKP[[ind]];
ERFrame=tabERF[[ind]];
Print["(Subscript[E, 1/2]) = ", (1-weight)tabE[[ind,1]]+weight tabE[[ind,2]]]

VP=Right;
Show[{Graphics3D[{GrayLevel[0.4],PointSize[0.02],Point[KP],Dashed,Line[KP]}],ParametricPlot3D[curveR,{t,aa,bb},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[pol7,{t,0,1},PlotStyle->GrayLevel[0.4],PlotRange->All]},PlotRange->All,Boxed->False]

(* Let us draw the frame *)
FFi=ERFrame;
ff1=FFi[[1]];
ff2=FFi[[2]];
ff3=FFi[[3]];
kor=0.02;
vel=0.5;
(*g2=DrawGeneralFrame[ff1,ff2,ff3,pol7,t,0,1,kor,vel,{0.7,0,0},{0,0.7,0},{0,0,0.7}];*)
par=EqualParameters[polA,t,30];
g2=DrawGeneralFrame1[ff1,ff2,ff3,pol7,t,par,vel,{0.7,0,0},{0,0.7,0},{0,0,0.7},0.02,0.002];


Show[{g2,ParametricPlot3D[curveR,{t,aa,bb},PlotStyle->{RGBColor[{0,0,0}]}],ParametricPlot3D[pol7,{t,0,1},PlotStyle->GrayLevel[0.4]]},Boxed->False]

(* ------ spline ----------- *)

Print["Parameter segments: "]
tabA=Table[aa,{aa,0,5,1}]

Print["Table of chosen parameters ξ: "]
tabK=Table[1,{i,1,Length[tabA]}]

tabSpline={};
tabSplineA={};
tabSplineKP={};
tabSplineERF={};
tabSplineE={};
tabSplineRot={};
weight=1/2; (* chosen weight for the functional (Subscript[E, δ]) *)
ClearAll[t];
For[kk=1,kk≤Length[tabA]-1,kk++,
aa=tabA[[kk]];
bb=tabA[[kk+1]];
izbKsi=tabK[[kk]];
Print["Interval = ",{aa,bb}];
(* Chosen data: *)
th0=Quiet[NIntegrate[-sig tor,{t,aaZ,aa},WorkingPrecision->NAT]];
th1=Quiet[NIntegrate[-sig tor,{t,aaZ,bb},WorkingPrecision->NAT]];
P0a=curveR/.{t->aa};
P1a=curveR/.{t->bb};
U0a=curveQRM/.{t->aa,θ->th0};
U1a=curveQRM/.{t->bb,θ->th1};
V0a=DcurveQRM/.{t->aa,θ->th0};
V1a=DcurveQRM/.{t->bb,θ->th1};
(*
P0a=curveR/.{t->aa};
P1a=curveR/.{t->bb};
U0a=curveQ/.{t->aa};
U1a=curveQ/.{t->bb};
V0a=D[curveQ,t]/.{t->aa};
V1a=D[curveQ,t]/.{t->bb};*)
If[Sign[U0a.U1a]<0,U1a=-U1a;V1a=-V1a];
(* ------------- *)
{sol,tabpol,tabKP,tabpolA,tabERF,tabE}=SepticPHInterpolant1[t,P0a,P1a,U0a,U1a,V0a,V1a,izbKsi,NAT];
Print["Number of solutions: ",Length[sol]];
Print["Values of {(Subscript[E, len]),(Subscript[E, ω])}: ",tabE//MatrixForm];
If[Length[sol]≠0,
ind=1;
For[j=2,j<=Length[sol],j++,
(* we choose the interpolant with the smallest length and smallest w *)
If[((1-weight)tabE[[j,1]]+weight tabE[[j,2]])<((1-weight)tabE[[ind,1]]+weight tabE[[ind,2]]),
ind=j;
];
];
pol7=tabpol[[ind]];
pol7A=tabpolA[[ind]];
KP=tabKP[[ind]];
ERFrame=tabERF[[ind]];
(*Rotational axis: *)
WF=RotationAxis[ERFrame[[1]],ERFrame[[2]],ERFrame[[3]],t];
FunE=tabE[[ind]];
];
Print["\!\(\*SubscriptBox[\(E\), \(\(1/2\)\(\\ \)\)]\) = ", (1-weight)tabE[[ind,1]]+weight tabE[[ind,2]]];
tabSpline=Append[tabSpline,pol7];
tabSplineA=Append[tabSplineA,pol7A];
tabSplineKP=Append[tabSplineKP,KP];
tabSplineERF=Append[tabSplineERF,ERFrame];
tabSplineRot=Append[tabSplineRot,WF];
tabSplineE=Append[tabSplineE,FunE];
]

Print["Control polygons: "]
Show[{Table[Graphics3D[{GrayLevel[0.4],PointSize[0.01],Point[tabSplineKP[[i]]],Dashed,Line[tabSplineKP[[i]]]}],{i,1,Length[tabSplineKP]}]}]
Print["Curve and its PH spline interpolant: "]
Show[{ParametricPlot3D[curveR,{t,tabA[[1]],Last[tabA]},PlotStyle->{RGBColor[{0,0,0}]}],Table[ParametricPlot3D[tabSpline[[i]],{t,0,1},PlotStyle->GrayLevel[0.4],PlotRange->All],{i,1,Length[tabSpline]}]},PlotRange->All]

Print["Rotational axis: "]
tabSplinePar=Table[{},{i,1,Length[tabSplineA]}];
For[i=1,i≤Length[tabSplineA],i++,
tabSplinePar[[i]]=EqualParameters[tabSplineA[[i]],t,10];
]
Graphics3D[{Arrowheads[0.01],Flatten[Table[Table[Arrow[{tabSpline[[i]],tabSpline[[i]]+4tabSplineRot[[i]]/Norma[tabSplineRot[[i]]]}/.{t->tabSplinePar[[i,j]]}],{j,1,Length[tabSplinePar[[i]]]}],{i,1,Length[tabSpline]}]]}]

tabSplinePar=Table[{},{i,1,Length[tabSplineA]}];
tabSplinePar[[1]]=EqualParameters[tabSplineA[[1]],t,35];
For[i=2,i≤Length[tabSplineA],i++,
tabSplinePar[[i]]=EqualParameters[tabSplineA[[i]],t,50];
]

Show[{Table[DrawGeneralFrame1[tabSplineERF[[i,1]],tabSplineERF[[i,2]],tabSplineERF[[i,3]],tabSpline[[i]],t,tabSplinePar[[i]],1,{0.7,0,0},{0,0.7,0},{0,0,0.7},0.01,0.0008],{i,1,Length[tabSplineERF]}],Table[DrawGeneralFrame1[tabSplineERF[[i,1]],tabSplineERF[[i,2]],tabSplineERF[[i,3]],tabSpline[[i]],t,{0,1},1,{0,0,0},{0,0,0},{0,0,0},0.015,0.002],{i,1,Length[tabSplineERF]}],Table[ParametricPlot3D[tabSpline[[i]],{t,0,1},PlotStyle->GrayLevel[0.4],PlotRange->All],{i,1,Length[tabSpline]}]},Axes->True,BaseStyle->20]

Print["Motion of a cube: "]
tabSplinePar=Table[{},{i,1,Length[tabSplineA]}];
For[i=1,i≤Length[tabSplineA],i++,
tabSplinePar[[i]]=EqualParameters[tabSplineA[[i]],t,12];
]
vel=0.7;
Show[{Graphics3D[{Table[Table[DrawRB[vel Kocka,tabSpline[[ii]]/.{t->tabSplinePar[[ii,k]]},tabSplineA[[ii]]/.{t->tabSplinePar[[ii,k]]}],{k,1,Length[tabSplinePar[[ii]]]}],{ii,1,Length[tabSplineA]}]}],Graphics3D[{Table[Table[DrawRB1[vel Kocka,tabSpline[[ii]]/.{t->k},tabSplineA[[ii]]/.{t->k}],{k,0,1}],{ii,1,Length[tabSplineA]}]}]},ViewPoint->VP]