(*^
::[	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-part ii
:[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]
Best uniform approximation (manual Remez exchange)
f continuous
;[s]
3:0,0;51,1;63,0;64,-1;
2:2,19,14,Times,1,18,0,0,0;1,19,14,Times,1,18,65535,0,0;
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Preliminaries
:[font = input; preserveAspect]
Off[General::spell,General::spell1];
;[s]
3:0,0;4,1;34,0;37,-1;
2:2,12,10,Courier,1,12,0,0,0;1,12,10,Courier,0,12,65535,0,0;
:[font = input; wordwrap; 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; wordwrap; preserveAspect]
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}]]
:[font = input; wordwrap; preserveAspect]
Squash[x_] := Table[If[Abs[x[[i1]]]<.1^12,0.,x],{i1,Length[x]}]
:[font = input; wordwrap; preserveAspect]
Clear[DashLine];
DashLine[a_,b_,n_]:= Table[Line[
{a+2 i2(b-a)/(2n+1),a+(2 i2+1)(b-a)/(2n+1)}],{i2,0,n}]

:[font = input; preserveAspect]
Clear[FindLocalExtrema];
FindLocalExtrema[ff_,a_,b_] := Block[
{localMin,localMax,i,nn,vals},
nn=100;
vals = Table[ff[a+i1 1./nn (b-a)],{i1,0,nn}];
localMin = {};
localMax = {};
For[i=2,i<=nn,i++,
  If[vals[[i-1]] <= vals[[i]] &&
     vals[[i]] >= vals[[i+1]],
     localMax=Append[localMax,a+(i-1) 1./nn (b-a)]];
  If[vals[[i-1]] >= vals[[i]] &&
     vals[[i]] <= vals[[i+1]],
     localMin=Append[localMin,a+(i-1) 1./nn (b-a)]];
  ];
If[vals[[1]]<vals[[2]], 
  localMin=Append[localMin,a],
  localMax=Append[localMax,a]
  ];
If[vals[[n]]<vals[[n+1]], 
  localMax=Append[localMax,b],
  localMin=Append[localMin,b]
  ];
Return[{Sort[localMin],Sort[localMax]}];
];       
:[font = input; preserveAspect]
Clear[ZoomIn]
ZoomIn[ff_,x_,left_,right_] := Block[
{d,z},
d = (right-left)/100;
If[ff[x]<=Min[ff[x-d],ff[x+d]],
  locale[z_] := ff[z];
  index = 1;,
  locale[z_] := -ff[z];
  index = 2;
  ];
z=FindLocalExtrema[locale,x-d,x+d][[index,1]];
d=d/10;
z=FindLocalExtrema[locale,x-d,x+d][[index,1]];
d=d/10;
z=FindLocalExtrema[locale,x-d,x+d][[index,1]];
d=d/10;
z=FindLocalExtrema[locale,x-d,x+d][[index,1]];
d=d/10;
z=FindLocalExtrema[locale,x-d,x+d][[index,1]];
Return[z];
];
:[font = input; preserveAspect; endGroup]
Clear[FindExtrema];
FindExtrema[ff_,left_,right_] := Block[
{localMin,localMax,i,temp,tol},
tol = .1^6;
{localMin,localMax}=
  FindLocalExtrema[ff,left,right];
For[i=1,i<=Length[localMin],i++,
  If[left<localMin[[i]] &&
     localMin[[i]] < right,
     localMin[[i]] = 
       ZoomIn[e,localMin[[i]],left,right]
    ];
  ];
For[i=1,i<=Length[localMax],i++,
  If[left<localMax[[i]] &&
     localMax[[i]] < right,
     localMax[[i]] = 
       ZoomIn[e,localMax[[i]],left,right]
    ];
  ];
If[Length[localMin]>0,
  temp = {localMin[[1]]};
  For[i=1,i<Length[localMin],i++,
    If[localMin[[i+1]]-localMin[[i]]>tol,
      temp=Append[temp,localMin[[i+1]]];
      ];
    ];
  ];
localMin = temp;
If[Length[localMax]>0,
  temp = {localMax[[1]]};
  For[i=1,i<Length[localMax],i++,
    If[localMax[[i+1]]-localMax[[i]]>tol,
      temp=Append[temp,localMax[[i+1]]];
      ];
    ];
  ];
localMax = temp;
Return[{localMin,localMax}];
]
:[font = input; preserveAspect]
left = -1.;
right = 1.;

:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Linear approx with manual exchange
:[font = input; wordwrap; preserveAspect]
Clear[f,x,a,b,err];
f[x_] := Abs[x-.5];
n=1;
alt = Table[left+i1/2.(right-left),{i1,0,2}];
mat = Table[{1, alt[[i1]],(-1)^i1},
      {i1,Length[alt]}];
dat = Table[{f[alt[[i1]]]},{i1,Length[alt]}];
{a,b,err} = Flatten[Inverse[mat].dat];
Print["p[x] = ",a," + ",b," x"]
Print[" "];
Print["error = ",Table[e[alt[[i1]]],{i1,Length[alt]}],"...on the alternation set: ",alt];

Clear[e];
e[x_] := f[x]- a - b x;
Plot[e[x],{x,left,right},
  Prolog->{PointSize[.02],
  Table[Point[{alt[[i1]],e[alt[[i1]]]}],{i1,Length[alt]}]}]

{localMin,localMax} = FindExtrema[e,left,right];
extremePts= Sort[Join[localMin,localMax]];
Print[" "];
Print["But the local min/max for the error functions are"];
Print[" "];
max = 0;
For[i=1,i<=Length[extremePts],i++,
  temp = e[extremePts[[i]]];
  If[max<Abs[temp],
    max = Max[Abs[temp],max];
    tempi = i;
    ];
  Print["e[",extremePts[[i]],"] = ",temp];
]
Print[" "];
If[max-Abs[err]>.1^4,
Print["The largest |error| = ",max," and occurs at x = ",extremePts[[tempi]],"."];
Print["This point should be swapped with one of"];
Print["the current alternation points."],
Print["There seems to be an alternation set of"];
Print["length ",Length[alt],", so we are done."];
]
:[font = input; wordwrap; preserveAspect]
alt[[2]] =.5;
mat = Table[{1, alt[[i1]],(-1)^i1},
      {i1,Length[alt]}];
dat = Table[{f[alt[[i1]]]},{i1,Length[alt]}];
{a,b,err} = Flatten[Inverse[mat].dat];
Print["p[x] = ",a," + ",b," x"]
Print[" "];
Print["error = ",Table[e[alt[[i1]]],{i1,Length[alt]}],"...on the alternation set: ",alt];

Clear[e];
e[x_] := f[x]- a - b x;
Plot[e[x],{x,left,right},
  Prolog->{PointSize[.02],
  Table[Point[{alt[[i1]],e[alt[[i1]]]}],{i1,Length[alt]}]}]

{localMin,localMax} = FindExtrema[e,left,right];
extremePts= Sort[Join[localMin,localMax]];
Print[" "];
Print["But the local min/max for the error functions are"];
Print[" "];
max = 0;
For[i=1,i<=Length[extremePts],i++,
  temp = e[extremePts[[i]]];
  If[max<Abs[temp],
    max = Max[Abs[temp],max];
    tempi = i;
    ];
  Print["e[",extremePts[[i]],"] = ",temp];
]
Print[" "];
If[max-Abs[err]>.1^4,
Print["The largest |error| = ",max," and occurs at x = ",extremePts[[tempi]],"."];
Print["This point should be swapped with one of"];
Print["the current alternation points."],
Print["There seems to be an alternation set of"];
Print["length ",Length[alt],", so we are done."];
]
;[s]
4:0,2;10,1;12,2;13,0;1121,-1;
3:1,12,10,Courier,1,12,0,0,0;1,12,10,Courier,0,12,0,0,0;2,12,10,Courier,1,12,65535,0,0;
:[font = input; wordwrap; preserveAspect; endGroup]
p[x_] := b x + a;

M= Max[Abs[{f[right],f[left],p[right],p[left]}]];
Plot[{f[x],p[x]},{x,left,right},
  PlotStyle->{Dashing[{1,0}],Dashing[{.02,.02}]},
  Prolog->{PointSize[.02],
  Table[Point[{alt[[i1]],f[alt[[i1]]]}],
     {i1,Length[alt]}]},
  PlotRange->1.05{-M,M}]
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Quadratic approx with manual exchange
:[font = input; wordwrap; preserveAspect]
Clear[f,x];
f[x_] := Abs[x-.5];
n=2;
alt = Table[left+i1/3.(right-left),{i1,0,3}]
mat = Table[{1, alt[[i1]],alt[[i1]]^2,(-1)^i1},
      {i1,Length[alt]}];
