Hermite-Interpoláció

Adott:

X={x1,x2,...xn}
F={f1,f2,...,fn}
DF={df1,df2,...,dfn}

Adott n db különböző pont, (Subscript[x, 1])<(Subscript[x, 2])<…<(Subscript[x, n]) ((Subscript[x, j])∈ℝ) és n db függvényérték, (Subscript[f, 1]),(Subscript[f, 2]),…,(Subscript[f, n]) ((Subscript[f, j])∈ℝ) és n db merekség, (Subscript[df, 1]),(Subscript[df, 2]),…,(Subscript[df, n]) ((Subscript[df, j])∈ℝ). Keressünk egy olyan H polinomfüggvényt, melyre H[(Subscript[x, j])]=(Subscript[f, j]) és H' [(Subscript[x, j])]=(Subscript[df, j]).

(Underscript[∃!, H∈(Subscript[ℙ, 2n-1])])(Underscript[∀, j])H[(Subscript[x, j])]=(Subscript[f, j])∧H' [(Subscript[x, j])]=(Subscript[df, j]).

Mi a következő Hermite interpolációs probléma megoldása?
x0={1,2,3,4}
y0={1,2,4,3}
yd0={1,0,0,-1}

Ábrázoljuk az "adatokkal" a polinomot!
Oldjuk meg a feladatot a Mathematica függvénnyel!

A beépített Mathematica függvény

?InterpolatingPolynomial

InterpolatingPolynomial[{{1,{-1,1}},{3,{21,25}}},x]//Expand

x0={1,2,3,4};
y0={1,2,4,3};
yd0={1,0,0,-1};

hp=Expand[InterpolatingPolynomial[Transpose[{x0,Transpose[{y0,yd0}]}],x]]

Grafikon:

Plot[hp,{x,0,5},PlotRange->{-1,5},PlotStyle->Thickness[.005]]

Grafikon+pontok:

