Finding Roots Using Binary or Interpolation Search

quad[x_]:=0.3*(x-4)*(x-1)-0.3;
quad1[x_]:=-0.3*(x-4)*(x-1)+0.2;
cos[x_]:=Cos[1.5*x];
expo[x_]:=2*Exp[-x]-0.6;
cube[x_]:=(x-1.1)^3;

plotoptions={PlotRange->{{0,2.5},{-1,1}}, PlotRangePadding->0.25,AspectRatio->Automatic,ImageSize->400};

Manipulate[

If[TrueQ[pt[[1]]>pt2[[1]]], {p1:=pt[[1]];p2:=pt2[[1]]}, {p2:=pt[[1]];p1:=pt2[[1]]}];

b:=((func[p1]-func[p2])/(p1-p2)*p1-func[p1])/((func[p1]-func[p2])/(p1-p2));
If[TrueQ[Sign[func[b]]==Sign[func[p1]]],pp1:=p2,pp1:=p1];
b1:=((func[b]-func[pp1])/(b-pp1)*b-func[b])/((func[b]-func[pp1])/(b-pp1));
If[TrueQ[Sign[func[b1]]==Sign[func[pp1]]],pp2:=b,pp2:=pp1];
b2:=((func[b1]-func[pp2])/(b1-pp2)*b1-func[b1])/((func[b1]-func[pp2])/(b1-pp2));
If[TrueQ[Sign[func[b2]]==Sign[func[pp2]]],pp3:=b1,pp3:=pp2];
b3:=((func[b2]-func[pp3])/(b2-pp3)*b2-func[b2])/((func[b2]-func[pp3])/(b2-pp3));

p3:=(p2+p1)/2;
p4:=If[TrueQ[func[p3]*Sign[func'[1]]>0],(p3+p2)/2,(p3+p1)/2];
p5:=If[TrueQ[func[p3]*Sign[func'[1]]>0],
If[TrueQ[func[p4]*Sign[func'[1]]>0],(p4+p2)/2,(p4+p3)/2],
If[TrueQ[func[p4]*Sign[func'[1]]>0],(p4+p3)/2,(p4+p1)/2]
];
p6:=If[TrueQ[func[p3]*Sign[func'[1]]>0],
If[TrueQ[func[p4]*Sign[func'[1]]>0],
If[TrueQ[func[p5]*Sign[func'[1]]>0 ], (p5+p2)/2 ,(p5+p4)/2],
If[TrueQ[func[p5]*Sign[func'[1]]>0 ], (p5+p4)/2 ,(p5+p3)/2],
],
If[TrueQ[func[p4]*Sign[func'[1]]>0],
If[TrueQ[func[p5]*Sign[func'[1]]>0 ], (p5+p3)/2 ,(p5+p4)/2],
If[TrueQ[func[p5]*Sign[func'[1]]>0 ], (p5+p4)/2 ,(p5+p1)/2]
]
];

Show[Plot[{func[x],
If[TrueQ[is==True],(func[p1]-func[p2])/(p1-p2)*(x-p1)+func[p1],{}],
If[TrueQ[k>1 && is==True],(func[b]-func[pp1])/(b-pp1)*(x-b)+func[b],{}],
If[TrueQ[k>2 && is==True],(func[b1]-func[pp2])/(b1-pp2)*(x-b1)+func[b1],{}],If[TrueQ[k>3 && is==True],(func[b2]-func[pp3])/(b2-pp3)*(x-b2)+func[b2],{}]
}, {x,-1,3}, PlotStyle->{{Thickness[0.005]},{Thickness[0.001]},{Thickness[0.001]},{Thickness[0.001]},{Thickness[0.001]}},Evaluate[plotoptions],Filling->{1->Axis}],Graphics[{PointSize[.015],Point[{p1,func[p1]}]}],
Graphics[{PointSize[.015],Point[{p2,func[p2]}]}],
If[TrueQ[k>1 && is==True],Graphics[{PointSize[.01],Point[{b,func[b]}]}],{}],
If[TrueQ[k>2 && is==True],Graphics[{PointSize[.01],Point[{b1,func[b1]}]}],{}],
If[TrueQ[k>3 && is==True],Graphics[{PointSize[.01],Point[{b2,func[b2]}]}],{}],
If[TrueQ[is==True],Graphics[{PointSize[.01], Lighter[Blue],Point[{b,0}]}],{}],
If[TrueQ[k>1 && is==True],Graphics[{PointSize[.01], Blue,Point[{b1,0}]}],{}],
If[TrueQ[k>2 && is==True],Graphics[{PointSize[.01], Darker[Blue],Point[{b2,0}]}],{}],
If[TrueQ[k>3 && is==True],Graphics[{PointSize[.01], Darker[Blue],Point[{b3,0}]}],{}],
Graphics[{Dashed,Line[{{pt[[1]],-1},{pt[[1]],1}}]}],
Graphics[{Dashed,Line[{{pt2[[1]],-1},{pt2[[1]],1}}]}],
If[TrueQ[bs==True],Graphics[{PointSize[.01],Magenta,Point[{p3,0}]}],{}],
If[TrueQ[bs==True],Graphics[{Dashed,Line[{{p3,-0.5},{p3,0.5}}]}],{}],
If[TrueQ[k>1 && bs==True],Graphics[{PointSize[.01], Darker[Magenta],Point[{p4,0}]}],{}],
If[TrueQ[k>1 && bs==True],Graphics[{Dashed,Line[{{p4,-0.25},{p4,0.25}}]}],{}],
If[TrueQ[k>2 && bs==True],Graphics[{PointSize[.01], Darker[Darker[Magenta]],Point[{p5,0}]}],{}],
If[TrueQ[k>2 && bs==True],Graphics[{Dashed,Line[{{p5,-0.125},{p5,0.125}}]}],{}],
If[TrueQ[k>3 && bs==True],Graphics[{PointSize[.01], Darker[Darker[Magenta]],Point[{p6,0}]}],{}],
If[TrueQ[k>3 && bs==True],Graphics[{Dashed,Line[{{p6,-0.0625},{p6,0.0625}}]}],{}]

],
{{func,cos,""},{quad->"quadratic",quad1->"quadratic 2",cos->"cosine",expo->"exponential", cube->"cubic"},ControlType->RadioButtonBar,ControlPlacement->Top},
{{pt,{2.5,0}},{0,0},{10,0},Locator,Appearance->Style["|",20,Bold,Red]},
{{pt2,{0.5,0}},{-5,0},{10,0},Locator,Appearance->Style["|",20,Bold,Red]},
{{k,1,"steps"},Range[1,4],ControlType->SetterBar,ControlPlacement->Left},
{{bs,True,"binary search"},{True,False},ControlPlacement->Left},
{{is,True,"interpolation \nsearch"},{True,False},ControlPlacement->Left},
TrackedSymbols:>{pt,pt2,k,func,bs,is},SaveDefinitions->True
]

THIS NOTEBOOK IS THE SOURCE CODE FROM

"Finding Roots Using Binary or Interpolation Search" from The Wolfram Demonstrations Project
 http://demonstrations.wolfram.com/FindingRootsUsingBinaryOrInterpolationSearch/

Contributed by: Filip Piękniewski

A full-function Wolfram Mathematica 6 system is required to edit this notebook.
GET WOLFRAM MATHEMATICA 6 »

© The Wolfram Demonstrations Project & Contributors   |   Terms of Use   |   Make a new version of this Demonstration »