dat = Table[{f[alt[[i1]]]},{i1,Length[alt]}];
{a,b,c,err} = Flatten[Inverse[mat].dat];
Print["p[x] = ",a," + ",b," x + ",c," x^2"]
Print[" "];
Print["error = ",Table[e[alt[[i1]]],{i1,Length[alt]}],"...on the alternation set: ",alt];

Clear[e];
e[x_] := f[x]- a - b x - c x^2;
Plot[e[x],{x,left,right},
  Prolog->{PointSize[.02],
  Table[Point[{alt[[i1]],e[alt[[i1]]]}],{i1,Length[alt]}]}]

{localMin,localMax} = FindExtrema[e,left,right];
extremePts= Sort[Join[localMin,localMax]];
Print[" "];
Print["But the local min/max for the error functions are"];
Print[" "];
max = 0;
For[i=1,i<=Length[extremePts],i++,
  temp = e[extremePts[[i]]];
  If[max<Abs[temp],
    max = Max[Abs[temp],max];
    tempi = i;
    ];
  Print["e[",extremePts[[i]],"] = ",temp];
]
Print[" "];
If[max-Abs[err]>.1^4,
Print["The largest |error| = ",max," and occurs at x = ",extremePts[[tempi]],"."];
Print["This point should be swapped with one of"];
Print["the current alternation points."],
Print["There seems to be an alternation set of"];
Print["length ",Length[alt],", so we are done."];
]

:[font = input; wordwrap; preserveAspect]
alt[[2]] = -0.25;
mat = Table[{1, alt[[i1]],alt[[i1]]^2,(-1)^i1},
      {i1,Length[alt]}];
dat = Table[{f[alt[[i1]]]},{i1,Length[alt]}];
{a,b,c,err} = Flatten[Inverse[mat].dat];
Print["p[x] = ",a," + ",b," x + ",c," x^2"]
Print[" "];
Print["error = ",Table[e[alt[[i1]]],{i1,Length[alt]}],"...on the alternation set: ",alt];

Clear[e];
e[x_] := f[x]- a - b x - c x^2;
Plot[e[x],{x,left,right},
  Prolog->{PointSize[.02],
  Table[Point[{alt[[i1]],e[alt[[i1]]]}],{i1,Length[alt]}]}]

{localMin,localMax} = FindExtrema[e,left,right];
extremePts= Sort[Join[localMin,localMax]];
Print[" "];
Print["But the local min/max for the error functions are"];
Print[" "];
max = 0;
For[i=1,i<=Length[extremePts],i++,
  temp = e[extremePts[[i]]];
  If[max<Abs[temp],
    max = Max[Abs[temp],max];
    tempi = i;
    ];
  Print["e[",extremePts[[i]],"] = ",temp];
]
Print[" "];
If[max-Abs[err]>.1^4,
Print["The largest |error| = ",max," and occurs at x = ",extremePts[[tempi]],"."];
Print["This point should be swapped with one of"];
Print["the current alternation points."],
Print["There seems to be an alternation set of"];
Print["length ",Length[alt],", so we are done."];
]

;[s]
3:0,1;11,2;16,0;1160,-1;
3:1,12,10,Courier,1,12,0,0,0;1,12,10,Courier,1,12,65535,0,0;1,12,10,Courier,0,12,0,0,0;
:[font = input; wordwrap; preserveAspect; endGroup]
p[x_] := c x^2 + b x + a;

M= Max[Abs[{f[right],f[left],p[right],p[left]}]];
Plot[{f[x],p[x]},{x,left,right},
  PlotStyle->{Dashing[{1,0}],Dashing[{.02,.02}]},
  Prolog->{PointSize[.02],
  Table[Point[{alt[[i1]],f[alt[[i1]]]}],
     {i1,Length[alt]}]},
  PlotRange->1.05{-M,M}]
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Cubic approx with manual exchange
:[font = input; wordwrap; preserveAspect; startGroup]
Clear[f,x];
f[x_] := Abs[x-.5];
n=3;
alt = Table[left+i1/4.(right-left),{i1,0,4}];
mat = Table[{1, alt[[i1]],alt[[i1]]^2,alt[[i1]]^3,(-1)^i1},
      {i1,Length[alt]}];
dat = Table[{f[alt[[i1]]]},{i1,Length[alt]}];
{a,b,c,d,err} = Flatten[Inverse[mat].dat];
Print["p[x] = ",a," + ",b," x + ",c," x^2 + ",d," x^3"]
Print[" "];
Print["error = ",Table[e[alt[[i1]]],{i1,Length[alt]}],"...on the alternation set: ",alt];

Clear[e];
e[x_] := f[x]- a - b x - c x^2- d x^3;
Plot[e[x],{x,left,right},
  Prolog->{PointSize[.02],
  Table[Point[{alt[[i1]],e[alt[[i1]]]}],{i1,Length[alt]}]}]

{localMin,localMax} = FindExtrema[e,left,right];
extremePts= Sort[Join[localMin,localMax]];
Print[" "];
Print["But the local min/max for the error functions are"];
Print[" "];
max = 0;
For[i=1,i<=Length[extremePts],i++,
  temp = e[extremePts[[i]]];
  If[max<Abs[temp],
    max = Max[Abs[temp],max];
    tempi = i;
    ];
  Print["e[",extremePts[[i]],"] = ",temp];
]
Print[" "];
If[max-Abs[err]>.1^4,
Print["The largest |error| = ",max," and occurs at x = ",extremePts[[tempi]],"."];
Print["This point should be swapped with one of"];
Print["the current alternation points."],
Print["There seems to be an alternation set of"];
Print["length ",Length[alt],", so we are done."];
]

:[font = input; preserveAspect; endGroup]
alt[[5]]=0.802222;
mat = Table[{1, alt[[i1]],alt[[i1]]^2,alt[[i1]]^3,(-1)^i1},
      {i1,Length[alt]}];
dat = Table[{f[alt[[i1]]]},{i1,Length[alt]}];
{a,b,c,d,err} = Flatten[Inverse[mat].dat];
Print["p[x] = ",a," + ",b," x + ",c," x^2 + ",d," x^3"]
Print[" "];
Print["error = ",Table[e[alt[[i1]]],{i1,Length[alt]}],"...on the alternation set: ",alt];

Clear[e];
e[x_] := f[x]- a - b x - c x^2- d x^3;
Plot[e[x],{x,left,right},
  Prolog->{PointSize[.02],
  Table[Point[{alt[[i1]],e[alt[[i1]]]}],{i1,Length[alt]}]}]

{localMin,localMax} = FindExtrema[e,left,right];
extremePts= Sort[Join[localMin,localMax]];
Print[" "];
Print["But the local min/max for the error functions are"];
Print[" "];
max = 0;
For[i=1,i<=Length[extremePts],i++,
  temp = e[extremePts[[i]]];
  If[max<Abs[temp],
    max = Max[Abs[temp],max];
    tempi = i;
    ];
  Print["e[",extremePts[[i]],"] = ",temp];
]
Print[" "];
If[max-Abs[err]>.1^4,
Print["The largest |error| = ",max," and occurs at x = ",extremePts[[tempi]],"."];
Print["This point should be swapped with one of"];
Print["the current alternation points."],
Print["There seems to be an alternation set of"];
Print["length ",Length[alt],", so we are done."];
]

;[s]
3:0,0;9,1;17,0;1194,-1;
2:2,12,10,Courier,1,12,0,0,0;1,12,10,Courier,0,12,0,0,0;
:[font = input; wordwrap; preserveAspect; endGroup; endGroup]
p[x_] := d x^3+ c x^2 + b x + a;

M= Max[Abs[{f[right],f[left],p[right],p[left]}]];
Plot[{f[x],p[x]},{x,left,right},
  PlotStyle->{Dashing[{1,0}],Dashing[{.02,.02}]},
  Prolog->{PointSize[.02],
  Table[Point[{alt[[i1]],f[alt[[i1]]]}],
     {i1,Length[alt]}]},
  PlotRange->1.05{-M,M}]
:[font = section; inactive; Cclosed; preserveAspect; startGroup]
Best uniform approximation (manual Remez exchange)
f differentiable
;[s]
3:0,0;51,1;67,0;68,-1;
2:2,19,14,Times,1,18,0,0,0;1,19,14,Times,1,18,65535,0,0;
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Preliminaries
:[font = input; preserveAspect]
Off[General::spell,General::spell1];
;[s]
3:0,0;4,1;34,0;37,-1;
2:2,12,10,Courier,1,12,0,0,0;1,12,10,Courier,0,12,65535,0,0;
:[font = input; wordwrap; 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; wordwrap; preserveAspect]
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}]]
:[font = input; wordwrap; preserveAspect]
Squash[x_] := Table[If[Abs[x[[i1]]]<.1^12,0.,x],{i1,Length[x]}]
:[font = input; wordwrap; preserveAspect]
Clear[DashLine];
DashLine[a_,b_,n_]:= Table[Line[
{a+2 i2(b-a)/(2n+1),a+(2 i2+1)(b-a)/(2n+1)}],{i2,0,n}]