Plot[hp,{x,0,5},PlotRange->{-1,5},PlotStyle->{Thickness[.005],Black},Epilog->{Red,PointSize[.02],Map[Point[#]&,Transpose[{x0,y0}]]}]

grafikon+pontok+érintőegyenesek

L[{xx_,yy_,ydd_},var_]:=ydd(var-xx)+yy

L[{1,4,2},x]//Expand

ls=Map[L[#,x]&,Transpose[{x0,y0,yd0}]]

Plot[Evaluate[Prepend[ls,hp]],{x,0,5},PlotRange->{-1,5},PlotStyle->Prepend[Table[{Blue},{4}],{Thickness[.005],Black}],Epilog->{Red,PointSize[.02],Map[Point[#]&,Transpose[{x0,y0}]]}]

grafikon+pontok+érintőegyenes-szakaszok

Plot[hp,{x,0,5},PlotStyle->Black,Epilog->{RGBColor[1,0,0],PointSize[.02],Map[Point[#]&,Transpose[{x0,y0}]],RGBColor[0,0,1],Map[Line[{{#[[1]]-.5,#[[2]]-#[[3]].5},{#[[1]]+.5,#[[2]]+#[[3]].5}}]&,Transpose[{x0,y0,yd0}]]}]

A Hermite interpolációs polinomot ismét szukcesszív lineáris egyenletmegoldással keressük meg, lásd a Lagrange-problémánál lévő algoritmust!

A lépések sorrendje nem teljesen rögzített, de minden pontban  először a függvényértékre vonatkozó feltételt használjuk!

A Probléma tovább általánosítható. Ekkor néhány/minden pontban magasabbrendű deriváltak is adottak.

X={x1,x2}={1,3}
F={f1,f2}={-1,21}
DF={fd1,fd2}={21,25}

Adjuk meg a Hermite interpolációs polinomot!

Indulás a Taylor-polinomból

p1=-1+1(x-1)//Expand

p1 az x1-ben vett lineáris Taylor plinom, 'tudja', hogy p1[1]= - 1 és p1'[1]=1. Erre építkezünk tovább.
Vegyük észre, hogy a p2 polinomcsalád tetszőleges A esetén továbbra is tudja az első két feltételt, vagyis, hogy p2[1]=-1, p2'[1]=1.

p2=p1+A(x-1)(x-1)

Solve[(p2/.x->3)==21,A]

p2=p1+5(x-1)^2

p3=p2+A(x-1)^2(x-3)

Solve[(D[p3,x]/.x->3)==25,A]

p3=p2+1(x-1)^2(x-3)//Expand

Indulás a Lagrange-polinomból

A Lagrange polinomra is rá lehet építeni (más sorrend)!
Induljunk  a Lagrange polinomból:

p1=-1+11(x-1)

Expand[%]

p2=p1+A(x-1)(x-3)

Solve[(D[p2,x]/.x->1)==1,A]

p2=p1+5(x-1)(x-3)

p3=p2+A(x-1)^2(x-3)

Solve[(D[p3,x]/.x->3)==25,A]

p3=p2+1(x-1)^2(x-3)//Expand

A beépített Mathematica függvény

InterpolatingPolynomial[{{1,{-1,1}},{3,{21,25}}},x]//Expand

X={1,2,3,4,5};
Y={0,6,24,60,120};
P=Y[[1]];

Clear[LP];
LP[0]:=(P=Y[[1]]);
LP[n_]:=Module[{pl},pl=P+A Product[x-X[[j]],{j,1,n}];
P=pl/.Solve[(pl/.x->X[[n+1]])==Y[[n+1]],A][[1]];{pl,(pl/.x->X[[n+1]])==Y[[n+1]],Solve[(pl/.x->X[[n+1]])==Y[[n+1]],A][[1]],P,Expand[P]}]

Manipulate[TableForm[{{LP[n]}}],{n,0,4,1},SaveDefinitions->True]

InterpolatingPolynomial[{{1,{2,4}},{2,{32,79}},{3,{242,404}}},x]//Expand

p0=2;
p1=p0+A (x-1)

Solve[(D[p1,x]/.x->1)==4,A]

p1=p1/.A->4

p1/.x->1

D[p1,x]/.x->1

p2=p1+A (x-1) (x-1);

Solve[(p2/.x->2)==32,A]

p2=p2/.A->26

p3=p2+A (x-1)^2 (x-2);

Solve[(D[p3,x]/.x->2)==79,A]

p3=p3/.A->23

p4=p3+A (x-1)^2 (x-2)^2;

Solve[(p4/.x->3)==242,A]

p4=p4/.A->9

p5=p4+A (x-1)^2 (x-2)^2 (x-3);

Solve[(D[p5,x]/.x->3)==404,A]

p5=p5/.A->1//Expand

XH={1,2,3};
YH={2,32,242};
YDH={4,79,404};
PH=YH[[1]];

Clear[HP];
HP[0]:=(PH=YH[[1]]);
HP[n_?OddQ]:=Module[{pl},pl=PH+A Product[(x-XH[[j]])^2,{j,1,Floor[n/2]}] (x-XH[[Ceiling[n/2]]]);{pl,(D[pl,x]/.x->XH[[Ceiling[n/2]]])==YDH[[Ceiling[n/2]]],PH=pl/.Solve[(D[pl,x]/.x->XH[[Ceiling[n/2]]])==YDH[[Ceiling[n/2]]],A][[1]]}];
HP[n_?EvenQ]:=Module[{pl},pl=PH+A Product[(x-XH[[j]])^2,{j,1,n/2}];{pl,(pl/.(x->XH[[n/2+1]]))==YH[[n/2+1]],PH=pl/.Solve[(pl/.(x->XH[[n/2+1]]))==YH[[n/2+1]],A][[1]]}]

Manipulate[TableForm[{{HP[n]}}],{n,0,5,1},SaveDefinitions->True]

Adott: 
X={x1,x2,...xn}
Y={f1,f2,...,fn}
YD={df1,df2,...,dfn}

Keressünk olyan H∈ (Subscript[ℙ, 2 n - 1])  polinomot, melyre H[(Subscript[x, j])] =(Subscript[f, j])∧ H ' [(Subscript[x, j])]=(Subscript[df, j])
Megmutatjuk, hogy a differenciaséma értelemszerű általánosításával is dolgozhatunk.

A Hermite interpolációs polinomot ismét szukcesszív lineáris egyenletmegoldással keressük meg, lásd a Lagrange-problémánál lévő algoritmust!

p(1)=2, p'(1)=0, p(3)=0, p'(3)=1

azaz 
X={1,3}
Y={2,0}
YD={0,1}

InterpolatingPolynomial[{{1,{2,0}},{3,{0,1}}},x]

InterpolatingPolynomial[{{1,{2,0}},{3,{0,1}}},x]//Expand

Poliomfejlesztés és az ND háromszögtáblázat értelemszerű módosítása

Clear[p0,p1,p2,p3]

p0=2;

p1=p0+A(x-1)

Solve[(D[p1,x]/.x->1)==0,A]

p1=2+0(x-1)//Expand

p2=p1+A(x-1)(x-1)

Solve[(p2/.x->3)==0,A]

p2=p1+(-1/2)(x-1)^2

p3=p2+A(x-1)^2(x-3)

Solve[(D[p3,x]/.x->3)==1,A]

p3=p2+3/4(x-1)^2(x-3)

(Subscript[x, i]) (Subscript[f, i  ])          1 .      2.     3.

1    2  
               0   
1    2              -1/2
             -1                 3/4
3   0              1           
              1          
3   0