(*^ ::[ Information = "This is a Mathematica Notebook file. It contains ASCII text, and can be transferred by email, ftp, or other text-file transfer utility. It should be read or edited using a copy of Mathematica or MathReader. If you received this as email, use your mail application or copy/paste to save everything from the line containing (*^ down to the line containing ^*) into a plain text file. On some systems you may have to give the file a name ending with ".ma" to allow Mathematica to recognize it as a Notebook. The line below identifies what version of Mathematica created this file, but it can be opened using any other version as well."; FrontEndVersion = "Macintosh Mathematica Notebook Front End Version 2.2"; MacintoshStandardFontEncoding; fontset = title, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, e8, 24, "Times"; fontset = subtitle, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeTitle, center, M7, bold, e6, 18, "Times"; fontset = subsubtitle, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeTitle, center, M7, italic, e6, 14, "Times"; fontset = section, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, grayBox, M22, bold, a20, 18, "Times"; fontset = subsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, blackBox, M19, bold, a15, 14, "Times"; fontset = subsubsection, inactive, noPageBreakBelow, nohscroll, preserveAspect, groupLikeSection, whiteBox, M18, bold, a12, 12, "Times"; fontset = text, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; fontset = smalltext, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 10, "Times"; fontset = input, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeInput, M42, N23, bold, L-5, 12, "Courier"; fontset = output, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L-5, 12, "Courier"; fontset = message, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, R65535, L-5, 12, "Courier"; fontset = print, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, L-5, 12, "Courier"; fontset = info, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeOutput, M42, N23, B65535, L-5, 12, "Courier"; fontset = postscript, PostScript, formatAsPostScript, output, inactive, noPageBreakInGroup, nowordwrap, preserveAspect, groupLikeGraphics, M7, l34, w282, h287, 12, "Courier"; fontset = name, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, italic, 10, "Geneva"; fontset = header, inactive, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; fontset = leftheader, inactive, L2, 12, "Times"; fontset = footer, inactive, noKeepOnOnePage, preserveAspect, center, M7, 12, "Times"; fontset = leftfooter, inactive, L2, 12, "Times"; fontset = help, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 10, "Times"; fontset = clipboard, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; fontset = completions, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; fontset = special1, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; fontset = special2, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; fontset = special3, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; fontset = special4, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; fontset = special5, inactive, nohscroll, noKeepOnOnePage, preserveAspect, M7, 12, "Times"; paletteColors = 128; currentKernel; ] :[font = title; inactive; Cclosed; preserveAspect; startGroup] Approximation of Functions :[font = subtitle; inactive; preserveAspect] An interpretation based upon Theodore J. Rivilin's "An Introduction to the Approximation of Functions" :[font = subsubtitle; inactive; preserveAspect; endGroup] M.A. Lachance :[font = section; inactive; Cclosed; preserveAspect; startGroup] Norms in Euclidean space :[font = text; inactive; preserveAspect; startGroup] The p-norm of a vector v={v1,v2,...,vn} is the p-th root of the sum of the p-th powers of the absolute values of the components of the vector v,for 1<=p=0...this is easy ii) || c v || = |c| || v ||...this too is easy III) ||u + v || <= ||u|| + ||v|| ...this is tricky. It is called Minkowski's inequality, and requires Holder's inequality, which depends upon a (happily) simple geometric relationship ;[s] 5:0,0;228,1;237,0;265,1;271,0;347,-1; 2:3,13,9,Times,0,12,0,0,0;2,13,9,Times,1,12,0,0,0; :[font = text; inactive; preserveAspect; startGroup] INEQUALITY #1: If 1/p+1/q=1, then for any 0<=a,b, the inequality is valid: a^p/p + b^q/q>=a b This is easily seen geometrically (borrowed from Kolmogorov & Fomin) ;[s] 3:0,0;79,1;99,0;168,-1; 2:2,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] Below a random choice for p and q are made so that 1/+1/q=1. The curve y=x^(p-1) is plotted. :[font = input; wordwrap; preserveAspect; startGroup] Clear[a,b,x,y,p,q,f]; f[x_] := x^(p-1); g[y_] := y^(q-1); Print["p=",p = 1/Random[]," while q=", q = p/(p-1)]; 1/p+1/q==1 curve = Plot[f[x],{x,0,4}, AspectRatio->Automatic, PlotRange->{{0,4},{0,4}}] ;[s] 3:0,0;112,1;124,0;201,-1; 2:2,7,10,Courier,1,12,0,0,0;1,7,10,Courier,1,12,65535,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] a^(1/p) is the area under this curve on [0,a]; b^(1/q) is the area to the left of the curve on [0,b]. Random a and b values illustrate this point geometrically. :[font = input; wordwrap; preserveAspect; endGroup; endGroup; endGroup; endGroup] Print["If a = ",a = 1+ 3 Random[]," and b =", b = 1+ 3 Random[],","] Print["then the vertical area a^p/p = ",a^p/p," and"]; Print["the horizontal area b^q/q = ",b^q/q,"."] Print["These two areas sum to a value greater than ab = ",a b,"."] Show[curve, Table[Graphics[Line[{{x,0},{x,x^(p-1)}}]],{x,.00001,a,(a-.00001)/50}], Table[Graphics[Line[{{0,y},{y^(q-1),y}}]],{y,.00001,b,(b-.00001)/50}], Graphics[Line[Max[a,b,f[a],g[b]]{{1,0},{0,0},{0,1}}]], Graphics[Line[{{0,0},{0,b},{a,b},{a,0},{0,0}}]], Graphics[Text["a",{a,-.05}]], Graphics[Text["b",{-.05,b}]], Axes->False, AspectRatio->Automatic, PlotRange->{{-.1,1.1},{-.1,1.1}}Max[a,b,f[a],g[b]]] :[font = text; inactive; Cclosed; preserveAspect; startGroup] INEQUALITY #2: A consequence of this inequality is the following relating the p-norms for vectors || u v || <= || u || || v || , where 1/p+1/q=1 <-- Holder's inequality 1 p q ;[s] 3:0,0;166,1;185,0;226,-1; 2:2,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0; :[font = text; inactive; preserveAspect; endGroup] Assume that the p-norm of U=(U1,...,Un) and the q-norm of V=(V1,...,Vn) are both 1, and let a=|Uk| and b=|Vk| in the above inequality. Then |Uk Vk)| <=(1/p) |Uk|^p + (1/q) |Vk|^q. Summing over the index k we get sum |Uk Vk| <=(1/p)+(1/q) = 1 To get the general inequality, let U=u / || u || and V= v / || v || p q :[font = text; inactive; Cclosed; preserveAspect; startGroup] INEQUALITY #3: A consequence of this Holder's inequality is also the triangle inequality for p-norms: || u + v || <= || u || + || v || <--or Minkowski's inequality p p p ;[s] 5:0,0;65,1;100,0;157,1;179,0;241,-1; 2:3,13,9,Times,0,12,0,0,0;2,13,9,Times,1,12,0,0,0; :[font = text; inactive; preserveAspect; endGroup; endGroup] Assume uk,vk>0. Then |uk+vk|^p <= |uk|*|uk+vk|^(p-1)+|vk|*|uk+vk|^(p-1) || u+v ||^p <= ( ||u|| + ||v|| ) ( sum |uk+vk|^(p-1)q )^(1/q) by Holder's inequality p p p but |uk+vk|^(p-1)q = |uk+vk|^p, which implies that ( sum |uk+vk|^(p-1)q )^(1/q) = ( || u+v ||^p )^(1/q) = ( || u+v ||^p )^(1-1/p) p p Thus || u+v ||^p <= ( ||u|| + ||v|| ) ( || u+v ||^p )/ || u+v || which is the result we want. p p p p p :[font = text; inactive; Cclosed; preserveAspect; startGroup] Properties of p-norms :[font = text; inactive; preserveAspect] For 1 Automatic] :[font = text; inactive; Cclosed; preserveAspect; startGroup] EX: plot several two-dimensional balls simultaneously for different values of p. :[font = input; wordwrap; preserveAspect; endGroup] Show[Ball2D[.5], Ball2D[1], Ball2D[1.5]] :[font = text; inactive; preserveAspect; endGroup] * Use the Show[ ] command to plot several two-dimensional balls simultaneously for different values of p>=1. ;[s] 3:0,0;10,1;17,0;109,-1; 2:2,13,9,Times,0,12,0,0,0;1,15,11,MT,1,12,0,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] The unit ball in 3D ;[s] 3:0,0;4,1;13,0;20,-1; 2:2,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0; :[font = input; wordwrap; preserveAspect] Clear[Ball3D, pts, p]; p = .5; m = 20; n = 20; (* Generate rectangular array of ordered triples*) pts = Table[ Table[{x, y, Abs[1 - Abs[x]^p - Abs[y]^p]^(1/p)}, {y, -Abs[1 - Abs[x]^p]^(1/p), Abs[1 - Abs[x]^p]^(1/p), 2Abs[1 - Abs[x]^p]^(1/p)/m}], {x, -.99999, .99999, 1.99998/n}]; pts = Join[pts, Table[Table[ {x,y, -Abs[1 - Abs[x]^p - Abs[y]^p]^(1/p)}, {y, -Abs[1 - Abs[x]^p]^(1/p), Abs[1 -Abs[x]^p]^(1/p), 2Abs[1 - Abs[x]^p]^(1/p)/m}], {x, -.99999, .99999, 1.99998/n}]]; (* Define collection of polygons joing triples *) Ball3D = Table[Table[Graphics3D[Polygon[ {pts[[i1, j1]], pts[[i1, j1 + 1]], pts[[i1 + 1, j1 + 1]], pts[[i1 + 1, j1]]}]], {i1, Length[pts] - 1}], {j1, Length[pts[[1]]] - 1}]; :[font = input; wordwrap; preserveAspect] Show[Ball3D, PlotRange -> {{-1.01, 1.01}, {-1.01, 1.01}, {-1.01, 1.01}}] :[font = text; inactive; preserveAspect; endGroup; endGroup] * Plot several three-dimensional balls on different graphs for different values of p=.5,1,2,4,8. :[font = section; inactive; Cclosed; preserveAspect; startGroup] Norms in C[a,b] :[font = text; inactive; Cclosed; preserveAspect; startGroup] The p-norm of a function f={f[a],...,f[x],...,f[b]} is the p-th root of the sum of the p-th powers of the absolute values of the components of the vector v,for 1<=p=0...this is easy ii) || c f || = |c| || f ||...this too is easy III) ||f + g || <= ||f|| + ||g|| ...this follows the argument for the norm of vectors, replacing Uk with F(x), and integrating over x instead of summing over k. :[font = text; inactive; preserveAspect] * Compare the values of || f || using p=2 and using p=Infinity, where f[x] = Exp[-n x^2] as n becomes large. One implication of this example is that the p-norms in C[a,b] are not equivalent. ;[s] 3:0,0;153,1;189,0;191,-1; 2:2,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] When p=1, the p-norm is not strictly convex for C[a,b] :[font = input; wordwrap; preserveAspect; endGroup] Clear[f, g, h, x, p]; f[x_] := 3/4(1 - x^2) g[x_] := 3/2x^2; h[x_] := (f[x] + g[x])/2; p = 1; funcNorm[f, p, 0, 1] funcNorm[g, p, 0, 1] funcNorm[h, p, 0, 1] :[font = text; inactive; Cclosed; preserveAspect; startGroup] When p=Infinity, the p-norm is not strictly convex for C[a,b] :[font = input; wordwrap; preserveAspect; endGroup; endGroup] Clear[f, g, h, x, p]; f[x_] := x g[x_] := x^2 h[x_] := (f[x] + g[x])/2; p = Infinity; funcNorm[f, p, 0, 1] funcNorm[g, p, 0, 1] funcNorm[h, p, 0, 1] :[font = section; inactive; Cclosed; preserveAspect; startGroup] Bernstein polynomials and operator :[font = text; inactive; Cclosed; preserveAspect; startGroup] The Bernstein polynomials are the summands of the binomial expansion of (x+(1-x))^n. There are n+1 of them for each degree n, n=1,2,.... Clearly, they sum to 1, and on the interval [0,1] they are all nonnegative. Any set of numbers {a0,a1,...,an} that are nonnegative and sum to 1 for what is called a partition of unity. ;[s] 5:0,0;4,2;25,0;307,1;325,0;327,-1; 3:3,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0;1,15,11,MT,1,12,0,0,0; :[font = input; wordwrap; preserveAspect] Clear[BernPol]; BernPol[n_,k_,x_] := Binomial[n,k] x^k (1-x)^(n-k); :[font = text; inactive; Cclosed; preserveAspect; startGroup] * Plot several Bernstein polynomials (of the same degee) in the same graph. :[font = input; wordwrap; preserveAspect; endGroup; endGroup] Plot[{ BernPol[3,0,x], BernPol[3,1,x], BernPol[3,2,x], BernPol[3,3,x]}, {x,.000001,.99999}, PlotStyle->{RGBColor[1, 0, 0], RGBColor[1, 1, 0], RGBColor[0, 1, 1],RGBColor[0,0,1]}, PlotRange->{0,1}, AspectRatio->Automatic] :[font = text; inactive; Cclosed; preserveAspect; startGroup] The Bernstein operator is an n-th degree polynomial approximation of a function f[x],on the interval[0,1]. The Bernstein approximate BernOp[f,n,x] of f[x] enjoys a number of properties: 1) BernOp[1,n,x]=1 2) BernOp[x,n,x]=x 3) BernOp[x^2,n,x]=x^2+x(1-x)/n 4) BernOp[alpha f,n,x]=alpha BernOp[f,n,x] <--- BernOp is homogeneous 5) BernOp[f+g,n,x]=BernOp[f,n,x]+BernOp[g,n,x] <--- BernOp is additive 6) BernOp[f,n,x] <=BernOp[g,n,x] if f[x]<=g[x] <--- BernOp is montone ;[s] 8:0,0;4,1;22,0;331,1;342,0;409,1;417,0;485,1;493,-1; 2:4,13,9,Times,0,12,0,0,0;4,13,9,Times,1,12,0,0,0; :[font = input; wordwrap; preserveAspect] Clear[BernOp]; BernOp[f_, n_, x_] := Sum[f[k/n] BernPol[n, k, x], {k, 0, n}]; :[font = text; inactive; Cclosed; preserveAspect; startGroup] The Bernstein operator provides a constructive proof of the... Weierstrass Approximation Theorem: There exists a sequence of polynomials which converge uniformly to any continuous function on the interval [0,1]. ;[s] 3:0,0;64,1;97,0;213,-1; 2:2,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] EX: Plot f[x_]:=Exp[-x] and define BernOp[f,n,x] on [0,1]. Plot coefficients of Bernstein polynomials, a.k.a. "control points". :[font = input; wordwrap; preserveAspect; endGroup; endGroup] Clear[fx]; f[x_] := Exp[-x]; n=3; BernOp[f,n,x] N[Expand[BernOp[f,n,x]]] Plot[ {f[x],BernOp[f,n,x]}, {x,.00001,.99999}, PlotStyle->{Dashing[{1,0}],Dashing[{.02,.02}]}, Prolog->{PointSize[.02], Table[Point[{k/n,f[k/n]}],{k,0,n}]} ] :[font = text; inactive; Cclosed; preserveAspect; startGroup] EX: The polynomial approximates generated by the Bernstein operator converge very slowly to their target function. A good test function to illustrate this slow performance is f[x_]:=|x-.5 | and define h[x_]:=BernOp[f,n,x]-f[x] on [0,1]. ;[s] 3:0,0;124,1;137,0;240,-1; 2:2,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0; :[font = input; wordwrap; preserveAspect; endGroup] Clear[f, g, h, x]; n=50; f[x_] := Abs[x - .5]; g[x_] := N[BernOp[f, n, x]] h[x_] := g[x] - f[x] Plot[{f[x], g[x]}, {x, .0001, .9999}, PlotRange -> {0, .5}] Plot[{h[x], (x - .5) + h[.5]}, {x, .0001, .9999}, PlotRange -> {0, 2h[.5]}] :[font = text; inactive; preserveAspect; endGroup] * Plot several Bernstein approximates of f[x]=Sin[2 Pi x] above, as n increases. * Verify that 1) BernOp[1,n,x]=1 2) BernOp[x,n,x]=x 3) BernOp[x^2,n,x]=x^2+x(1-x)/n 4) BernOp[alpha f,n,x]=alpha BernOp[f,n,x] <--- BernOp is homogeneous 5) BernOp[f+g,n,x]=BernOp[f,n,x]+BernOp[g,n,x] <--- BernOp is additive 6) BernOp[f,n,x] <=BernOp[g,n,x] if f[x]<=g[x] <--- BernOp is montone * Choose pairs of functions f[x] and g[x] which satisfy f[x]<=g[x] on [0,1]. Verify that BernOp[f,n,x] <=BernOp[g,n,x] for some specific n. ;[s] 7:0,0;240,1;251,0;318,1;326,0;394,1;406,0;551,-1; 2:4,13,9,Times,0,12,0,0,0;3,13,9,Times,1,12,0,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] Verifying inequality (by example): -e-2M(x-y)^2/d^2 <= h(x)-h(y) <= e+2M(x-y)^2/d^2 :[font = input; wordwrap; preserveAspect] Clear[w,x,y,delta,a,b, x]; a = 0; b = 1; h[x_] := N[Exp[-x]]; M = funcNorm[h, Infinity, a, b] (* The following function is the modulus of continuity, which is discussed in more detail in the next section. It is used to get a uniform delta. *) w[f_,delta_,a_,b_] := Max[Table[Table[ Abs[N[f[x]-f[y]]], {x,Max[a,y-delta],Min[b,y+delta], (Min[b,y+delta]-Max[a,y-delta])/20}], {y,a,b,delta}]] ep = .1; delta = d /. FindRoot[w[h,d,a,b] == .9 ep, {d,.0001,ep}] upperBound[x_, y_] := ep + 2 M (x - y)^2/delta^2 ;[s] 5:0,0;129,1;150,0;228,1;241,0;512,-1; 2:3,12,10,Courier,1,12,0,0,0;2,12,10,Courier,1,12,65535,0,0; :[font = input; wordwrap; preserveAspect] top = Plot3D[upperBound[s, t], {s, 0, 1}, {t, 0, 1}] middle = Plot3D[h[s] - h[t], {s, 0, 1}, {t, 0, 1}, PlotPoints -> {20, 20}] bottom = Plot3D[-upperBound[s, t], {s, 0, 1}, {t, 0, 1}] combined=Show[top, middle, bottom, PlotRange -> {-2M/delta^2, 2M/delta^2}] :[font = text; inactive; Cclosed; preserveAspect; startGroup] Consider slices through the three surfaces :[font = input; wordwrap; preserveAspect; endGroup; endGroup; endGroup] t = .35; Show[combined,Graphics3D[Polygon[{ {0,t,2M/delta^2}, {1,t,2M/delta^2}, {1,t,-2M/delta^2}, {0,t,-2M/delta^2}}]]] Plot[{h[s] - h[t], -upperBound[s, t], upperBound[s, t]}, {s, 0, 1}, PlotRange -> {-2M/delta^2, 2M/delta^2}, Axes -> False] :[font = section; inactive; Cclosed; preserveAspect; startGroup] Modulus of continuity :[font = text; inactive; Cclosed; preserveAspect; startGroup] The modulus of continuity: w[f,d,a,b]=max{ | f[x]-f[y] |, x in [a,b], d>0, |x-y| < d} It measures the maximum deviation in the values f[x] and f[y] for x,y pairs within d of each other. w[d] (for short) satisfies w[n d]<=(1+n) w[d], for n>0. ;[s] 3:0,0;4,1;25,0;251,-1; 2:2,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] Following is an empirical version of w[d]... :[font = input; wordwrap; preserveAspect; endGroup] Clear[w,x,y,delta,a,b]; w[f_,delta_,a_,b_] := Max[Table[Table[ Abs[N[f[x]-f[y]]], {x,Max[a,y-delta],Min[b,y+delta], (Min[b,y+delta]-Max[a,y-delta])/20}], {y,a,b,delta/2}]] :[font = text; inactive; Cclosed; preserveAspect; startGroup] EX: w[f,d,a,b] for f[x_]:=Sin[2 Pi x] :[font = input; wordwrap; preserveAspect; endGroup] Clear[f, x]; f[x_] := Sin[2 Pi x]; delta=.001; w[f,delta,0,1] :[font = text; inactive; Cclosed; preserveAspect; startGroup] a f(x) = |x| , for 0Automatic] :[font = text; inactive; preserveAspect; endGroup] * Determine the modulus of continuity for nonuniformly continuous f[x_] := 1/x on [ep,1], for ep>0. * Determine the modulus of continuity for rapdily oscillating Sin[1/x] on [ep,1], where ep gets closer and closer to zero. * Determine the modulus of continuity for the discontinuous f[x_]:=If[x<.5,0,1]. * Relate the derivative of f[x] to w[f,d,a,b]/d as d->0 *Verify the inequality @òo¹Îù„÷V’¹úµÂ–òo÷r@ality empirically w[n d]¾(1+n) w[d],for n>0 for a variety ;[s] 7:0,0;42,1;65,0;143,1;162,0;271,1;284,0;466,-1; 2:4,13,9,Times,0,12,0,0,0;3,13,9,Times,1,12,0,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] The d=delta value that satisfies w[delta]=.99 epsilon is a uniform delta for the definition of uniform continuity. That is, if |x-y| {Dashing[{1, 0}], Dashing[{.02, .02}]}, PlotRange -> {-1, 1}] M = funcNorm[h, Infinity, .00001, .9999]; Plot[{h[x]}, {x, .0001, .9999}, PlotRange -> {-M, M}] :[font = text; inactive; preserveAspect; endGroup; endGroup] * Switch f to a function like Sin[n Pi x] and see what effect it has on how large one needs to choose n :[font = text; inactive; Cclosed; preserveAspect; startGroup] Special case: f[x_] := Abs[x-.5] shows that || f - BernOp[f,n] || = Binomial[n,n/2]/2^(n+1). Asymptotically the error || f - BernOp[f,n] || behaves like 1/2/sqrt[n]. Consequently, Bernstein polynomials do an ineffective job. Let f[x_]:=|x-.5| on [0,1],and define h[x_]:=BernOp[f,n,x]-f[x]. ;[s] 2:0,1;12,0;293,-1; 2:1,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0; :[font = input; wordwrap; preserveAspect] Clear[f, g, h, x]; n = 20; f[x_] := Abs[x - 1/2]; g[x_] := N[BernOp[f, n, x]] h[x_] := g[x] - f[x] 1/3/Sqrt[1.n] < funcNorm[h, Infinity, .00001, .99999] funcNorm[h, Infinity, .00001, .99999] < 3/2 w[f, 1./Sqrt[n], .00001, .99999] ;[s] 4:0,0;101,1;155,0;156,1;238,-1; 2:2,12,10,Courier,1,12,0,0,0;2,12,10,Courier,1,12,65535,0,0; :[font = input; wordwrap; preserveAspect] Plot[{f[x], g[x]}, {x, .0001, .9999}, PlotStyle -> {Dashing[{1, 0}], Dashing[{.02, .02}]}, PlotRange -> {0, .5}] Plot[{h[x]}, {x, .0001, .9999}, PlotRange -> {0, g[.5]}] :[font = input; preserveAspect] hide = DisplayFunction->Identity unhide = DisplayFunction->$DisplayFunction :[font = input; wordwrap; preserveAspect; endGroup; endGroup] Show[ ListPlot[Table[{k,Binomial[k,k/2]/2^k/2},{k,2,40,2}], PlotJoined->True,PlotRange->{0,1},hide], ListPlot[Table[{k,1/2/Sqrt[k]},{k,2,40,2}], PlotJoined->True,PlotRange->{0,1}, PlotStyle->{AbsoluteThickness[2]},hide], unhide] :[font = section; inactive; Cclosed; preserveAspect; startGroup] Chebyshev polynomials :[font = text; inactive; Cclosed; preserveAspect; startGroup] The trigonometric identity Cos[2a] + Cos[2b] = 2 Cos[a-b] Cos[a+b] leads to Cos[(k+1)t] + Cos[(k-1)t] = 2 Cos[t] Cos[k t] . Let T[k,Cos[t]] = Cos[kt], and let x=Cos[t]. Then i) If k=0 implies that T[0,x]=1; ii) If k=1 implies that T[1,x]=x; Using the trig identity above, T[k,x]= 2 x T[k-1,x] - T[k-2,x] iii) If k=2 implies that T[2,x]=(2x)(x)-1 = 2x^2-1; iv) If k=3 implies that T[3,x]=(2x)( 2x^2-1)-(x) = 4x^3-3x; iii) If k=2 implies that T[4,x]=(2x)( 4x^3-3x)-(2x^2-1)= 8x^4-8x^2+1; and in general T[k t] = ChebyshevT[k,Cos[t]] <-- the k-th degree Chebyshev polynomials of the first kind ;[s] 8:0,0;640,1;669,0;784,1;805,0;913,1;923,0;925,1;1014,-1; 2:4,13,9,Times,0,12,0,0,0;4,13,9,Times,1,12,0,0,0; :[font = input; wordwrap; preserveAspect] ChebyshevT[0,x] ChebyshevT[1,x] ChebyshevT[2,x] ChebyshevT[3,x] ChebyshevT[4,x] Expand[ChebyshevT[5,Cos[t]]-Cos[5 t], Trig->True] :[font = input; wordwrap; preserveAspect; endGroup] Plot[{ ChebyshevT[0,x], ChebyshevT[1,x], ChebyshevT[2,x], ChebyshevT[3,x], ChebyshevT[4,x]},{x,-1,1}, AspectRatio->Automatic] :[font = text; inactive; Cclosed; preserveAspect; startGroup] The trigonometric identity Sin[2a] + Sin[2b] = 2 Cos[a-b] Sin[a+b] leads to Sin[(k+1)t] + Sin[(k-1)t] = 2 Cos[t] Sin[k t] . dividing by Sin[t], Sin[(k+1)t] = 2 Cos[t] Sin[k t] - Sin[(k-1)t] ------------ -------- ----------- Sin[t] Sin[t] Sin[t] Let U[k,Cos[t]] = Sin[(k+1)t]/Sin[t], and let x=Cos[t]. Then i) If k=0 implies that U[0,x]=1; ii) If k=1 implies that U[1,x]=2 x; Using the trig identity above, U[k,x]= 2 x U[k-1,x] - U[k-2,x] iii) If k=2 implies that U[2,x]=(2x)(2x)-1 = 4x^2-1; iv) If k=3 implies that U[3,x]=(2x)( 4x^2-1)-(2x) = 8x^3-4x; iii) If k=2 implies that U[4,x]=(2x)(8x^3-4x)-( 4x^2-1)= 16x^4-12x^2+1; and in general U[k t] = ChebyshevU[k,Cos[t]] <-- the k-th degree Chebyshev polynomials of the second kind ;[s] 8:0,0;936,1;965,0;1080,1;1101,0;1209,1;1220,0;1222,1;1312,-1; 2:4,13,9,Times,0,12,0,0,0;4,13,9,Times,1,12,0,0,0; :[font = input; wordwrap; preserveAspect] ChebyshevU[0,x] ChebyshevU[1,x] ChebyshevU[2,x] ChebyshevU[3,x] ChebyshevU[4,x] Expand[Sin[t]ChebyshevU[4,Cos[t]]-Sin[5 t], Trig->True] :[font = input; wordwrap; preserveAspect] Plot[{ ChebyshevU[0,x], ChebyshevU[1,x], ChebyshevU[2,x], ChebyshevU[3,x], ChebyshevU[4,x]},{x,-1,1}, AspectRatio->Automatic] :[font = text; inactive; preserveAspect; endGroup] * Since Sin[t]*ChebyshevU[k,Cos[t]] is equioscillatory, ChebyshevU[k,x] oscillates back and forth between +1/sqrt(1-x^2) and -1/sqrt(1-x^2). Plot a few ChebyshevU[k,x] o together with +1/sqrt(1-x^2) and -1/sqrt(1-x^2). :[font = text; inactive; preserveAspect] The Dirichlet kernel is defined to be Sin[(N+1/2)x] ----------------- = 1/2 + sum Cos[k x] 2 Sin[x/2] k=1...N Said another way .5*Sin[(N+1/2)x] = Sin[x/2]*( 1/2 + sum Cos[k x] ) k=1...N * Verify this identity for various N by plotting the difference Let x = 2Cos[t] to get ChebyshevU[2N,t] = 1+ sum 2*ChebyshevT[2k,t] k=1...N * Verify this identity for various N by plotting the difference ;[s] 3:0,0;4,1;20,0;708,-1; 2:2,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] The Chebyshev polynomials and their derivatives form are the steepest growing possible outside the interval [-1,1]. :[font = input; preserveAspect] n=4; :[font = text; inactive; Cclosed; preserveAspect; startGroup] Preliminaries :[font = input; preserveAspect] Clear[funcNorm]; funcNorm[f_, p_, a_, b_] := If[p == Infinity, Max[Table[Abs[f[x]], {x, a, b, (b - a).001}]], NIntegrate[Abs[f[x]]^p, {x, a, b}]^(1/p)] :[font = input; preserveAspect; endGroup] Clear[T]; T[x_] := ChebyshevT[n,x]; Envelope1[x_] := If[Abs[x]>1,Abs[T[x]],T[1]] Envelope2[x_] := If[Abs[x]>1,Abs[T'[x]],T'[1]] Envelope3[x_] := If[Abs[x]>1,Abs[T''[x]],T''[1]] pic1=Plot[{Envelope1[x],-Envelope1[x]},{x,-2,2}, PlotStyle->AbsoluteThickness[2]] pic2=Plot[{Envelope2[x],-Envelope2[x]},{x,-2,2}, PlotStyle->AbsoluteThickness[2]] pic3=Plot[{Envelope3[x],-Envelope3[x]},{x,-2,2}, PlotStyle->AbsoluteThickness[2]] :[font = text; inactive; Cclosed; preserveAspect; startGroup] Generate a random polynomial p with norm ||p||=1, and plot with envelopes :[font = input; preserveAspect; startGroup] Clear[p]; coef = 2 Table[Random[],{n+1}]-1; p[x_]:= coef[[1]]+Sum[coef[[i1+1]] x^i1,{i1,n}] M = funcNorm[p,Infinity,-1,1]; P[x_] := p[x]/M; :[font = text; inactive; Cclosed; preserveAspect; startGroup] Grunt work :[font = input; preserveAspect; startGroup] pic4=Plot[P[x],{x,-2,2}] pic5=Plot[P'[x],{x,-2,2}] pic6=Plot[P''[x],{x,-2,2}] :[font = postscript; PostScript; formatAsPostScript; output; inactive; preserveAspect; pictureLeft = 34; pictureWidth = 282; pictureHeight = 174] %! %%Creator: Mathematica %%AspectRatio: .61803 MathPictureStart %% Graphics /Courier findfont 10 scalefont setfont % Scaling calculations 0.5 0.238095 0.100869 0.086156 [ [(-2)] .02381 .10087 0 2 Msboxa [(-1)] .2619 .10087 0 2 Msboxa [(1)] .7381 .10087 0 2 Msboxa [(2)] .97619 .10087 0 2 Msboxa [(-1)] .4875 .01471 1 0 Msboxa [(1)] .4875 .18703 1 0 Msboxa [(2)] .4875 .27318 1 0 Msboxa [(3)] .4875 .35934 1 0 Msboxa [(4)] .4875 .44549 1 0 Msboxa [(5)] .4875 .53165 1 0 Msboxa [(6)] .4875 .61781 1 0 Msboxa [ -0.001 -0.001 0 0 ] [ 1.001 .61903 0 0 ] ] MathScale % Start of Graphics 1 setlinecap 1 setlinejoin newpath [ ] 0 setdash 0 g p p .002 w .02381 .10087 m .02381 .10712 L s P [(-2)] .02381 .10087 0 2 Mshowa p .002 w .2619 .10087 m .2619 .10712 L s P [(-1)] .2619 .10087 0 2 Mshowa p .002 w .7381 .10087 m .7381 .10712 L s P [(1)] .7381 .10087 0 2 Mshowa p .002 w .97619 .10087 m .97619 .10712 L s P [(2)] .97619 .10087 0 2 Mshowa p .001 w .07143 .10087 m .07143 .10462 L s P p .001 w .11905 .10087 m .11905 .10462 L s P p .001 w .16667 .10087 m .16667 .10462 L s P p .001 w .21429 .10087 m .21429 .10462 L s P p .001 w .30952 .10087 m .30952 .10462 L s P p .001 w .35714 .10087 m .35714 .10462 L s P p .001 w .40476 .10087 m .40476 .10462 L s P p .001 w .45238 .10087 m .45238 .10462 L s P p .001 w .54762 .10087 m .54762 .10462 L s P p .001 w .59524 .10087 m .59524 .10462 L s P p .001 w .64286 .10087 m .64286 .10462 L s P p .001 w .69048 .10087 m .69048 .10462 L s P p .001 w .78571 .10087 m .78571 .10462 L s P p .001 w .83333 .10087 m .83333 .10462 L s P p .001 w .88095 .10087 m .88095 .10462 L s P p .001 w .92857 .10087 m .92857 .10462 L s P p .002 w 0 .10087 m 1 .10087 L s P p .002 w .5 .01471 m .50625 .01471 L s P [(-1)] .4875 .01471 1 0 Mshowa p .002 w .5 .18703 m .50625 .18703 L s P [(1)] .4875 .18703 1 0 Mshowa p .002 w .5 .27318 m .50625 .27318 L s P [(2)] .4875 .27318 1 0 Mshowa p .002 w .5 .35934 m .50625 .35934 L s P [(3)] .4875 .35934 1 0 Mshowa p .002 w .5 .44549 m .50625 .44549 L s P [(4)] .4875 .44549 1 0 Mshowa p .002 w .5 .53165 m .50625 .53165 L s P [(5)] .4875 .53165 1 0 Mshowa p .002 w .5 .61781 m .50625 .61781 L s P [(6)] .4875 .61781 1 0 Mshowa p .001 w .5 .03194 m .50375 .03194 L s P p .001 w .5 .04918 m .50375 .04918 L s P p .001 w .5 .06641 m .50375 .06641 L s P p .001 w .5 .08364 m .50375 .08364 L s P p .001 w .5 .1181 m .50375 .1181 L s P p .001 w .5 .13533 m .50375 .13533 L s P p .001 w .5 .15256 m .50375 .15256 L s P p .001 w .5 .16979 m .50375 .16979 L s P p .001 w .5 .20426 m .50375 .20426 L s P p .001 w .5 .22149 m .50375 .22149 L s P p .001 w .5 .23872 m .50375 .23872 L s P p .001 w .5 .25595 m .50375 .25595 L s P p .001 w .5 .29041 m .50375 .29041 L s P p .001 w .5 .30764 m .50375 .30764 L s P p .001 w .5 .32487 m .50375 .32487 L s P p .001 w .5 .34211 m .50375 .34211 L s P p .001 w .5 .37657 m .50375 .37657 L s P p .001 w .5 .3938 m .50375 .3938 L s P p .001 w .5 .41103 m .50375 .41103 L s P p .001 w .5 .42826 m .50375 .42826 L s P p .001 w .5 .46272 m .50375 .46272 L s P p .001 w .5 .47996 m .50375 .47996 L s P p .001 w .5 .49719 m .50375 .49719 L s P p .001 w .5 .51442 m .50375 .51442 L s P p .001 w .5 .54888 m .50375 .54888 L s P p .001 w .5 .56611 m .50375 .56611 L s P p .001 w .5 .58334 m .50375 .58334 L s P p .001 w .5 .60057 m .50375 .60057 L s P p .002 w .5 0 m .5 .61803 L s P P 0 0 m 1 0 L 1 .61803 L 0 .61803 L closepath clip newpath p p .004 w s s s s s s s s .21537 .61803 m .22222 .5258 L s .22222 .5258 m .24206 .32746 L .25198 .25065 L .2619 .18703 L .27183 .13537 L .28175 .09452 L .29167 .06334 L .29663 .05105 L .30159 .04077 L .30655 .03239 L .31151 .02578 L .31399 .02311 L .31647 .02083 L .31895 .01893 L .32143 .01741 L .32391 .01623 L .32515 .01578 L .32639 .0154 L .32763 .01511 L .32887 .0149 L .33011 .01477 L .33135 .01472 L .33259 .01473 L .33383 .01483 L .33507 .01499 L .33631 .01523 L .33755 .01553 L .33879 .0159 L .34127 .01684 L .34623 .01945 L .35119 .02296 L .36111 .0323 L .38095 .05779 L .42063 .11895 L .44048 .14664 L .4504 .15841 L .46032 .16841 L .47024 .17642 L .4752 .17963 L .48016 .18227 L .48512 .18434 L .4876 .18516 L .49008 .18583 L .49256 .18635 L .4938 .18656 L .49504 .18673 L .49628 .18686 L .49752 .18695 L .49876 .18701 L .5 .18703 L Mistroke .50124 .18701 L .50248 .18695 L .50372 .18686 L .50496 .18673 L .5062 .18656 L .50744 .18635 L .50992 .18583 L .5124 .18516 L .51488 .18434 L .51984 .18227 L .52976 .17642 L .53968 .16841 L .55952 .14664 L .57937 .11895 L .59921 .08814 L .61905 .05779 L .62897 .04413 L .63889 .0323 L .64385 .02727 L .64881 .02296 L .65377 .01945 L .65625 .01803 L .65873 .01684 L .66121 .0159 L .66245 .01553 L .66369 .01523 L .66493 .01499 L .66617 .01483 L .66741 .01473 L .66865 .01472 L .66989 .01477 L .67113 .0149 L .67237 .01511 L .67361 .0154 L .67609 .01623 L .67857 .01741 L .68105 .01893 L .68353 .02083 L .68849 .02578 L .69345 .03239 L .69841 .04077 L .70833 .06334 L .71825 .09452 L .72817 .13537 L .7381 .18703 L .75794 .32746 L .77778 .5258 L Mfstroke .78463 .61803 m .77778 .5258 L s s s s s s s s P P % End of Graphics MathPictureEnd :[font = output; output; inactive; preserveAspect] Graphics["<<>>"] ;[o] -Graphics- :[font = postscript; PostScript; formatAsPostScript; output; inactive; preserveAspect; pictureLeft = 34; pictureWidth = 282; pictureHeight = 174] %! %%Creator: Mathematica %%AspectRatio: .61803 MathPictureStart %% Graphics /Courier findfont 10 scalefont setfont % Scaling calculations 0.5 0.238095 0.309029 0.0169218 [ [(-2)] .02381 .30903 0 2 Msboxa [(-1)] .2619 .30903 0 2 Msboxa [(1)] .7381 .30903 0 2 Msboxa [(2)] .97619 .30903 0 2 Msboxa [(-15)] .4875 .0552 1 0 Msboxa [(-10)] .4875 .13981 1 0 Msboxa [(-5)] .4875 .22442 1 0 Msboxa [(5)] .4875 .39364 1 0 Msboxa [(10)] .4875 .47825 1 0 Msboxa [(15)] .4875 .56286 1 0 Msboxa [ -0.001 -0.001 0 0 ] [ 1.001 .61903 0 0 ] ] MathScale % Start of Graphics 1 setlinecap 1 setlinejoin newpath [ ] 0 setdash 0 g p p .002 w .02381 .30903 m .02381 .31528 L s P [(-2)] .02381 .30903 0 2 Mshowa p .002 w .2619 .30903 m .2619 .31528 L s P [(-1)] .2619 .30903 0 2 Mshowa p .002 w .7381 .30903 m .7381 .31528 L s P [(1)] .7381 .30903 0 2 Mshowa p .002 w .97619 .30903 m .97619 .31528 L s P [(2)] .97619 .30903 0 2 Mshowa p .001 w .07143 .30903 m .07143 .31278 L s P p .001 w .11905 .30903 m .11905 .31278 L s P p .001 w .16667 .30903 m .16667 .31278 L s P p .001 w .21429 .30903 m .21429 .31278 L s P p .001 w .30952 .30903 m .30952 .31278 L s P p .001 w .35714 .30903 m .35714 .31278 L s P p .001 w .40476 .30903 m .40476 .31278 L s P p .001 w .45238 .30903 m .45238 .31278 L s P p .001 w .54762 .30903 m .54762 .31278 L s P p .001 w .59524 .30903 m .59524 .31278 L s P p .001 w .64286 .30903 m .64286 .31278 L s P p .001 w .69048 .30903 m .69048 .31278 L s P p .001 w .78571 .30903 m .78571 .31278 L s P p .001 w .83333 .30903 m .83333 .31278 L s P p .001 w .88095 .30903 m .88095 .31278 L s P p .001 w .92857 .30903 m .92857 .31278 L s P p .002 w 0 .30903 m 1 .30903 L s P p .002 w .5 .0552 m .50625 .0552 L s P [(-15)] .4875 .0552 1 0 Mshowa p .002 w .5 .13981 m .50625 .13981 L s P [(-10)] .4875 .13981 1 0 Mshowa p .002 w .5 .22442 m .50625 .22442 L s P [(-5)] .4875 .22442 1 0 Mshowa p .002 w .5 .39364 m .50625 .39364 L s P [(5)] .4875 .39364 1 0 Mshowa p .002 w .5 .47825 m .50625 .47825 L s P [(10)] .4875 .47825 1 0 Mshowa p .002 w .5 .56286 m .50625 .56286 L s P [(15)] .4875 .56286 1 0 Mshowa p .001 w .5 .07212 m .50375 .07212 L s P p .001 w .5 .08905 m .50375 .08905 L s P p .001 w .5 .10597 m .50375 .10597 L s P p .001 w .5 .12289 m .50375 .12289 L s P p .001 w .5 .15673 m .50375 .15673 L s P p .001 w .5 .17365 m .50375 .17365 L s P p .001 w .5 .19058 m .50375 .19058 L s P p .001 w .5 .2075 m .50375 .2075 L s P p .001 w .5 .24134 m .50375 .24134 L s P p .001 w .5 .25826 m .50375 .25826 L s P p .001 w .5 .27519 m .50375 .27519 L s P p .001 w .5 .29211 m .50375 .29211 L s P p .001 w .5 .32595 m .50375 .32595 L s P p .001 w .5 .34287 m .50375 .34287 L s P p .001 w .5 .35979 m .50375 .35979 L s P p .001 w .5 .37672 m .50375 .37672 L s P p .001 w .5 .41056 m .50375 .41056 L s P p .001 w .5 .42748 m .50375 .42748 L s P p .001 w .5 .4444 m .50375 .4444 L s P p .001 w .5 .46132 m .50375 .46132 L s P p .001 w .5 .49517 m .50375 .49517 L s P p .001 w .5 .51209 m .50375 .51209 L s P p .001 w .5 .52901 m .50375 .52901 L s P p .001 w .5 .54593 m .50375 .54593 L s P p .001 w .5 .03828 m .50375 .03828 L s P p .001 w .5 .02136 m .50375 .02136 L s P p .001 w .5 .00444 m .50375 .00444 L s P p .001 w .5 .57978 m .50375 .57978 L s P p .001 w .5 .5967 m .50375 .5967 L s P p .001 w .5 .61362 m .50375 .61362 L s P p .002 w .5 0 m .5 .61803 L s P P 0 0 m 1 0 L 1 .61803 L 0 .61803 L closepath clip newpath p p .004 w s s s s s s s .2558 0 m .2619 .03828 L s .2619 .03828 m .28175 .14012 L .30159 .22129 L .32143 .28365 L .33135 .30836 L .34127 .32908 L .35119 .34605 L .36111 .35948 L .36607 .36495 L .37103 .36963 L .37599 .37354 L .38095 .37672 L .38591 .37919 L .39087 .38099 L .39335 .38164 L .39459 .38191 L .39583 .38214 L .39707 .38233 L .39831 .38248 L .39955 .38259 L .40079 .38267 L .40203 .38271 L .40327 .38271 L .40451 .38268 L .40575 .38262 L .40699 .38251 L .40823 .38238 L .41071 .382 L .41319 .3815 L .41567 .38086 L .42063 .37922 L .43056 .37456 L .44048 .36825 L .46032 .35165 L .5 .30903 L .51984 .28678 L .53968 .26641 L .5496 .25752 L .55952 .2498 L .56944 .2435 L .5744 .24095 L .57937 .23883 L .58185 .23795 L .58433 .23719 L .58681 .23656 L .58929 .23605 L .59053 .23585 L .59177 .23568 L .59301 .23554 L .59425 .23544 L Mistroke .59549 .23537 L .59673 .23534 L .59797 .23535 L .59921 .23539 L .60045 .23546 L .60169 .23558 L .60417 .23592 L .60541 .23615 L .60665 .23642 L .60913 .23707 L .61409 .23887 L .61905 .24134 L .62401 .24452 L .62897 .24843 L .63889 .25858 L .64881 .27201 L .65873 .28897 L .67857 .33441 L .69841 .39677 L .71825 .47793 L .7381 .57978 L Mfstroke .74365 .61803 m .7381 .57978 L s s s s s s s P P % End of Graphics MathPictureEnd :[font = output; output; inactive; preserveAspect] Graphics["<<>>"] ;[o] -Graphics- :[font = postscript; PostScript; formatAsPostScript; output; inactive; preserveAspect; pictureLeft = 34; pictureWidth = 282; pictureHeight = 174] %! %%Creator: Mathematica %%AspectRatio: .61803 MathPictureStart %% Graphics /Courier findfont 10 scalefont setfont % Scaling calculations 0.5 0.238095 0.0392403 0.00153282 [ [(-2)] .02381 .03924 0 2 Msboxa [(-1)] .2619 .03924 0 2 Msboxa [(1)] .7381 .03924 0 2 Msboxa [(2)] .97619 .03924 0 2 Msboxa [(100)] .4875 .19252 1 0 Msboxa [(200)] .4875 .3458 1 0 Msboxa [(300)] .4875 .49909 1 0 Msboxa [ -0.001 -0.001 0 0 ] [ 1.001 .61903 0 0 ] ] MathScale % Start of Graphics 1 setlinecap 1 setlinejoin newpath [ ] 0 setdash 0 g p p .002 w .02381 .03924 m .02381 .04549 L s P [(-2)] .02381 .03924 0 2 Mshowa p .002 w .2619 .03924 m .2619 .04549 L s P [(-1)] .2619 .03924 0 2 Mshowa p .002 w .7381 .03924 m .7381 .04549 L s P [(1)] .7381 .03924 0 2 Mshowa p .002 w .97619 .03924 m .97619 .04549 L s P [(2)] .97619 .03924 0 2 Mshowa p .001 w .07143 .03924 m .07143 .04299 L s P p .001 w .11905 .03924 m .11905 .04299 L s P p .001 w .16667 .03924 m .16667 .04299 L s P p .001 w .21429 .03924 m .21429 .04299 L s P p .001 w .30952 .03924 m .30952 .04299 L s P p .001 w .35714 .03924 m .35714 .04299 L s P p .001 w .40476 .03924 m .40476 .04299 L s P p .001 w .45238 .03924 m .45238 .04299 L s P p .001 w .54762 .03924 m .54762 .04299 L s P p .001 w .59524 .03924 m .59524 .04299 L s P p .001 w .64286 .03924 m .64286 .04299 L s P p .001 w .69048 .03924 m .69048 .04299 L s P p .001 w .78571 .03924 m .78571 .04299 L s P p .001 w .83333 .03924 m .83333 .04299 L s P p .001 w .88095 .03924 m .88095 .04299 L s P p .001 w .92857 .03924 m .92857 .04299 L s P p .002 w 0 .03924 m 1 .03924 L s P p .002 w .5 .19252 m .50625 .19252 L s P [(100)] .4875 .19252 1 0 Mshowa p .002 w .5 .3458 m .50625 .3458 L s P [(200)] .4875 .3458 1 0 Mshowa p .002 w .5 .49909 m .50625 .49909 L s P [(300)] .4875 .49909 1 0 Mshowa p .001 w .5 .0699 m .50375 .0699 L s P p .001 w .5 .10055 m .50375 .10055 L s P p .001 w .5 .13121 m .50375 .13121 L s P p .001 w .5 .16187 m .50375 .16187 L s P p .001 w .5 .22318 m .50375 .22318 L s P p .001 w .5 .25384 m .50375 .25384 L s P p .001 w .5 .28449 m .50375 .28449 L s P p .001 w .5 .31515 m .50375 .31515 L s P p .001 w .5 .37646 m .50375 .37646 L s P p .001 w .5 .40712 m .50375 .40712 L s P p .001 w .5 .43777 m .50375 .43777 L s P p .001 w .5 .46843 m .50375 .46843 L s P p .001 w .5 .00858 m .50375 .00858 L s P p .001 w .5 .52974 m .50375 .52974 L s P p .001 w .5 .5604 m .50375 .5604 L s P p .001 w .5 .59106 m .50375 .59106 L s P p .002 w .5 0 m .5 .61803 L s P P 0 0 m 1 0 L 1 .61803 L 0 .61803 L closepath clip newpath p p .004 w .02381 .60332 m .06349 .50931 L .10317 .42347 L .14286 .3458 L .18254 .27632 L .22222 .215 L .2619 .16187 L .30159 .1169 L .34127 .08012 L .38095 .0515 L .40079 .04026 L .42063 .03107 L .44048 .02391 L .4504 .0211 L .46032 .0188 L .47024 .01701 L .4752 .01631 L .48016 .01574 L .48512 .01529 L .4876 .01511 L .49008 .01497 L .49256 .01486 L .4938 .01481 L .49504 .01478 L .49628 .01475 L .49752 .01473 L .49876 .01472 L .5 .01472 L .50124 .01472 L .50248 .01473 L .50372 .01475 L .50496 .01478 L .5062 .01481 L .50744 .01486 L .50992 .01497 L .5124 .01511 L .51488 .01529 L .51984 .01574 L .5248 .01631 L .52976 .01701 L .53968 .0188 L .5496 .0211 L .55952 .02391 L .57937 .03107 L .59921 .04026 L .61905 .0515 L .65873 .08012 L .69841 .1169 L .7381 .16187 L .77778 .215 L Mistroke .81746 .27632 L .85714 .3458 L .89683 .42347 L .93651 .50931 L .97619 .60332 L Mfstroke P P % End of Graphics MathPictureEnd :[font = output; output; inactive; preserveAspect; endGroup; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; Cclosed; preserveAspect; startGroup] Plot p(t), p'(t), p"(t) :[font = input; preserveAspect; endGroup; endGroup; endGroup; endGroup; endGroup] Show[pic1,pic4] Show[pic2,pic5] Show[pic3,pic6] :[font = section; inactive; Cclosed; preserveAspect; startGroup] Jackson's Theorem :[font = text; inactive; Cclosed; preserveAspect; startGroup] REVIEW: Fourier approximation of periodic functions ;[s] 1:0,1;53,-1; 2:0,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] For g(t) continuous, differentiable, and periodic on [-Pi,Pi]... ;[s] 5:0,0;9,1;37,0;40,1;49,0;65,-1; 2:3,13,9,Times,0,12,0,0,0;2,13,9,Times,1,12,0,0,0; :[font = input; wordwrap; preserveAspect; startGroup] Clear[f, g, a, b, s, q]; pi = N[Pi]; g[t_] := Cos[4t]Exp[Sin[t]]; pic1 = Plot[g[t], {t, -Pi, Pi}, PlotStyle->AbsoluteThickness[3]] :[font = text; inactive; Cclosed; preserveAspect; startGroup] Hide a little bit of plotting :[font = input; wordwrap; preserveAspect; endGroup] pic2=Plot[g[t], {t, -3Pi, 3Pi}] :[font = input; wordwrap; preserveAspect; endGroup; endGroup] Show[pic1,pic2] :[font = text; inactive; preserveAspect; startGroup] Define s(n,g,t) to be the n-th degree trigonometric polynomial approximate of g: s(n,g,t)= a0 / 2 + sum ( ak cos(k t) + bk sin(k t) ) k=1,..,n ;[s] 3:0,0;38,1;74,0;192,-1; 2:2,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] To do this efficiently, for a fixed n we define a0,a1,...an,b1,...,bn. THEN we define s(n,g,t) :[font = text; inactive; preserveAspect] BLOCK constructs are subroutines in M'atica Block[{local variables{,executable statements, return] :[font = input; wordwrap; preserveAspect; endGroup] Off[NIntegrate::slwcon,NIntegrate::ncvb,NIntegrate::ploss]; Clear[TrigCoef]; TrigCoef[g_,n_] := Block[ {k,t}, cosCoef=Table[ NIntegrate[g[t] Cos[k t],{t,-pi,pi}],{k,0,n}]/pi; sinCoef=Table[ NIntegrate[g[t] Sin[k t],{t,-pi,pi}],{k,1,n}]/pi; cosCoef=Table[If[ Abs[cosCoef[[k]]]<.1^15,0,cosCoef[[k]]], {k,1,n+1}]; sinCoef=Table[If[ Abs[sinCoef[[k]]]<.1^15,0,sinCoef[[k]]], {k,1,n}]; Return[{cosCoef,sinCoef}]; ]; ;[s] 8:0,3;23,2;57,3;60,0;112,2;114,0;254,1;256,0;441,-1; 4:3,12,10,Courier,1,12,0,0,0;1,12,10,Courier,1,12,65535,0,0;2,12,10,Courier,0,12,0,0,0;2,12,10,Courier,0,12,65535,0,0; :[font = input; wordwrap; preserveAspect] Clear[t]; n=4; {cosCoef,sinCoef}=TrigCoef[g,n]; s[t_] := cosCoef[[1]]/2 + Sum[cosCoef[[k+1]] Cos[k t]+ sinCoef[[k]] Sin[k t], {k, 1, n}]; s[t] Plot[{g[t],s[t]}, {t,-Pi,Pi}, PlotStyle->{Dashing[{1,0}],Dashing[{.02,.02}]}] :[font = text; inactive; Cclosed; preserveAspect; startGroup] Alternatively, s[t] = Integrate[g[t+x] u[x]/pi,{x,-pi,pi}] where u[x]=.5+ sum Cos[k x] k=1...n :[font = input; wordwrap; preserveAspect] Clear[u,S]; u[t_] := .5+Sum[Cos[k t],{k,n}] S[t_] := NIntegrate[g[t+x] u[x],{x,-pi,pi}] Plot[s[t],{t,-pi,pi}] Plot[S[t],{t,-pi,pi}] :[font = text; inactive; preserveAspect; endGroup] * Show that Integrate[ u[x]/pi,{x,-pi,pi}]=1 by showing that Integrate[ cos[k x],{x,-pi,pi}]=0 for k>=1. :[font = text; inactive; Cclosed; preserveAspect; startGroup] We use this integral representation to prove s[g,n,t]-->g[t] as n-->infinity :[font = text; inactive; preserveAspect] g[t]-s[t] = 1/pi Integrate[ (g[t]-g[t+x]) u[x],{x,-pi,pi}] = 1/pi Integrate[ 2(g[t]-g[t+x])/x *(x/2)/Sin[x/2] *Sin[x/2] u[x],{x,-pi,pi}] = 1/pi Integrate[ (g[t]-g[t+x])/x *(x/2)/Sin[x/2] *Sin[(N+1/2)x],{x,-pi,pi}] = 1/pi Integrate[continuous fucntion[x] *Sin[(N+1/2)x],{x,-pi,pi}] if g'(t) exists --> 0 as N-->infinity (Riemann's lemma) ;[s] 5:0,0;340,1;355,0;399,1;414,0;416,-1; 2:3,13,9,Times,0,12,0,0,0;2,13,9,Times,1,12,0,0,0; :[font = text; inactive; preserveAspect; endGroup; endGroup; endGroup] * Verify Riemann's lemma for a variety of continuous fucntions: Integrate[continuous fucntion[x] *Sin[(N+1/2)x],{x,-pi,pi}] --> 0 as N--> infinity :[font = text; inactive; Cclosed; preserveAspect; startGroup] Variation of Fourier approximation of periodic functions ;[s] 1:0,1;57,-1; 2:0,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0; :[font = text; inactive; preserveAspect] For g(t) continuous and periodic on [-Pi,Pi]... ;[s] 5:0,0;9,1;20,0;23,1;32,0;48,-1; 2:3,13,9,Times,0,12,0,0,0;2,13,9,Times,1,12,0,0,0; :[font = input; wordwrap; preserveAspect] Clear[f, g, a, b, s, q]; pi = N[Pi]; g[t_] := Cos[4t]Exp[Sin[t]]; pic1 = Plot[g[t], {t, -Pi, Pi}, PlotStyle->AbsoluteThickness[3]] :[font = text; inactive; Cclosed; preserveAspect; startGroup] Define q(n,g,t) to be the n-th degree trigonometric polynomial RELATED to g: q(n,g,t)=a0/2 + sum qk*( ak cos(k t) + bk sin(k t) ) k=1,..,n Note the q(n,g,t) has coefficients qk times the terms of s(g,n,t), and the qk are ANYTHING ;[s] 3:0,0;38,1;63,0;309,-1; 2:2,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] To do this efficiently, for a fixed n we define a0,a1,...an,b1,...,bn. THEN we define q(n,g,t) :[font = text; inactive; preserveAspect] BLOCK constructs are subroutines in M'atica Block[{local variables{,executable statements, return] :[font = input; wordwrap; preserveAspect; endGroup] Off[NIntegrate::slwcon,NIntegrate::ncvb,NIntegrate::ploss]; Clear[TrigCoef]; TrigCoef[g_,n_] := Block[ {k,t}, cosCoef=Table[ NIntegrate[g[t] Cos[k t],{t,-pi,pi}],{k,0,n}]/pi; sinCoef=Table[ NIntegrate[g[t] Sin[k t],{t,-pi,pi}],{k,1,n}]/pi; cosCoef=Table[If[ Abs[cosCoef[[k]]]<.1^15,0,cosCoef[[k]]], {k,1,n+1}]; sinCoef=Table[If[ Abs[sinCoef[[k]]]<.1^15,0,sinCoef[[k]]], {k,1,n}]; Return[{cosCoef,sinCoef}]; ]; ;[s] 8:0,3;23,2;57,3;60,0;112,2;114,0;254,1;256,0;441,-1; 4:3,12,10,Courier,1,12,0,0,0;1,12,10,Courier,1,12,65535,0,0;2,12,10,Courier,0,12,0,0,0;2,12,10,Courier,0,12,65535,0,0; :[font = input; wordwrap; preserveAspect] Clear[s,q,t]; n=5; {cosCoef,sinCoef}=TrigCoef[g,n]; qCoef= Table[2 Random[]-1,{n}] s[t_] := cosCoef[[1]]/2 + Sum[(cosCoef[[k+1]] Cos[k t]+ sinCoef[[k]] Sin[k t]), {k, 1, n}]; s[t] q[t_] := cosCoef[[1]]/2 + Sum[qCoef[[k]](cosCoef[[k+1]] Cos[k t]+ sinCoef[[k]] Sin[k t]), {k, 1, n}]; q[t] Plot[{g[t],s[t],q[t]}, {t,-Pi,Pi}, PlotStyle->{Dashing[{1,0}],Dashing[{.03,.015}],Dashing[{.015,.015}]}] :[font = text; inactive; Cclosed; preserveAspect; startGroup] Alternatively, q[t] = Integrate[g[t+x] u[x],{x,-pi,pi}] where u[x]=.5+sum qk*Cos[k x] Note too that Integrate[ u[x],{x,-pi,pi}]=1 because Integrate[Cos[k x],{x,-pi,pi}]=0, k=1,2,... :[font = text; inactive; preserveAspect; startGroup] We can choose the qk so that u[x]>=0. :[font = text; inactive; preserveAspect; startGroup] Consider the complex sum, with real ck: expr1 = sum ck Exp[I k t] expr2 = sum ck Exp[-I k t] <--complex conjugate expr1*expr2>=0 :[font = input; Cclosed; wordwrap; preserveAspect; startGroup] Clear[c]; n = 6; expr1 = Sum[c[k] Exp[I (k-1) t],{k,0,n}] expr2 = Sum[c[k] Exp[-I (k-1) t],{k,0,n}]; temp = Expand[expr1 expr2]; :[font = text; inactive; Cclosed; preserveAspect; startGroup] The constant term of "temp" is (sum c^2) k=0,...,n k :[font = input; wordwrap; preserveAspect; endGroup] Table[Coefficient[temp,c[k]^2],{k,0,n}] :[font = text; inactive; Cclosed; preserveAspect; startGroup] The Cos[t] term of "temp" is 2(sum c * c ), k=0,...,n-1 k k+1 :[font = text; inactive; preserveAspect] Remember that Exp[a t] + Exp[-a t] = 2 Cos[a t] :[font = input; wordwrap; preserveAspect; endGroup] Table[Coefficient[temp,c[k]c[k+1]],{k,0,n-1}] :[font = text; inactive; Cclosed; preserveAspect; startGroup] The Cos[2t] term of "temp" is 2(sum c * c ), k=0,...,n-2 k k+2 :[font = input; wordwrap; preserveAspect; endGroup; endGroup] Table[Coefficient[temp,c[k]c[k+2]],{k,0,n-2}] :[font = text; inactive; Cclosed; preserveAspect; startGroup] So that temp = (sum c^2) + 2(sum c * c )*cos[t] + 2(sum c * c )*cos[2t]+...+2c[0]c[n]cos[nt] k k k+1 k k+2 We want sum ck^2 to be 1/2 so that temp = 1/2 + sum qk cos[k t] >=0 any ck's will work so long as the sum of their squares is 1/2... :[font = input; wordwrap; preserveAspect; endGroup; endGroup; endGroup] c = Table[2 Random[]-1,{k,0,n}]; c = c/Sqrt[2Sum[c[[k]]^2,{k,Length[c]}]] u[t_] := 1/2+ Sum[2Sum[c[[k]]c[[k+j]],{k,Length[c]-j}]Cos[j t],{j,n}] Plot[u[t],{t,-Pi,Pi}, PlotRange->{0,1}] :[font = input; wordwrap; preserveAspect; endGroup; endGroup] Clear[u]; c = Table[2 Random[]-1,{k,0,n}]; c = c/Sqrt[2Sum[c[[k]]^2,{k,Length[c]}]]; qCoef=Table[2Sum[c[[k]]c[[k+j]],{k,Length[c]-j}],{j,n}]; u[t_] := 1/2+ Sum[qCoef[[j]] Cos[j t],{j,n}] u[t] Plot[u[t],{t,-Pi,Pi}, PlotRange->{0,1}] :[font = text; inactive; preserveAspect] | g[t]-s[t] | <= 1/pi Integrate[ |g[t]-g[t+x]| u[x],{x,-pi,pi}] <= 1/pi Integrate[w(|x|)| u[x],{x,-pi,pi}] <--remember modulus of continuity? remember w(n d)<=(1+ n)w(d) so, letting d = |x|/n we can write | g[t]-s[t] | <=w(1/n) 1/pi Integrate[ (1+n |x|) u[x],{x,-pi,pi}] =w(1/n) ( 1/pi Integrate[u[x],{x,-pi,pi}] + n/pi Integrate[ |x| u[x],{x,-pi,pi}] ) =w(1/n) ( 1 + n/pi Integrate[ |x| u[x],{x,-pi,pi}] ) 1/pi Integrate[ |x| u[x],{x,-pi,pi}] <= || |x| sqrt[u[x]/pi] || * || sqrt[u[x]/pi] ||, using the Holder's inequality with p=q=2 = || |x| sqrt[u[x]/pi] || , since || sqrt[u[x]/pi] || = 1. || |x| sqrt[u[x]/pi] ||^2 = 1/pi Integrate[ x^2 u[x],{x,-pi,pi}] Recall -pi<=x<=pi and x<=pi/2Sin[x] if 0<=x<=pi/2. Thus -pi/2<=x/2<= pi/2 and |x|/2<=pi/2 sin[|x|/2]. (|x|/2)^2<= pi^2/4 Sin[|x|/2]^2 x^2 <= pi^2 Sin[|x|/2]^2=pi^2 (1-Cos[x])/2 1/pi Integrate[ x^2 u[x],{x,-pi,pi}] <= pi/2 Integrate[ (1-Cos[x]) u[x],{x,-pi,pi}] = pi^2/2 (1-q1) since Integrate[ (1-Cos[x]) u[x],{x,-pi,pi}]/pi=1-q1 And we have | g[t]-s[t] | <=w(1/n). ;[s] 7:0,0;140,1;148,0;181,1;189,0;727,1;746,0;1500,-1; 2:4,13,9,Times,0,12,0,0,0;3,13,9,Times,1,12,0,0,0; :[font = input; wordwrap; preserveAspect] Integrate[ (1-Cos[x]) u[x],{x,-pi,pi}] /pi (1-qCoef[[1]]) :[font = text; inactive; Cclosed; preserveAspect; startGroup] Define an empirical version of the function norm and the modulus of continuity: :[font = input; wordwrap; preserveAspect; endGroup] Clear[funcNorm]; funcNorm[f_, p_, a_, b_] := If[p == Infinity, Max[Table[Abs[f[x]], {x, a, b, (b - a).001}]], NIntegrate[Abs[f[x]]^p, {x, a, b}]^(1/p)] Clear[w]; Clear[w]; w[f_,delta_,a_,b_] := Max[Table[Table[ Abs[N[f[x]-f[y]]], {x,Max[a,y-delta],Min[b,y+delta], (Min[b,y+delta]-Max[a,y-delta])/20}], {y,a,b,delta}]] :[font = text; inactive; Cclosed; preserveAspect; startGroup] For completely random nonnegative u(t), ck = 2Random[]-1, k=0,...,n, and the normalized. We compare || g-q || with w(g,1/n)(1-n*pi*sqrt[ (1-q1)/2 ] ;[s] 3:0,0;6,1;40,0;166,-1; 2:2,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0; :[font = input; wordwrap; preserveAspect; endGroup] Clear[u,q]; n=8; g[t_] := Cos[4t]Exp[Sin[t]]; {cosCoef,sinCoef}=TrigCoef[g,n]; s[t_] := cosCoef[[1]]/2 + Sum[(cosCoef[[k+1]] Cos[k t]+ sinCoef[[k]] Sin[k t]), {k, 1, n}]; c = Table[2 Random[]-1,{k,0,n}]; c = c/Sqrt[2Sum[c[[k]]^2,{k,Length[c]}]]; qCoef=Table[2Sum[c[[k]]c[[k+j]],{k,Length[c]-j}],{j,n}]; u[t_] := 1/2+ Sum[qCoef[[j]] Cos[j t],{j,n}] q[t_] := cosCoef[[1]]/2 + Sum[qCoef[[k]](cosCoef[[k+1]] Cos[k t]+ sinCoef[[k]] Sin[k t]), {k, 1, n}]; e[x_] := g[x]-q[x]; Plot[u[t],{t,-pi,pi}] Print["The sup-norm ||g-q|| = ",t2=funcNorm[e,Infinity,-pi,pi]] Print["The modulus of continuity w(g,1/",n,") = ",t1=w[g,1/n,-pi,pi]] Print["(1+",n,"Pi*Sqrt[(1-q1)/2]) = ",t3=(1+n*pi*Sqrt[(1-qCoef[[1]])/2])] Print["q1 = ",qCoef[[1]]] Print[" "] Print["||g-q||<= w(g,1/",n,")*(1+",n,"Pi*Sqrt[(1-q1)/2]) = ",t1*t3,"? ",t2<=t1*t3] ;[s] 5:0,0;12,1;17,0;199,1;232,0;886,-1; 2:3,12,10,Courier,1,12,0,0,0;2,12,10,Courier,1,12,65535,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] For specially chosen nonnegative u(t), ck = Sin[(k+1)Pi/(n+2)], k=0,...,n, and the normalized. We compare || g-q || with w(g,1/n)(1-n*pi*sqrt[ (1-q1)/2 ] ;[s] 3:0,0;6,1;39,0;174,-1; 2:2,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0; :[font = input; wordwrap; preserveAspect; endGroup; endGroup] Clear[u,q,s,g]; n=10; g[t_] := Cos[4t]Exp[Sin[t]]; {cosCoef,sinCoef}=TrigCoef[g,n]; s[t_] := cosCoef[[1]]/2 + Sum[(cosCoef[[k+1]] Cos[k t]+ sinCoef[[k]] Sin[k t]), {k, 1, n}]; c = Table[Sin[(k+1) pi/(n+2)],{k,0,n}]; c=c/Sqrt[n+2.]; qCoef=Table[2Sum[c[[k]]c[[k+j]],{k,Length[c]-j}],{j,n}]; u[t_] := 1/2+ Sum[qCoef[[j]] Cos[j t],{j,n}] q[t_] := cosCoef[[1]]/2 + Sum[qCoef[[k]](cosCoef[[k+1]] Cos[k t]+ sinCoef[[k]] Sin[k t]), {k, 1, n}]; e[x_] := g[x]-q[x]; Plot[u[t],{t,-pi,pi}] Print["The sup-norm ||g-q|| = ",t2=funcNorm[e,Infinity,-pi,pi]] Print["The modulus of continuity w(g,1/",n,") = ",t1=w[g,1/n,-pi,pi]] Print["(1+",n,"Pi*Sqrt[(1-q1)/2]) = ",t3=(1+n*pi*Sqrt[(1-qCoef[[1]])/2])] Print["q1 = ",qCoef[[1]]] Print[" "] Print["||g-q||<= w(g,1/",n,")*(1+",n,"Pi*Sqrt[(1-q1)/2]) = ",t1*t3,"? ",t2<=t1*t3] ;[s] 7:0,0;16,1;22,0;204,1;243,0;253,1;257,0;872,-1; 2:4,12,10,Courier,1,12,0,0,0;3,12,10,Courier,1,12,65535,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] Polynomial approximation of continuous functions ;[s] 1:0,1;49,-1; 2:0,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] For f(x) continuous on [-1,1], define g(t) continuous, and periodic on [-Pi,Pi]... :[font = input; wordwrap; preserveAspect; startGroup] Clear[f, g, a, b, s, q]; f[x_] := Exp[-x]Sin[3 x^2]; pi = N[Pi]; g[t_] := Expand[f[Cos[t]],Trig->True]; g[t] :[font = text; inactive; Cclosed; preserveAspect; startGroup] Hide a little bit of plotting :[font = input; preserveAspect; endGroup] pic1=Plot[f[x], {x, -1,1}] pic2=Plot[g[t], {t, -Pi, Pi}] pic3=Plot[g[t], {t, 0, Pi}, PlotStyle->AbsoluteThickness[3]] pic4 = Show[pic2,pic3]; :[font = input; preserveAspect; endGroup; endGroup] Show[GraphicsArray[{pic1,pic4}]] :[font = text; inactive; Cclosed; preserveAspect; startGroup] Since g(t) is even, s(n,g,t) has only cosine terms: s(n,g,t)=a0/2 + sum ( ak cos(k t) + 0 sin(k t) ) k=1,..,n Let ck = c*Sin[(k+1)Pi/(n+2)], k=0,...,n and normalize so that (sum c^2) =1/2. k and let qk = 2(sum c * c ) k k+j For this set of qk values we define the variation of s(n,g,t): q(n,g,t)=a0/2 + sum qk*( ak cos(k t) + 0 sin(k t) ) k=1,..,n From this q(n,g,t) we define a polynomial p(x) approximate of original f(x) p(n,f,x)=a0/2 + sum qk*ak ChebyshevT[n,x] k=1,..,n ;[s] 19:0,0;14,1;18,0;38,1;44,0;87,1;89,0;100,1;102,0;604,1;606,0;622,1;624,0;819,1;821,0;822,1;824,0;825,1;835,0;883,-1; 2:10,13,9,Times,0,12,0,0,0;9,13,9,Times,1,12,0,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] To do this efficiently, we need some supporting subroutines :[font = text; inactive; preserveAspect] BLOCK constructs are subroutines in M'atica Block[{local variables{,executable statements, return] :[font = input; wordwrap; preserveAspect] Off[NIntegrate::slwcon,NIntegrate::ncvb,NIntegrate::ploss]; Clear[TrigCoef]; TrigCoef[g_,n_] := Block[ {k,t}, cosCoef=Table[ NIntegrate[g[t] Cos[k t],{t,-pi,pi}],{k,0,n}]/pi; sinCoef=Table[ NIntegrate[g[t] Sin[k t],{t,-pi,pi}],{k,1,n}]/pi; cosCoef=Table[If[ Abs[cosCoef[[k]]]<.1^15,0,cosCoef[[k]]], {k,1,n+1}]; sinCoef=Table[If[ Abs[sinCoef[[k]]]<.1^15,0,sinCoef[[k]]], {k,1,n}]; Return[{cosCoef,sinCoef}]; ]; ;[s] 8:0,3;23,2;57,3;60,0;112,2;114,0;254,1;256,0;441,-1; 4:3,7,10,Courier,1,12,0,0,0;1,7,10,Courier,1,12,65535,0,0;2,7,10,Courier,0,12,0,0,0;2,7,10,Courier,0,12,65535,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] Define an empirical version of the function norm and the modulus of continuity: :[font = input; wordwrap; preserveAspect; endGroup; endGroup] Clear[funcNorm]; funcNorm[f_, p_, a_, b_] := If[p == Infinity, Max[Table[Abs[f[x]], {x, a, b, (b - a).001}]], NIntegrate[Abs[f[x]]^p, {x, a, b}]^(1/p)] Clear[w]; Clear[w]; w[f_,delta_,a_,b_] := Max[Table[Table[ Abs[N[f[x]-f[y]]], {x,Max[a,y-delta],Min[b,y+delta], (Min[b,y+delta]-Max[a,y-delta])/20}], {y,a,b,delta}]] :[font = input; wordwrap; preserveAspect] Clear[u,q,s,u,e,p,x]; n=10; {cosCoef,sinCoef}=TrigCoef[g,n]; s[t_] := cosCoef[[1]]/2 + Sum[(cosCoef[[k+1]] Cos[k t]+ sinCoef[[k]] Sin[k t]), {k, 1, n}]; c = Table[Sin[(k+1) pi/(n+2)],{k,0,n}]; c = c/Sqrt[n+2.]; qCoef=Table[2Sum[c[[k]]c[[k+j]],{k,Length[c]-j}],{j,n}]; q[t_] := cosCoef[[1]]/2 + Sum[qCoef[[k]] cosCoef[[k+1]] Cos[k t], {k, 1, n}]; p[x_] := cosCoef[[1]]/2 + Sum[qCoef[[k]] cosCoef[[k+1]] ChebyshevT[k,x], {k, 1, n}]; p[x] Expand[p[x]] e[x_] := f[x]-p[x]; Plot[{f[x],p[x]},{x,-1,1}, PlotStyle->{Dashing[{1,0}],Dashing[{.03,.015}]}] Plot[{e[x]},{x,-1,1}] ;[s] 7:0,0;22,1;28,0;179,1;218,0;230,1;234,0;638,-1; 2:4,7,10,Courier,1,12,0,0,0;3,7,10,Courier,1,12,65535,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] We showed that |g(t) - q(n,g,t)| < 6 * w(g,1/n). This implies that |f(x) - p(n,f,x)| < 6 * w(f,1/n) because max {|g(cos(x))-g(cos(y))| : |x-y|<1/n} is less than max {|g(cos(x))-g(cos(y)| : |cos(x)-cos(y)|<1/n}= max {|f(s)-f(t)| : |s-t|<1/n} :[font = input; preserveAspect; endGroup; endGroup] Off[Plot::plnr]; Plot[{x-1/n, x+1/n, ArcCos[Cos[x]-1/n], ArcCos[Cos[x]+1/n]},{x,0,Pi}] ;[s] 3:0,0;4,1;14,0;105,-1; 2:2,7,10,Courier,1,12,0,0,0;1,7,10,Courier,0,12,65535,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] Special case: f[x_] := Abs[x-.5] on the interval [0,1] shows that || f - BernOp[f,n] || = Binomial[n,n/2]/2^(n+1). Asymptotically the error || f - BernOp[f,n] || behaves like 1/2/sqrt[n] as n tends to infinity. Consequently, Bernstein polynomials converge slowly to f. In general we showed that || f - BernOp[f,n] || <3/2 1/sqrt[n], but for this f(x), || f - BernOp[f,n] || ~1/2 1/sqrt[n] . This means that the rate 1/sqrt(n) can't be improved upon with Bernstein polynomials ;[s] 10:0,1;12,0;228,1;265,0;324,1;327,0;425,1;429,0;510,1;519,0;570,-1; 2:5,13,9,Times,0,12,0,0,0;5,13,9,Times,1,12,0,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] The example revisited... :[font = input; wordwrap; preserveAspect] Clear[BernPol,BernOp]; BernPol[n_,k_,x_] := Binomial[n,k] x^k (1-x)^(n-k); BernOp[f_, n_, x_] := Sum[f[k/n] BernPol[n, k, x], {k, 0, n}]; :[font = input; preserveAspect; startGroup] f[x_] := Abs[x-.5]; n=30; P[x_] := Expand[BernOp[f,n,x]] P[.5] Plot[{P[x],f[x]},{x,.00001,.99999}] Plot[{P[(x+1)/2],f[(x+1)/2]},{x,-.99999,.99999}] :[font = input; preserveAspect; startGroup] dot = {}; For[n=2,n<=100,n=n+2, dot= Append[dot,{n, Sqrt[1.n]*Binomial[n,n/2]2.^-(n+1)}]; ]; ListPlot[dot,PlotJoined->True] :[font = postscript; PostScript; formatAsPostScript; output; inactive; preserveAspect; pictureLeft = 34; pictureWidth = 282; pictureHeight = 174] %! %%Creator: Mathematica %%AspectRatio: .61803 MathPictureStart %% Graphics /Courier findfont 10 scalefont setfont % Scaling calculations 0.0238095 0.0047619 -42.0199 106.974 [ [(50)] .2619 .02096 0 2 Msboxa [(100)] .5 .02096 0 2 Msboxa [(150)] .7381 .02096 0 2 Msboxa [(200)] .97619 .02096 0 2 Msboxa [(0.394)] .01131 .12793 1 0 Msboxa [(0.395)] .01131 .23491 1 0 Msboxa [(0.396)] .01131 .34188 1 0 Msboxa [(0.397)] .01131 .44886 1 0 Msboxa [(0.398)] .01131 .55583 1 0 Msboxa [ -0.001 -0.001 0 0 ] [ 1.001 .61903 0 0 ] ] MathScale % Start of Graphics 1 setlinecap 1 setlinejoin newpath [ ] 0 setdash 0 g p p .002 w .2619 .02096 m .2619 .02721 L s P [(50)] .2619 .02096 0 2 Mshowa p .002 w .5 .02096 m .5 .02721 L s P [(100)] .5 .02096 0 2 Mshowa p .002 w .7381 .02096 m .7381 .02721 L s P [(150)] .7381 .02096 0 2 Mshowa p .002 w .97619 .02096 m .97619 .02721 L s P [(200)] .97619 .02096 0 2 Mshowa p .001 w .07143 .02096 m .07143 .02471 L s P p .001 w .11905 .02096 m .11905 .02471 L s P p .001 w .16667 .02096 m .16667 .02471 L s P p .001 w .21429 .02096 m .21429 .02471 L s P p .001 w .30952 .02096 m .30952 .02471 L s P p .001 w .35714 .02096 m .35714 .02471 L s P p .001 w .40476 .02096 m .40476 .02471 L s P p .001 w .45238 .02096 m .45238 .02471 L s P p .001 w .54762 .02096 m .54762 .02471 L s P p .001 w .59524 .02096 m .59524 .02471 L s P p .001 w .64286 .02096 m .64286 .02471 L s P p .001 w .69048 .02096 m .69048 .02471 L s P p .001 w .78571 .02096 m .78571 .02471 L s P p .001 w .83333 .02096 m .83333 .02471 L s P p .001 w .88095 .02096 m .88095 .02471 L s P p .001 w .92857 .02096 m .92857 .02471 L s P p .002 w 0 .02096 m 1 .02096 L s P p .002 w .02381 .12793 m .03006 .12793 L s P [(0.394)] .01131 .12793 1 0 Mshowa p .002 w .02381 .23491 m .03006 .23491 L s P [(0.395)] .01131 .23491 1 0 Mshowa p .002 w .02381 .34188 m .03006 .34188 L s P [(0.396)] .01131 .34188 1 0 Mshowa p .002 w .02381 .44886 m .03006 .44886 L s P [(0.397)] .01131 .44886 1 0 Mshowa p .002 w .02381 .55583 m .03006 .55583 L s P [(0.398)] .01131 .55583 1 0 Mshowa p .001 w .02381 .04236 m .02756 .04236 L s P p .001 w .02381 .06375 m .02756 .06375 L s P p .001 w .02381 .08515 m .02756 .08515 L s P p .001 w .02381 .10654 m .02756 .10654 L s P p .001 w .02381 .14933 m .02756 .14933 L s P p .001 w .02381 .17072 m .02756 .17072 L s P p .001 w .02381 .19212 m .02756 .19212 L s P p .001 w .02381 .21351 m .02756 .21351 L s P p .001 w .02381 .2563 m .02756 .2563 L s P p .001 w .02381 .2777 m .02756 .2777 L s P p .001 w .02381 .29909 m .02756 .29909 L s P p .001 w .02381 .32049 m .02756 .32049 L s P p .001 w .02381 .36328 m .02756 .36328 L s P p .001 w .02381 .38467 m .02756 .38467 L s P p .001 w .02381 .40607 m .02756 .40607 L s P p .001 w .02381 .42746 m .02756 .42746 L s P p .001 w .02381 .47025 m .02756 .47025 L s P p .001 w .02381 .49165 m .02756 .49165 L s P p .001 w .02381 .51304 m .02756 .51304 L s P p .001 w .02381 .53444 m .02756 .53444 L s P p .001 w .02381 .57723 m .02756 .57723 L s P p .001 w .02381 .59862 m .02756 .59862 L s P p .002 w .02381 0 m .02381 .61803 L s P P 0 0 m 1 0 L 1 .61803 L 0 .61803 L closepath clip newpath .004 w s s s s s s s s .1006 0 m .10952 .0683 L s .10952 .0683 m .11905 .12671 L .12857 .17458 L .1381 .21452 L .14762 .24835 L .15714 .27737 L .16667 .30254 L .17619 .32457 L .18571 .34403 L .19524 .36133 L .20476 .37682 L .21429 .39076 L .22381 .40338 L .23333 .41486 L .24286 .42534 L .25238 .43495 L .2619 .4438 L .27143 .45196 L .28095 .45952 L .29048 .46655 L .3 .47309 L .30952 .47919 L .31905 .4849 L .32857 .49026 L .3381 .49529 L .34762 .50003 L .35714 .50449 L .36667 .50871 L .37619 .5127 L .38571 .51648 L .39524 .52007 L .40476 .52348 L .41429 .52672 L .42381 .52981 L .43333 .53275 L .44286 .53557 L .45238 .53825 L .4619 .54082 L .47143 .54328 L .48095 .54564 L .49048 .5479 L .5 .55007 L .50952 .55216 L .51905 .55417 L .52857 .5561 L .5381 .55796 L .54762 .55975 L .55714 .56148 L .56667 .56315 L .57619 .56476 L Mistroke .58571 .56631 L .59524 .56782 L .60476 .56927 L .61429 .57068 L .62381 .57204 L .63333 .57336 L .64286 .57464 L .65238 .57588 L .6619 .57709 L .67143 .57825 L .68095 .57939 L .69048 .58049 L .7 .58156 L .70952 .5826 L .71905 .58362 L .72857 .5846 L .7381 .58556 L .74762 .5865 L .75714 .58741 L .76667 .58829 L .77619 .58916 L .78571 .59 L .79524 .59082 L .80476 .59163 L .81429 .59241 L .82381 .59317 L .83333 .59392 L .84286 .59465 L .85238 .59536 L .8619 .59605 L .87143 .59673 L .88095 .5974 L .89048 .59805 L .9 .59869 L .90952 .59931 L .91905 .59992 L .92857 .60051 L .9381 .6011 L .94762 .60167 L .95714 .60223 L .96667 .60278 L .97619 .60332 L Mfstroke % End of Graphics MathPictureEnd :[font = output; output; inactive; preserveAspect; endGroup; endGroup; endGroup] Graphics["<<>>"] ;[o] -Graphics- :[font = text; inactive; preserveAspect] Now lets use the polynomial constructed from the variation on the Fourier approach. In general we showed that || f - p || < 6 1/n, but for this f(x), || f - p || ~ 5/2 1/n. ;[s] 5:0,0;126,1;127,0;210,1;214,0;222,-1; 2:3,13,9,Times,0,12,0,0,0;2,13,9,Times,1,12,0,0,0; :[font = input; wordwrap; preserveAspect] Clear[u,q,s,u,e,p,x,g,cosCoef,sinCoef]; n=30; g[x_] := Abs[Cos[x]]; {cosCoef,sinCoef}=TrigCoef[g,n]; s[t_] := cosCoef[[1]]/2 + Sum[(cosCoef[[k+1]] Cos[k t]+ sinCoef[[k]] Sin[k t]), {k, 1, n}]; c = Table[Sin[(k+1) pi/(n+2)],{k,0,n}]; c = c/Sqrt[n+2.]; qCoef=Table[2Sum[c[[k]]c[[k+j]],{k,Length[c]-j}],{j,n}]; q[t_] := cosCoef[[1]]/2 + Sum[qCoef[[k]] cosCoef[[k+1]] Cos[k t], {k, 1, n}]; p[x_] := cosCoef[[1]]/2 + Sum[qCoef[[k]] cosCoef[[k+1]] ChebyshevT[k,x], {k, 1, n}]; p[0] Plot[{g[ArcCos[x]],p[x]},{x,-1,1}, PlotStyle->{Dashing[{1,0}],Dashing[{.03,.015}]}] ;[s] 7:0,0;40,1;46,0;219,1;258,0;270,1;274,0;632,-1; 2:4,7,10,Courier,1,12,0,0,0;3,7,10,Courier,1,12,65535,0,0; :[font = input; preserveAspect; endGroup; endGroup] Clear[cosCoef]; cosCoef[k_] := If[k==1,0, (-4*Cos[(k*Pi)/2])/(-1 + k^2) + (2*k*Sin[k*Pi])/(-1 + k^2)] dot = {}; For[n=2,n<=100,n=n+2, c = Table[Sin[(k+1) pi/(n+2)],{k,0,n}]; c = c/Sqrt[n+2.]; qCoef=Table[2Sum[c[[k]]c[[k+j]],{k,Length[c]-j}],{j,n}]; dot= Append[dot,{n, n*Expand[cosCoef[0]/2 + Sum[qCoef[[k]] cosCoef[k] ChebyshevT[k,0], {k, n}]]/pi}]; ]; ListPlot[dot,PlotJoined->True] ;[s] 5:0,0;147,1;186,0;189,1;206,0;423,-1; 2:3,7,10,Courier,1,12,0,0,0;2,7,10,Courier,1,12,65535,0,0; :[font = text; inactive; Cclosed; preserveAspect; startGroup] The best we can hope for is... ;[s] 1:0,1;31,-1; 2:0,13,9,Times,0,12,0,0,0;1,13,9,Times,1,12,0,0,0; :[font = text; inactive; preserveAspect; endGroup; endGroup] Let f(x) is a continuous function on [a,b], and E[f,n] = min || f-p ||, where p is a polynomial of degree at most n, and || || dentoes the infinity norm. 6 M 1) E[f,n] <= 6 w{f,1/n) <= ----- <--proved by Jackson, using a variation on Fourier n approximates, assmes ||f||<=M 6 M 2) E[f,n] <= ----- , if f' is continuous and bounded by M (property of w(f,d)) n 6 3) E[f,n] <= ------ E[f',n-1], if f' exists n k+1 k 6 e (k) 1 (k) 4) E[f,n] <= ------------- w(f , ---- ), if f exists <-- applying (3) recursively k+1 n-k n (k+1) BUT according to Bernstein (Meinardus, p63, Thm 52), -k-a If E[f,n] <= A n for k a positive integer, 0