:[font = input; preserveAspect; endGroup]
Clear[FindExtrema];
FindExtrema[ff_,left_,right_] := Block[
{extremePts,i,temp,tol},
tol = .1^6;
Off[FindRoot::cvnwt];
extremePts = {left,right};
extremePts = Sort[Join[extremePts,
  Table[
  FindRoot[ff'[x]==0,{x,left+i1*.04 (right-left)}]
  [[1]][[2]],{i1,0,25}]]];
temp = {};
For[i=1,i<=Length[extremePts],i++,
    If[extremePts[[i]]>=left &&
       extremePts[[i]]<=right,
      temp=Append[temp,extremePts[[i]]];
      ];
    ];
extremePts = Sort[temp];
temp = {extremePts[[1]]};
  For[i=1,i<Length[extremePts],i++,
    If[extremePts[[i+1]]-extremePts[[i]]>tol,
      temp=Append[temp,extremePts[[i+1]]];
      ];
    ];
extremePts = temp;
temp = {};
  For[i=2,i<Length[extremePts],i++,
    If[Abs[ff'[extremePts[[i]]]]>.1^6,
      temp=Append[temp,extremePts[[i]]];
      ];
    ];
extremePts = Complement[extremePts,temp];
Return[{extremePts}];
]
;[s]
3:0,0;101,1;119,0;854,-1;
2:2,12,10,Courier,1,12,0,0,0;1,12,10,Courier,0,12,65535,0,0;
:[font = input; preserveAspect]
left = -1.;
right = 1.;

:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Linear approx with manual exchange
:[font = input; wordwrap; preserveAspect]
Clear[f,x,a,b,err];
f[x_] := x^2 Exp[-x];
n=1;
alt = Table[left+i1/2.(right-left),{i1,0,2}];
mat = Table[{1, alt[[i1]],(-1)^i1},
      {i1,Length[alt]}];
dat = Table[{f[alt[[i1]]]},{i1,Length[alt]}];
{a,b,err} = Flatten[Inverse[mat].dat];
Print["p[x] = ",a," + ",b," x"]
Print[" "];
Print["error = ",Table[e[alt[[i1]]],{i1,Length[alt]}],"...on the alternation set: ",alt];

Clear[e];
e[x_] := f[x]- a - b x;
Plot[e[x],{x,left,right},
  Prolog->{PointSize[.02],
  Table[Point[{alt[[i1]],e[alt[[i1]]]}],{i1,Length[alt]}]}]

extremePts = Sort[Flatten[FindExtrema[e,left,right]]];
Print[" "];
Print["But the local min/max for the error functions are"];
Print[" "];
max = 0;
For[i=1,i<=Length[extremePts],i++,
  temp = e[extremePts[[i]]];
  If[max<Abs[temp],
    max = Max[Abs[temp],max];
    tempi = i;
    ];
  Print["e[",extremePts[[i]],"] = ",temp];
]
Print[" "];
If[max-Abs[err]>.1^4,
Print["The largest |error| = ",max," and occurs at x = ",extremePts[[tempi]],"."];
Print["This point should be swapped with one of"];
Print["the current alternation points."],
Print["There seems to be an alternation set of"];
Print["length ",Length[alt],", so we are done."];
]
:[font = input; wordwrap; preserveAspect]
alt[[2]] =-0.351601;
mat = Table[{1, alt[[i1]],(-1)^i1},
      {i1,Length[alt]}];
dat = Table[{f[alt[[i1]]]},{i1,Length[alt]}];
{a,b,err} = Flatten[Inverse[mat].dat];
Print["p[x] = ",a," + ",b," x"]
Print[" "];
Print["error = ",Table[e[alt[[i1]]],{i1,Length[alt]}],"...on the alternation set: ",alt];

Clear[e];
e[x_] := f[x]- a - b x;
Plot[e[x],{x,left,right},
  Prolog->{PointSize[.02],
  Table[Point[{alt[[i1]],e[alt[[i1]]]}],{i1,Length[alt]}]}]

extremePts = Sort[Flatten[FindExtrema[e,left,right]]];
Print[" "];
Print["But the local min/max for the error functions are"];
Print[" "];
max = 0;
For[i=1,i<=Length[extremePts],i++,
  temp = e[extremePts[[i]]];
  If[max<Abs[temp],
    max = Max[Abs[temp],max];
    tempi = i;
    ];
  Print["e[",extremePts[[i]],"] = ",temp];
]
Print[" "];
If[max-Abs[err]>.1^4,
Print["The largest |error| = ",max," and occurs at x = ",extremePts[[tempi]],"."];
Print["This point should be swapped with one of"];
Print["the current alternation points."],
Print["There seems to be an alternation set of"];
Print["length ",Length[alt],", so we are done."];
]
;[s]
4:0,2;11,1;19,2;20,0;1091,-1;
3:1,12,10,Courier,1,12,0,0,0;1,12,10,Courier,0,12,0,0,0;2,12,10,Courier,1,12,65535,0,0;
:[font = input; wordwrap; preserveAspect; endGroup]
Clear[p];
p[x_] := b x + a;

M= Max[Abs[{f[right],f[left],p[right],p[left]}]];
Plot[{f[x],p[x]},{x,left,right},
  PlotStyle->{Dashing[{1,0}],Dashing[{.02,.02}]},
  Prolog->{PointSize[.02],
  Table[Point[{alt[[i1]],f[alt[[i1]]]}],
     {i1,Length[alt]}]},
  PlotRange->1.05{-M,M}]
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Quadratic approx with manual exchange
:[font = input; wordwrap; preserveAspect]
Clear[f,x];
f[x_] := x^2 Exp[-x];
n=2;
alt = Table[left+i1/3.(right-left),{i1,0,3}];
mat = Table[{1, alt[[i1]],alt[[i1]]^2,(-1)^i1},
      {i1,Length[alt]}];
dat = Table[{f[alt[[i1]]]},{i1,Length[alt]}];
{a,b,c,err} = Flatten[Inverse[mat].dat];
Print["p[x] = ",a," + ",b," x + ",c," x^2"]
Print[" "];
Print["error = ",Table[e[alt[[i1]]],{i1,Length[alt]}],"...on the alternation set: ",alt];

Clear[e];
e[x_] := f[x]- a - b x - c x^2;
Plot[e[x],{x,left,right},
  Prolog->{PointSize[.02],
Table[Point[{alt[[i1]],e[alt[[i1]]]}],{i1,Length[alt]}]}];

extremePts =  
   Sort[Flatten[FindExtrema[e,left,right]]];
Print[" "];
Print["But the local min/max for the error functions are"];
Print[" "];
max = 0;
For[i=1,i<=Length[extremePts],i++,
  temp = e[extremePts[[i]]];
  If[max<Abs[temp],
    max = Max[Abs[temp],max];
    tempi = i;
    ];
  Print["e[",extremePts[[i]],"] = ",temp];
]
Print[" "];
If[max-Abs[err]>.1^4,
Print["The largest |error| = ",max," and occurs at x = ",extremePts[[tempi]],"."];
Print["This point should be swapped with one of"];
Print["the current alternation points."],
Print["There seems to be an alternation set of"];
Print["length ",Length[alt],", so we are done."];
]

:[font = input; wordwrap; preserveAspect]
alt[[2]] = -0.606096;
mat = Table[{1, alt[[i1]],alt[[i1]]^2,(-1)^i1},
      {i1,Length[alt]}];
dat = Table[{f[alt[[i1]]]},{i1,Length[alt]}];
{a,b,c,err} = Flatten[Inverse[mat].dat];
Print["p[x] = ",a," + ",b," x + ",c," x^2"]
Print[" "];
Print["error = ",Table[e[alt[[i1]]],{i1,Length[alt]}],"...on the alternation set: ",alt];

Clear[e];
e[x_] := f[x]- a - b x - c x^2;
Plot[e[x],{x,left,right},
  Prolog->{PointSize[.02],
  Table[Point[{alt[[i1]],e[alt[[i1]]]}],{i1,Length[alt]}]}]

extremePts =  
   Sort[Flatten[FindExtrema[e,left,right]]];
Print[" "];
Print["But the local min/max for the error functions are"];
Print[" "];
max = 0;
For[i=1,i<=Length[extremePts],i++,
  temp = e[extremePts[[i]]];
  If[max<Abs[temp],
    max = Max[Abs[temp],max];
    tempi = i;
    ];
  Print["e[",extremePts[[i]],"] = ",temp];
]
Print[" "];
If[max-Abs[err]>.1^4,
Print["The largest |error| = ",max," and occurs at x = ",extremePts[[tempi]],"."];
Print["This point should be swapped with one of"];
Print["the current alternation points."],
Print["There seems to be an alternation set of"];
Print["length ",Length[alt],", so we are done."];
]

;[s]
3:0,1;11,2;21,0;1132,-1;
3:1,12,10,Courier,1,12,0,0,0;1,12,10,Courier,1,12,65535,0,0;1,12,10,Courier,0,12,0,0,0;
:[font = input; wordwrap; preserveAspect; endGroup]
Clear[p];
p[x_] := c x^2 + b x + a;

M= Max[Abs[{f[right],f[left],p[right],p[left]}]];
Plot[{f[x],p[x]},{x,left,right},
  PlotStyle->{Dashing[{1,0}],Dashing[{.02,.02}]},
  Prolog->{PointSize[.02],
  Table[Point[{alt[[i1]],f[alt[[i1]]]}],
     {i1,Length[alt]}]},
  PlotRange->1.05{-M,M}]
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Cubic approx with manual exchange
:[font = input; wordwrap; preserveAspect; startGroup]
Clear[f,x];
f[x_] := x^2 Exp[-x];
n=3;
alt = Table[left+i1/4.(right-left),{i1,0,4}];
mat = Table[{1, alt[[i1]],alt[[i1]]^2,alt[[i1]]^3,(-1)^i1},
      {i1,Length[alt]}];
dat = Table[{f[alt[[i1]]]},{i1,Length[alt]}];
{a,b,c,d,err} = Flatten[Inverse[mat].dat];
Print["p[x] = ",a," + ",b," x + ",c," x^2 + ",d," x^3"]
Print[" "];
Print["error = ",Table[e[alt[[i1]]],{i1,Length[alt]}],"...on the alternation set: ",alt];

Clear[e];
e[x_] := f[x]- a - b x - c x^2- d x^3;
Plot[e[x],{x,left,right},
  Prolog->{PointSize[.02],
  Table[Point[{alt[[i1]],e[alt[[i1]]]}],{i1,Length[alt]}]}]

extremePts =  
   Sort[Flatten[FindExtrema[e,left,right]]];
Print[" "];
Print["But the local min/max for the error functions are"];
Print[" "];
max = 0;
For[i=1,i<=Length[extremePts],i++,
  temp = e[extremePts[[i]]];
  If[max<Abs[temp],
    max = Max[Abs[temp],max];
    tempi = i;
    ];
  Print["e[",extremePts[[i]],"] = ",temp];
]
Print[" "];
If[max-Abs[err]>.1^4,
Print["The largest |error| = ",max," and occurs at x = ",extremePts[[tempi]],"."];
Print["This point should be swapped with one of"];
Print["the current alternation points."],
Print["There seems to be an alternation set of"];
Print["length ",Length[alt],", so we are done."];
]

:[font = input; preserveAspect; endGroup]
alt[[3]]=-0.079869;
mat = Table[{1, alt[[i1]],alt[[i1]]^2,alt[[i1]]^3,(-1)^i1},
      {i1,Length[alt]}];
dat = Table[{f[alt[[i1]]]},{i1,Length[alt]}];
{a,b,c,d,err} = Flatten[Inverse[mat].dat];
Print["p[x] = ",a," + ",b," x + ",c," x^2 + ",d," x^3"]
Print[" "];
Print["error = ",Table[e[alt[[i1]]],{i1,Length[alt]}],"...on the alternation set: ",alt];

Clear[e];
e[x_] := f[x]- a - b x - c x^2- d x^3;
Plot[e[x],{x,left,right},
  Prolog->{PointSize[.02],
  Table[Point[{alt[[i1]],e[alt[[i1]]]}],{i1,Length[alt]}]}]

extremePts =  
   Sort[Flatten[FindExtrema[e,left,right]]];
Print[" "];
Print["But the local min/max for the error functions are"];
Print[" "];
max = 0;
For[i=1,i<=Length[extremePts],i++,
  temp = e[extremePts[[i]]];
  If[max<Abs[temp],
    max = Max[Abs[temp],max];
    tempi = i;
    ];
  Print["e[",extremePts[[i]],"] = ",temp];
]
Print[" "];
If[max-Abs[err]>.1^4,
Print["The largest |error| = ",max," and occurs at x = ",extremePts[[tempi]],"."];
Print["This point should be swapped with one of"];
Print["the current alternation points."],
Print["There seems to be an alternation set of"];
Print["length ",Length[alt],", so we are done."];
]

;[s]
3:0,0;9,1;18,0;1163,-1;
2:2,12,10,Courier,1,12,0,0,0;1,12,10,Courier,0,12,0,0,0;
:[font = input; wordwrap; preserveAspect; endGroup; endGroup]
Clear[p];
p[x_] := d x^3+ c x^2 + b x + a;

M= Max[Abs[{f[right],f[left],p[right],p[left]}]];
Plot[{f[x],p[x]},{x,left,right},
  PlotStyle->{Dashing[{1,0}],Dashing[{.02,.02}]},
  Prolog->{PointSize[.02],
  Table[Point[{alt[[i1]],f[alt[[i1]]]}],
     {i1,Length[alt]}]},
  PlotRange->1.05{-M,M}]
:[font = section; inactive; Cclosed; preserveAspect; startGroup]
Fewer than n+2 alternation points? Not best.
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Preliminaries
:[font = input; preserveAspect]
Off[General::spell,General::spell1];
;[s]
3:0,0;4,1;34,0;37,-1;
2:2,12,10,Courier,1,12,0,0,0;1,12,10,Courier,0,12,65535,0,0;
:[font = input; wordwrap; 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; wordwrap; preserveAspect]
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}]]
:[font = input; wordwrap; preserveAspect]
Squash[x_] := Table[If[Abs[x[[i1]]]<.1^12,0.,x],{i1,Length[x]}]
:[font = input; preserveAspect]
Clear[FindLocalExtrema];
FindLocalExtrema[ff_,a_,b_] := Block[
{localMin,localMax,i,nn,vals},
nn=100;
vals = Table[ff[a+i1 1./nn (b-a)],{i1,0,nn}];
localMin = {};
localMax = {};
For[i=2,i<=nn,i++,
  If[vals[[i-1]] <= vals[[i]] &&
     vals[[i]] >= vals[[i+1]],
     localMax=Append[localMax,a+(i-1) 1./nn (b-a)]];
  If[vals[[i-1]] >= vals[[i]] &&
     vals[[i]] <= vals[[i+1]],
     localMin=Append[localMin,a+(i-1) 1./nn (b-a)]];
  ];
If[vals[[1]]<vals[[2]], 
  localMin=Append[localMin,a],
  localMax=Append[localMax,a]
  ];
If[vals[[n]]<vals[[n+1]], 
  localMax=Append[localMax,b],
  localMin=Append[localMin,b]
  ];
Return[{Sort[localMin],Sort[localMax]}];
];       
:[font = input; preserveAspect]
Clear[ZoomIn]
ZoomIn[ff_,x_,left_,right_] := Block[
{d,z},
d = (right-left)/100;
If[ff[x]<=Min[ff[x-d],ff[x+d]],
  locale[z_] := ff[z];
  index = 1;,
  locale[z_] := -ff[z];
  index = 2;
  ];
z=FindLocalExtrema[locale,x-d,x+d][[index,1]];
d=d/10;
z=FindLocalExtrema[locale,x-d,x+d][[index,1]];
d=d/10;
z=FindLocalExtrema[locale,x-d,x+d][[index,1]];
d=d/10;
z=FindLocalExtrema[locale,x-d,x+d][[index,1]];
d=d/10;
z=FindLocalExtrema[locale,x-d,x+d][[index,1]];
Return[z];
];
:[font = input; preserveAspect]
Clear[FindExtrema];
FindExtrema[ff_,left_,right_] := Block[
{localMin,localMax,i,temp,tol},
tol = .1^6;
{localMin,localMax}=
  FindLocalExtrema[ff,left,right];
For[i=1,i<=Length[localMin],i++,
  If[left<localMin[[i]] &&
     localMin[[i]] < right,
     localMin[[i]] = 
       ZoomIn[e,localMin[[i]],left,right]
    ];
  ];
For[i=1,i<=Length[localMax],i++,
  If[left<localMax[[i]] &&
     localMax[[i]] < right,
     localMax[[i]] = 
       ZoomIn[e,localMax[[i]],left,right]
    ];
  ];
If[Length[localMin]>0,
  temp = {localMin[[1]]};
  For[i=1,i<Length[localMin],i++,
    If[localMin[[i+1]]-localMin[[i]]>tol,
      temp=Append[temp,localMin[[i+1]]];
      ];
    ];
  ];
localMin = temp;
If[Length[localMax]>0,
  temp = {localMax[[1]]};
  For[i=1,i<Length[localMax],i++,
    If[localMax[[i+1]]-localMax[[i]]>tol,
      temp=Append[temp,localMax[[i+1]]];
      ];
    ];
  ];
localMax = temp;
Return[{localMin,localMax}];
]
:[font = input; wordwrap; preserveAspect; endGroup]
Clear[DashLine];
DashLine[a_,b_,n_]:= Table[Line[
{a+2 i2(b-a)/(2n+1),a+(2 i2+1)(b-a)/(2n+1)}],{i2,0,n}]

:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Create sample error function by shifting and normalizaing Chebyshev polynomials
:[font = input; wordwrap; preserveAspect; endGroup]
Clear[f,p,e];
a1 = 8/9.;
b1 = 1/9.;
n = 7;
f[x_] := x^n;
e[x_] := Expand[ChebyshevT[n,a1 (x-b1)]/a1^n/2^(n-1)]
p[x_] := f[x]-e[x];
c = Table[Coefficient[p[x],x^i1],{i1,n-1}];
c = Prepend[c,p[0]];

Clear[p];
p[x_] := c[[1]]+Sum[c[[i1]] x^(i1-1),{i1,2,n}];
Print["f[x]=",f[x]];
Print["p[x]=",Expand[p[x]]];
pic0=Plot[{f[x],p[x]},{x,-1,1},
PlotStyle->{Dashing[{1,0}],Dashing[{.02,.02}]}]

pic1=Plot[e[x],{x,-1,1}]
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Determine maximum error, and find alternation set
:[font = input; preserveAspect; endGroup]
(* Maximum error *)
Print["The uniform error is ",
rho = funcNorm[e,Infinity,-1,1]]
Print[" "];

(* Determine alternation set *)
{localMin,localMax} = FindExtrema[e,left,right];
extremePts = Sort[Join[localMin,localMax]];
Print["The local extrema occur at and are: "];
max = 0;
For[i=1,i<=Length[extremePts],i++,
  temp = e[extremePts[[i]]];
  If[max<Abs[temp],
    max = Max[Abs[temp],max];
    tempi = i;
    ];
  Print["e[",extremePts[[i]],"] = ",temp];
]
Print[" "];
alt = {};
For[i=1,i<=Length[extremePts],i++,
  If[Abs[Abs[e[extremePts[[i]]]]-max]<.1^3,
    alt = Append[alt,extremePts[[i]]];
    ];
  ];
Print["The points "];
Print[alt]
Print["form an alternation set of length ",Length[alt],"<n+2=",n+2]
pic3=Show[pic1,

Graphics[DashLine[{-1,rho},{1,rho},20]],

Graphics[DashLine[{-1,-rho},{1,-rho},20]],
Table[
Graphics[DashLine[{alt[[i1]],0},
{alt[[i1]],e[alt[[i1]]]},5]],
{i1,Length[alt]}]]
;[s]
4:0,1;20,0;97,1;129,0;903,-1;
2:2,12,10,Courier,1,12,0,0,0;2,12,10,Courier,1,12,65535,0,0;
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Subdivide into intervals where maximum deviation in e(x) is rho/2.
:[font = input; wordwrap; preserveAspect; endGroup]
(* Subdivide into intervals where w(d)<rho/2 *)
endpts = {};
For[i=1,i<=100,i++,
  endpts = Append[endpts,
  FindRoot[e[x]==rho/2,{x,-1.+2 i .01}][[1,2]]];
  endpts = Append[endpts,
  FindRoot[e[x]==0,{x,-1+2 i .01}][[1,2]]];
  endpts = Append[endpts,
  FindRoot[e[x]==-rho/2,{x,-1+2 i .01}][[1,2]]];
];
endpts = Sort[endpts];
tol = .1^3;
keep = {};
keepIndex = {};
For[i=1,i<Length[endpts],i++,
  If[endpts[[i+1]]-endpts[[i]]<tol &&
     endpts[[i]]>=-1 &&
     endpts[[i]]<=1,
     keepIndex = Append[keepIndex,i],
     keepIndex = Append[keepIndex,i];
     keep =  Append[keep,
       Sum[Part[endpts,keepIndex][[i1]],
       {i1,Length[keepIndex]}]/
       Length[keepIndex]];
       keepIndex={};
    ]
 ]
dropIndex = {};
For[i=1,i<=Length[keep],i++,
  If[keep[[i]]<-1 || keep[[i]]>1, 
    dropIndex = Append[dropIndex,i]
    ];
  ]
keep = Complement[keep,Part[keep,dropIndex]];
endpts = keep;
endpts = Prepend[endpts,-1.];
endpts = Append[endpts,1.];

Print["The interval endpoints are :"]
Print[" "];

Print[endpts]
int = Table[{endpts[[i1]],endpts[[i1+1]]},
   {i1,Length[endpts]-1}];
   
pic4=Show[pic1,
Table[
Graphics[DashLine[{endpts[[i1]],-rho},{endpts[[i1]],rho},10]],{i1,Length[endpts]}]
]
;[s]
2:0,1;48,0;1205,-1;
2:1,12,10,Courier,1,12,0,0,0;1,12,10,Courier,1,12,65535,0,0;
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Select the intervals where the extreme values are attained positively and negatively.
:[font = input; wordwrap; preserveAspect; endGroup]
(* Determine plus and minus intervals *)
plusIntervals={};
minusIntervals={};
For[i=1,i<Length[int],i++,
For[j=1,j<=Length[alt],j++,
  If[int[[i,1]]<alt[[j]] &&
     alt[[j]]<int[[i,2]],
     If[e[alt[[j]]]>0,
     plusIntervals=Append[plusIntervals,i],
     minusIntervals=Append[minusIntervals,i]]];
     ];
     ];
Print["Below are pictured the (+) and the (-) intervals"]
pic2=Show[pic3,

Table[Graphics[{AbsoluteThickness[4],Line[{{int[[plusIntervals[[i1]],1]],0},{int[[plusIntervals[[i1]],2]],0}}]}],{i1,Length[plusIntervals]}],

Table[Graphics[Text["+",{int[[plusIntervals[[i1]],1]]+int[[plusIntervals[[i1]],2]],-rho/3}/2]],{i1,Length[plusIntervals]}],

Table[Graphics[{AbsoluteThickness[4],Line[{{int[[minusIntervals[[i1]],1]],0},{int[[minusIntervals[[i1]],2]],0}}]}],{i1,Length[minusIntervals]}],

Table[Graphics[Text["-",{int[[minusIntervals[[i1]],1]]+int[[minusIntervals[[i1]],2]],rho/3}/2]],{i1,Length[minusIntervals]}],

Axes->False
]

;[s]
2:0,1;41,0;949,-1;
2:1,12,10,Courier,1,12,0,0,0;1,12,10,Courier,1,12,65535,0,0;
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Determine R, the complement of the (+) and (-) intervals
:[font = input; wordwrap; preserveAspect; endGroup]
(* Determine complement of (+) and (-) intervals *)
R=Table[{},{Length[alt]+1}];
set = Union[plusIntervals,minusIntervals];
If[set[[1]]!=1,  
  R[[1]] = N[{-1.,int[[set[[1]]-1,2]]}]];
If[Last[set]!=Length[endpts]-1,  
  R[[Length[alt]+1]] = N[{int[[Last[set],2]],1.}]];
For[i=1,i<Length[set],i++,
  R[[i+1]] = N[{
    int[[set[[i]],2]],
    int[[set[[i+1]],1]]}];
  ]
Print["The maximum of |e(x)| on the set R, the complement ","of the (+) and the (-) intervals, is ",rhoPrime];

rhoPrime = 0;
For[i=1,i<=Length[R],i++,
  rhoPrime = Max[rhoPrime,
      funcNorm[e,
               Infinity,
               R[[i,1]],
               R[[i,2]]]];
      ]
  
pic3=Show[pic1,

Table[
Graphics[DashLine[{endpts[[i1]],0},{endpts[[i1]],e[endpts[[i1]]]},3]],{i1,Length[endpts]}],

Graphics[DashLine[{-1,rhoPrime},{1,rhoPrime},20]],

Graphics[DashLine[{-1,-rhoPrime},{1,-rhoPrime},20]],

Table[
Graphics[{AbsoluteThickness[4],
Line[{{R[[i1,1]],0},{R[[i1,2]],0}}]}],
{i1,Length[R]}],

Axes->False]
;[s]
2:0,1;52,0;985,-1;
2:1,12,10,Courier,1,12,0,0,0;1,12,10,Courier,1,12,65535,0,0;
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Select z values from the interior intervals of R, and define q(x).
:[font = input; wordwrap; preserveAspect; endGroup]
(* Determine z values for q(x) *)
temp = Table[1+2Random[],{Length[alt]}]/3;
z = Table[(R[[i1,1]]+R[[i1,2]])/2,
{i1,2,Length[alt]}];

sign = 1;
q[x_] := sign Product[(z[[i1]]-x),{i1,Length[z]}];
sign = Sign[q[alt[[1]]] e[alt[[1]]]];

M = funcNorm[q,Infinity,-1,1];
lam = .99 Min[rho-rhoPrime,rho/2]/M;

pic5=Plot[rho q[x]/q[1],{x,-1,1},
  PlotStyle->Dashing[{.02,.02}],
  Prolog->{PointSize[.02],
  Table[Point[{z[[i1]],0}],{i1,Length[z]}]}]
  
Show[pic2,pic5,Graphics[{PointSize[.02],
  Table[Point[{z[[i1]],0}],{i1,Length[z]}]}]]
;[s]
2:0,1;34,0;532,-1;
2:1,12,10,Courier,1,12,0,0,0;1,12,10,Courier,1,12,65535,0,0;
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Add a multiple of  q(x) to the current best approximate p(x) to show it is not "best".
:[font = input; wordwrap; preserveAspect; endGroup; endGroup]
newP[x_] := p[x]+lam q[x];
newE[x_] := e[x]-lam q[x];
newRho=funcNorm[newE,Infinity,-1,1];

Show[pic1,
pic6=Plot[lam q[x],{x,-1,1},
PlotStyle->Dashing[{.02,.02}],Prolog->{PointSize[.02]
,
Table[Point[{z[[i1]],0}],{i1,Length[z]}]}],

Graphics[{PointSize[.02],
  Table[Point[{z[[i1]],0}],{i1,Length[z]}]}]
  ]
  
  
Plot[{f[x]-p[x],f[x]-newP[x],
rho,-rho,newRho,-newRho},{x,-1,1},
PlotStyle->{Dashing[{1.,.00}],Dashing[{.02,.02}],
Dashing[{1.,.00}],Dashing[{1.,.00}],Dashing[{.02,.02}],Dashing[{.02,.02}]}]
:[font = section; inactive; Cclosed; preserveAspect; startGroup]
Best uniform approximation on finite set
;[s]
3:0,0;30,1;36,0;41,-1;
2:2,19,14,Times,1,18,0,0,0;1,19,14,Times,1,18,65535,0,0;
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Stand alone illustration of best uniform n-th degree fit on n+2 points
:[font = input; preserveAspect]
Clear[f, w, wp, p, L]; 
n = 3; 

x = Sort[Table[2*Random[] - 1, {n + 2}]]; 
Show[Graphics[{PointSize[0.02], Table[Point[{x[[i1]], 0}], 
     {i1, n + 2}]}], Graphics[
   Line[{{-1, -0.1}, {-1, 0.1}}]], 
  Graphics[Line[{{1, -0.1}, {1, 0.1}}]], 
  Graphics[Line[{{-1, 0}, {1, 0}}]], 
  PlotRange -> {-1, 1}]
  
f[t_] := Abs[t]; 
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Lagrange polynomials
:[font = input; preserveAspect; endGroup]
Clear[Lagrange]; 
Lagrange[t_, j_] := 
  Product[(t - x[[i1]])/(x[[j]] - x[[i1]]), {i1, j - 1}]*
   Product[(t - x[[i1]])/(x[[j]] - x[[i1]]), 
    {i1, j + 1, n + 2}]
    
Plot[{1, Lagrange[t, 1], Lagrange[t, 2], Lagrange[t, 3], 
   Lagrange[t, 4], Lagrange[t, 5]}, {t, -1, 1}, 
  Prolog -> {PointSize[0.02], Table[Point[{x[[i1]], 0}], 
     {i1, Length[x]}],Table[Point[{x[[i1]], 1}], 
     {i1, Length[x]}]}, PlotRange -> {-2, 2}]
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Clever mathematical alternative, but difficult from programing perspective.
                                   w[t]
Lagrange[t,k] = --------------------
                         ( t-x(k) )w'[x(k)]
:[font = input; preserveAspect; endGroup]
Clear[w, wp]; 
w[t_] := Product[t - x[[i1]], {i1, n + 2}]; 

wp[t_] := Block[{i, val, i1}, 
   For[i = 1, i <= n + 2, i++, If[Abs[t - x[[i]]] < 0.1^10, 
       Return[Product[t - x[[i1]], {i1, i - 1}]*
         Product[t - x[[i1]], {i1, i + 1, n + 2}]]]; ]; 
    Return[w[t]*Sum[1/(t - x[[i1]]), {i1, n + 2}]]; ]
    
Plot[{w[t], wp[t]}, {t, -1, 1}, 
  Prolog -> {PointSize[0.02], 
    Table[Point[{x[[i1]], wp[x[[i1]]]}], {i1, Length[x]}], 
    Table[Point[{x[[i1]], 0}], {i1, Length[x]}]},
    PlotStyle->{Dashing[{1,0}],Dashing[{.02,.02}]}]
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Compare two definitions of polynomial p[t] interpolating f[t] at x(1)<x(2)<...<x(n+2)
:[font = input; preserveAspect; endGroup]
Clear[P,p]; 
P[t_] := Sum[w[t]*(f[x[[i1]]]/(t - x[[i1]])/wp[x[[i1]]]), 
   {i1, n + 2}]
   
p[t_] := Sum[f[x[[i1]]]*Lagrange[t, i1], {i1, n + 2}]
Print["p[t] = ",Expand[p[t]]]

Plot[{P[t]-p[t]}, {t, -1, 1},      
   PlotRange->{-.1^14,.1^14}]
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Define p*, the best approximate
:[font = input; preserveAspect; endGroup; endGroup]
Clear[L,l]; 
L[t_] := Sum[w[t]*((-1)^i1/(t - x[[i1]])/wp[x[[i1]]]), 
   {i1, n + 2}]
   
l[t_] := Sum[(-1)^i1*Lagrange[t, i1], {i1, n + 2}]
Print["l[t] = ",Expand[l[t]]]


lambda = Sum[f[x[[i1]]]/wp[x[[i1]]], {i1, n + 2}]/
         Sum[(-1)^i1/wp[x[[i1]]], {i1, n + 2}]
   
pstar[t_] := p[t] - lambda*l[t]; 

e[t_] := f[t] - pstar[t]; 

Plot[{f[t], pstar[t]}, {t, -1, 1}, 
  Prolog -> {PointSize[0.02], 
    Table[Point[{x[[i1]], f[x[[i1]]]}], {i1, Length[x]}]}]

Plot[{e[t], lambda, -lambda}, {t, -1, 1}, 
  Prolog -> {PointSize[0.02], 
    Table[Point[{x[[i1]], f[x[[i1]]] - pstar[x[[i1]]]}], 
     {i1, Length[x]}]}]
;[s]
3:0,0;274,1;308,0;620,-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]
Example in book, page 36
:[font = text; inactive; Cclosed; preserveAspect; startGroup]
Preliminaries
:[font = input; preserveAspect]
Clear[w, wp]; 
w[t_] := Product[t - x[[i1]], {i1, n + 2}]; 

wp[t_] := Block[{i, val, i1}, 
   For[i = 1, i <= n + 2, i++, If[Abs[t - x[[i]]] < 0.1^10, 
       Return[Product[t - x[[i1]], {i1, i - 1}]*
         Product[t - x[[i1]], {i1, i + 1, n + 2}]]]; ]; 
    Return[w[t]*Sum[1/(t - x[[i1]]), {i1, n + 2}]]; ]

:[font = input; preserveAspect; endGroup]
Clear[Lagrange]; 
Lagrange[t_, j_] := 
  Product[(t - x[[i1]])/(x[[j]] - x[[i1]]), {i1, j - 1}]*
   Product[(t - x[[i1]])/(x[[j]] - x[[i1]]), 
    {i1, j + 1, n + 2}]

:[font = input; Cclosed; preserveAspect; startGroup]
superSet={-1,-.5,0,.5,1};
n=2;
f[t_] := Abs[t];
max = 0;
where = 0;
For[i=1,i<=Binomial[Length[superSet],n+2],i++,
  x= Sort[Part[RotateLeft[superSet,i],
     Table[i1,{i1,n+2}]]];
  lambda = Sum[f[x[[i1]]]/wp[x[[i1]]], {i1, n + 2}]/
   Sum[(-1)^i1/wp[x[[i1]]], {i1, n + 2}];
  
  Print[{x,lambda}];
  If[max<lambda,
    max=lambda; 
    where = i;
    ];
  ]
:[font = print; inactive; preserveAspect]
{{-0.5, 0, 0.5, 1}, -0.125}
{{-1, 0, 0.5, 1}, -0.111111}
{{-1, -0.5, 0.5, 1}, 0.}
{{-1, -0.5, 0, 1}, 0.111111}
{{-1, -0.5, 0, 0.5}, 0.125}
:[font = input; preserveAspect; startGroup]
x= Sort[Part[RotateLeft[superSet,where],
     Table[i1,{i1,n+2}]]];
  lambda = Sum[f[x[[i1]]]/wp[x[[i1]]], {i1, n + 2}]/
   Sum[(-1)^i1/wp[x[[i1]]], {i1, n + 2}]
  p[t_] := Sum[f[x[[i1]]]*Lagrange[t, i1], {i1, n + 2}];
   
  l[t_] := Sum[(-1)^i1*Lagrange[t, i1], {i1, n + 2}];

pstar[t_] := p[t] - lambda*l[t]; 
Expand[pstar[t]]

  e[t_] := f[t] - pstar[t]; 

:[font = output; output; inactive; preserveAspect]
0.125
;[o]
0.125
:[font = output; output; inactive; preserveAspect; endGroup]
0.125 - 5.551115123125783*10^-17*t + 1.*t^2 + 
 
  2.220446049250313*10^-16*t^3
;[o]
                  -17         2             -16  3
0.125 - 5.55112 10    t + 1. t  + 2.22045 10    t
:[font = input; preserveAspect; startGroup]
   
Plot[{f[t], pstar[t]}, {t, -1, 1}, 
  Prolog -> {PointSize[0.02], 
    Table[Point[{x[[i1]], f[x[[i1]]]}], {i1, Length[x]}]}]

Plot[{e[t], lambda, -lambda}, {t, -1, 1}, 
  Prolog -> {PointSize[0.02], 
    Table[Point[{x[[i1]], f[x[[i1]]] - pstar[x[[i1]]]}], 
     {i1, Length[x]}]}]
:[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.47619 0.0147151 0.523203 [
[(-1)] .02381 .01472 0 2 Msboxa
[(-0.5)] .2619 .01472 0 2 Msboxa
[(0.5)] .7381 .01472 0 2 Msboxa
[(1)] .97619 .01472 0 2 Msboxa
[(0.2)] .4875 .11936 1 0 Msboxa
[(0.4)] .4875 .224 1 0 Msboxa
[(0.6)] .4875 .32864 1 0 Msboxa
[(0.8)] .4875 .43328 1 0 Msboxa
[(1)] .4875 .53792 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 .01472 m
.02381 .02097 L
s
P
[(-1)] .02381 .01472 0 2 Mshowa
p
.002 w
.2619 .01472 m
.2619 .02097 L
s
P
[(-0.5)] .2619 .01472 0 2 Mshowa
p
.002 w
.7381 .01472 m
.7381 .02097 L
s
P
[(0.5)] .7381 .01472 0 2 Mshowa
p
.002 w
.97619 .01472 m
.97619 .02097 L
s
P
[(1)] .97619 .01472 0 2 Mshowa
p
.001 w
.07143 .01472 m
.07143 .01847 L
s
P
p
.001 w
.11905 .01472 m
.11905 .01847 L
s
P
p
.001 w
.16667 .01472 m
.16667 .01847 L
s
P
p
.001 w
.21429 .01472 m
.21429 .01847 L
s
P
p
.001 w
.30952 .01472 m
.30952 .01847 L
s
P
p
.001 w
.35714 .01472 m
.35714 .01847 L
s
P
p
.001 w
.40476 .01472 m
.40476 .01847 L
s
P
p
.001 w
.45238 .01472 m
.45238 .01847 L
s
P
p
.001 w
.54762 .01472 m
.54762 .01847 L
s
P
p
.001 w
.59524 .01472 m
.59524 .01847 L
s
P
p
.001 w
.64286 .01472 m
.64286 .01847 L
s
P
p
.001 w
.69048 .01472 m
.69048 .01847 L
s
P
p
.001 w
.78571 .01472 m
.78571 .01847 L
s
P
p
.001 w
.83333 .01472 m
.83333 .01847 L
s
P
p
.001 w
.88095 .01472 m
.88095 .01847 L
s
P
p
.001 w
.92857 .01472 m
.92857 .01847 L
s
P
p
.002 w
0 .01472 m
1 .01472 L
s
P
p
.002 w
.5 .11936 m
.50625 .11936 L
s
P
[(0.2)] .4875 .11936 1 0 Mshowa
p
.002 w
.5 .224 m
.50625 .224 L
s
P
[(0.4)] .4875 .224 1 0 Mshowa
p
.002 w
.5 .32864 m
.50625 .32864 L
s
P
[(0.6)] .4875 .32864 1 0 Mshowa
p
.002 w
.5 .43328 m
.50625 .43328 L
s
P
[(0.8)] .4875 .43328 1 0 Mshowa
p
.002 w
.5 .53792 m
.50625 .53792 L
s
P
[(1)] .4875 .53792 1 0 Mshowa
p
.001 w
.5 .03564 m
.50375 .03564 L
s
P
p
.001 w
.5 .05657 m
.50375 .05657 L
s
P
p
.001 w
.5 .0775 m
.50375 .0775 L
s
P
p
.001 w
.5 .09843 m
.50375 .09843 L
s
P
p
.001 w
.5 .14028 m
.50375 .14028 L
s
P
p
.001 w
.5 .16121 m
.50375 .16121 L
s
P
p
.001 w
.5 .18214 m
.50375 .18214 L
s
P
p
.001 w
.5 .20307 m
.50375 .20307 L
s
P
p
.001 w
.5 .24492 m
.50375 .24492 L
s
P
p
.001 w
.5 .26585 m
.50375 .26585 L
s
P
p
.001 w
.5 .28678 m
.50375 .28678 L
s
P
p
.001 w
.5 .30771 m
.50375 .30771 L
s
P
p
.001 w
.5 .34957 m
.50375 .34957 L
s
P
p
.001 w
.5 .37049 m
.50375 .37049 L
s
P
p
.001 w
.5 .39142 m
.50375 .39142 L
s
P
p
.001 w
.5 .41235 m
.50375 .41235 L
s
P
p
.001 w
.5 .45421 m
.50375 .45421 L
s
P
p
.001 w
.5 .47513 m
.50375 .47513 L
s
P
p
.001 w
.5 .49606 m
.50375 .49606 L
s
P
p
.001 w
.5 .51699 m
.50375 .51699 L
s
P
p
.001 w
.5 .55885 m
.50375 .55885 L
s
P
p
.001 w
.5 .57977 m
.50375 .57977 L
s
P
p
.001 w
.5 .6007 m
.50375 .6007 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
.02 w
.02381 .53792 Mdot
.2619 .27632 Mdot
.5 .01472 Mdot
.7381 .27632 Mdot
P
p
p
p
.004 w
.02381 .53792 m
.06349 .49432 L
.10317 .45072 L
.14286 .40712 L
.18254 .36352 L
.22222 .31992 L
.2619 .27632 L
.30159 .23272 L
.34127 .18912 L
.38095 .14552 L
.42063 .10192 L
.46032 .05832 L
.48016 .03652 L
.49008 .02562 L
.49504 .02017 L
.49752 .01744 L
.49876 .01608 L
.5 .01472 L
.50248 .01744 L
.50496 .02017 L
.50992 .02562 L
.51984 .03652 L
.53968 .05832 L
.57937 .10192 L
.61905 .14552 L
.65873 .18912 L
.69841 .23272 L
.7381 .27632 L
.77778 .31992 L
.81746 .36352 L
.85714 .40712 L
.89683 .45072 L
.93651 .49432 L
.97619 .53792 L
s
P
P
p
p
.004 w
.02381 .60332 m
.06349 .51975 L
.10317 .44345 L
.14286 .37442 L
.18254 .31265 L
.22222 .25815 L
.2619 .21092 L
.30159 .17095 L
.34127 .13825 L
.38095 .11282 L
.40079 .10282 L
.42063 .09465 L
.44048 .08829 L
.4504 .08579 L
.46032 .08375 L
.47024 .08216 L
.4752 .08153 L
.48016 .08102 L
.48512 .08063 L
.4876 .08047 L
.49008 .08034 L
.49256 .08024 L
.4938 .0802 L
.49504 .08017 L
.49628 .08015 L
.49752 .08013 L
.49876 .08012 L
.5 .08012 L
.50124 .08012 L
.50248 .08013 L
.50372 .08015 L
.50496 .08017 L
.5062 .0802 L
.50744 .08024 L
.50992 .08034 L
.5124 .08047 L
.51488 .08063 L
.51984 .08102 L
.5248 .08153 L
.52976 .08216 L
.53968 .08375 L
.5496 .08579 L
.55952 .08829 L
.57937 .09465 L
.59921 .10282 L
.61905 .11282 L
.65873 .13825 L
.69841 .17095 L
.7381 .21092 L
.77778 .25815 L
Mistroke
.81746 .31265 L
.85714 .37442 L
.89683 .44345 L
.93651 .51975 L
.97619 .60332 L
Mfstroke
P
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.47619 0.309017 2.35442 [
[(-1)] .02381 .30902 0 2 Msboxa
[(-0.5)] .2619 .30902 0 2 Msboxa
[(0.5)] .7381 .30902 0 2 Msboxa
[(1)] .97619 .30902 0 2 Msboxa
[(-0.1)] .4875 .07358 1 0 Msboxa
[(-0.05)] .4875 .1913 1 0 Msboxa
[(0.05)] .4875 .42674 1 0 Msboxa
[(0.1)] .4875 .54446 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 .30902 m
.02381 .31527 L
s
P
[(-1)] .02381 .30902 0 2 Mshowa
p
.002 w
.2619 .30902 m
.2619 .31527 L
s
P
[(-0.5)] .2619 .30902 0 2 Mshowa
p
.002 w
.7381 .30902 m
.7381 .31527 L
s
P
[(0.5)] .7381 .30902 0 2 Mshowa
p
.002 w
.97619 .30902 m
.97619 .31527 L
s
P
[(1)] .97619 .30902 0 2 Mshowa
p
.001 w
.07143 .30902 m
.07143 .31277 L
s
P
p
.001 w
.11905 .30902 m
.11905 .31277 L
s
P
p
.001 w
.16667 .30902 m
.16667 .31277 L
s
P
p
.001 w
.21429 .30902 m
.21429 .31277 L
s
P
p
.001 w
.30952 .30902 m
.30952 .31277 L
s
P
p
.001 w
.35714 .30902 m
.35714 .31277 L
s
P
p
.001 w
.40476 .30902 m
.40476 .31277 L
s
P
p
.001 w
.45238 .30902 m
.45238 .31277 L
s
P
p
.001 w
.54762 .30902 m
.54762 .31277 L
s
P
p
.001 w
.59524 .30902 m
.59524 .31277 L
s
P
p
.001 w
.64286 .30902 m
.64286 .31277 L
s
P
p
.001 w
.69048 .30902 m
.69048 .31277 L
s
P
p
.001 w
.78571 .30902 m
.78571 .31277 L
s
P
p
.001 w
.83333 .30902 m
.83333 .31277 L
s
P
p
.001 w
.88095 .30902 m
.88095 .31277 L
s
P
p
.001 w
.92857 .30902 m
.92857 .31277 L
s
P
p
.002 w
0 .30902 m
1 .30902 L
s
P
p
.002 w
.5 .07358 m
.50625 .07358 L
s
P
[(-0.1)] .4875 .07358 1 0 Mshowa
p
.002 w
.5 .1913 m
.50625 .1913 L
s
P
[(-0.05)] .4875 .1913 1 0 Mshowa
p
.002 w
.5 .42674 m
.50625 .42674 L
s
P
[(0.05)] .4875 .42674 1 0 Mshowa
p
.002 w
.5 .54446 m
.50625 .54446 L
s
P
[(0.1)] .4875 .54446 1 0 Mshowa
p
.001 w
.5 .09712 m
.50375 .09712 L
s
P
p
.001 w
.5 .12066 m
.50375 .12066 L
s
P
p
.001 w
.5 .14421 m
.50375 .14421 L
s
P
p
.001 w
.5 .16775 m
.50375 .16775 L
s
P
p
.001 w
.5 .21484 m
.50375 .21484 L
s
P
p
.001 w
.5 .23838 m
.50375 .23838 L
s
P
p
.001 w
.5 .26193 m
.50375 .26193 L
s
P
p
.001 w
.5 .28547 m
.50375 .28547 L
s
P
p
.001 w
.5 .33256 m
.50375 .33256 L
s
P
p
.001 w
.5 .35611 m
.50375 .35611 L
s
P
p
.001 w
.5 .37965 m
.50375 .37965 L
s
P
p
.001 w
.5 .40319 m
.50375 .40319 L
s
P
p
.001 w
.5 .45028 m
.50375 .45028 L
s
P
p
.001 w
.5 .47383 m
.50375 .47383 L
s
P
p
.001 w
.5 .49737 m
.50375 .49737 L
s
P
p
.001 w
.5 .52091 m
.50375 .52091 L
s
P
p
.001 w
.5 .05003 m
.50375 .05003 L
s
P
p
.001 w
.5 .02649 m
.50375 .02649 L
s
P
p
.001 w
.5 .00294 m
.50375 .00294 L
s
P
p
.001 w
.5 .568 m
.50375 .568 L
s
P
p
.001 w
.5 .59155 m
.50375 .59155 L
s
P
p
.001 w
.5 .61509 m
.50375 .61509 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
.02 w
.02381 .01472 Mdot
.2619 .60332 Mdot
.5 .01472 Mdot
.7381 .60332 Mdot
P
p
p
p
.004 w
.02381 .01472 m
.06349 .19457 L
.10317 .34172 L
.14286 .45617 L
.1627 .50113 L
.18254 .53792 L
.20238 .56653 L
.2123 .57777 L
.22222 .58697 L
.23214 .59412 L
.2371 .59693 L
.24206 .59923 L
.24702 .60102 L
.2495 .60172 L
.25198 .6023 L
.25446 .60274 L
.2557 .60292 L
.25694 .60306 L
.25818 .60318 L
.25942 .60326 L
.26066 .6033 L
.2619 .60332 L
.26314 .6033 L
.26438 .60326 L
.26563 .60318 L
.26687 .60306 L
.26935 .60274 L
.27183 .6023 L
.27431 .60172 L
.27679 .60102 L
.28175 .59923 L
.28671 .59693 L
.29167 .59412 L
.30159 .58697 L
.31151 .57777 L
.32143 .56653 L
.34127 .53792 L
.36111 .50113 L
.38095 .45617 L
.42063 .34172 L
.46032 .19457 L
.48016 .10873 L
.49008 .06274 L
.49504 .03898 L
.49752 .02691 L
.49876 .02083 L
.5 .01472 L
.50248 .02691 L
.50496 .03898 L
.50992 .06274 L
Mistroke
.51984 .10873 L
.53968 .19457 L
.57937 .34172 L
.61905 .45617 L
.63889 .50113 L
.65873 .53792 L
.67857 .56653 L
.68849 .57777 L
.69841 .58697 L
.70833 .59412 L
.71329 .59693 L
.71825 .59923 L
.72321 .60102 L
.72569 .60172 L
.72817 .6023 L
.73065 .60274 L
.73189 .60292 L
.73313 .60306 L
.73438 .60318 L
.73562 .60326 L
.73686 .6033 L
.7381 .60332 L
.73934 .6033 L
.74058 .60326 L
.74182 .60318 L
.74306 .60306 L
.74554 .60274 L
.74802 .6023 L
.7505 .60172 L
.75298 .60102 L
.75794 .59923 L
.7629 .59693 L
.76786 .59412 L
.77778 .58697 L
.7877 .57777 L
.79762 .56653 L
.81746 .53792 L
.8373 .50113 L
.85714 .45617 L
.89683 .34172 L
.93651 .19457 L
.97619 .01472 L
Mfstroke
P
P
p
p
.004 w
.02381 .60332 m
.06349 .60332 L
.10317 .60332 L
.14286 .60332 L
.18254 .60332 L
.22222 .60332 L
.2619 .60332 L
.30159 .60332 L
.34127 .60332 L
.38095 .60332 L
.42063 .60332 L
.46032 .60332 L
.5 .60332 L
.53968 .60332 L
.57937 .60332 L
.61905 .60332 L
.65873 .60332 L
.69841 .60332 L
.7381 .60332 L
.77778 .60332 L
.81746 .60332 L
.85714 .60332 L
.89683 .60332 L
.93651 .60332 L
.97619 .60332 L
s
P
P
p
p
.004 w
.02381 .01472 m
.06349 .01472 L
.10317 .01472 L
.14286 .01472 L
.18254 .01472 L
.22222 .01472 L
.2619 .01472 L
.30159 .01472 L
.34127 .01472 L
.38095 .01472 L
.42063 .01472 L
.46032 .01472 L
.5 .01472 L
.53968 .01472 L
.57937 .01472 L
.61905 .01472 L
.65873 .01472 L
.69841 .01472 L
.7381 .01472 L
.77778 .01472 L
.81746 .01472 L
.85714 .01472 L
.89683 .01472 L
.93651 .01472 L
.97619 .01472 L
s
P
P
P
% End of Graphics
MathPictureEnd

:[font = output; output; inactive; preserveAspect; endGroup; endGroup; endGroup; endGroup]
Graphics["<<>>"]
;[o]
-Graphics-
^*)