Holditch's Theorem

Author

Eric W. Weisstein
October 19, 2003

This notebook downloaded from http://mathworld.wolfram.com/notebooks/PlaneGeometry/HolditchsTheorem.nb.

For more information, see Eric's MathWorld entry http://mathworld.wolfram.com/HolditchsTheorem.html.

©2005 Wolfram Research, Inc. except for portions noted otherwise

Code

Holditch[] works only if the equation for t0 can be solved analytically.  Perhaps this could be done better using ImplicitPlot

FunctionCurve::usage =
"FunctionCurve[{f,g},{t1,t2}] returns a Graphics objects of the curve for the
parametric function {f[t],g[t]} for t between {t1,t2}.";

Holditch::usage =
"Holditch[{x,y,t},{p,q}] gives the parameter t0 of the other end of
the Holditch line segment of length p+q starting at {x[t],y[t]}.";

HolditchCircle::usage =
"HolditchCircle[dt,{p,q}] returns a HolditchPlot for a circle of unit
radius and parameters {p,q}, together with a dashed circle of radius
Sqrt[1-pq].";

HolditchCurve::usage =
"HolditchCurve[{f,g},{t1,t2},{p,q}] returns a Graphics objects which
is the Holditch curve for the
parametric function {f[t],g[t]} for t between {t1,t2} for parameters p and q.";

HolditchLine::usage =
"HolditchLine[{f,g,t},{p,q}] returns the Holditch line for the
parametric function {f[t],g[t]} at t for parameters p and q.";

HolditchLines::usage =
"HolditchLines[{f,g},{t1,t2,dt},{p,q}] returns the Holditch lines for the
parametric function {f[t],g[t]} for t between t1 and t2 with step size dt
for parameters p and q.";

HolditchMovie::usage =
"HolditchMove";

HolditchPlot::usage =
"HolditchPlot[{f,g},{t1,t2,dt},{p,q},<opts>] plots the original parametric
curve {f[t],g[t]} for t between t1 and t2, the corresponding Holditch curve
speicified by parameters {p,q}, and the chords with endpoints for t between
t1 and t2 by steps of dt.";

HolditchPoint::usage =
"HolditchPoint[{f,g,t},{p,q}] gives the point on the Holditch curve
of the parametric function {f[t],g[t]} for t for parameters p and q.";

HolditchPoints::usage =
"HolditchPoints[{f,g},{t1,t2,dt},{p,q}] gives points on the Holditch curve
of the parametric function {f[t],g[t]} for t between t1 and t2 by steps of
dt for parameters p and q.";

Holditch[{x_,y_,t_},{p_,q_}]:=Module[{t0,s},Off[Solve::ifun];
soln=Select[t0/.Solve[p+q==Sqrt[(x[t]-x[t0])^2+(y[t]-y[t0])^2],t0],Im[#]==0&];
(*Pick the chord which has endpoint in a counterclockwise direction*)s=If[Length[soln]==1,soln,If[x[t]y[soln[[1]]]-x[soln[[1]]]y[t]>0,soln[[1]],soln[[2]]]];
{x[s],y[s]}]

HolditchCircle[dt_,{p_,q_}]:=Show[{HolditchPlot[{Cos,Sin},{p,q},{0,2Pi,dt},DisplayFunction->Identity],Graphics[{Dashing[{.06,.06}],Thickness[.02],Circle[{0,0},Sqrt[1-p q]]}]},DisplayFunction->$DisplayFunction]

HolditchCurve[{f_,g_},{p_,q_},{t1_,t2_}]:=Module[{t},Off[ParametricPlot::ppcom];
ParametricPlot[HolditchPoint[{f,g,t},{p,q}][[1]],{t,t1,t2},Axes->False,AspectRatio->Automatic,DisplayFunction->Identity][[1]]]

FunctionCurve[{f_,g_},{t1_,t2_}]:=Module[{t},ParametricPlot[{f[t],g[t]},{t,t1,t2},Axes->False,AspectRatio->Automatic,DisplayFunction->Identity][[1]]]

HolditchLine[{f_,g_,t_},{p_,q_}]:=Module[{},Line[{{f[t],g[t]},Holditch[{f,g,t},{p,q}]}]]

HolditchLines[{f_,g_},{p_,q_},{t1_,t2_,dt_}]:=Module[{t},Table[HolditchLine[{f,g,t},{p,q}],{t,t1,t2,dt}]]

HolditchMovie[{f_,g_},{p_,q_},{t1_,t2_,dt_},opts___]:=Module[{t,tt,fc=FunctionCurve[{f,g},{t1,t2}],hc=HolditchCurve[{f,g},{p,q},{t1,t2}]},Table[Show[Graphics[{fc,hc,{Thickness[.01],Table[HolditchLine[{f,g,t},{p,q}],{t,t1,tt,dt}]}},opts,AspectRatio->Automatic]],{tt,t1,t2,dt}]]

HolditchPoint[{f_,g_,t_},{p_,q_}]:=Module[{line=HolditchLine[{f,g,t},{p,q}][[1]],l1,l2,dl},l1=line[[1]];
l2=line[[2]];
dl=l2-l1;
Point[l1+p(l2-l1)/Sqrt[dl.dl]]]

HolditchPlot[{f_,g_},{p_,q_},{t1_,t2_,dt_},opts___]:=Module[{},Show[Graphics[{FunctionCurve[{f,g},{t1,t2}],HolditchCurve[{f,g},{p,q},{t1,t2}],HolditchLines[{f,g},{p,q},{t1,t2,dt}],{PointSize[.03],GrayLevel[.7],HolditchPoints[{f,g},{p,q},{t1,t2,dt}]},{PointSize[.03],FunctionPoints[{f,g},{t1,t2,dt}]}}],AspectRatio->Automatic,opts]]

HolditchPoints[{f_,g_},{t1_,t2_,dt_},{p_,q_}]:=Module[{t},Table[HolditchPoint[{f,g,t},{p,q}],{t,t1,t2,dt}]]

FunctionPoints[{f_,g_},{t1_,t2_,dt_}]:=Module[{t},Table[Point[{f[t],g[t]}],{t,t1,t2,dt}]]

Graphics

HolditchCircle[2Pi/10,{.6,.7}]

p1=HolditchPlot[{Cos,Sin},{0,2Pi,2Pi/10},{.2,.9}]

p2=HolditchPlot[{Cos,Sin},{0,2Pi,2Pi/10},{1,.7}]

HalfSine[x_]:=.5Sin[x];

p3=HolditchPlot[{Cos,HalfSine},{0,2Pi,2Pi/10},{.4,.4}]

b[t_]:=(2+Cos[t])Sin[t]/3;

p4=HolditchPlot[{Cos,b},{0,2Pi,2Pi/10},{.5,.3}]

Show[GraphicsArray[{{p1,p2},{p3,p4}}]]

b[t_]:=(2+Cos[t])Sin[t]/3;

HolditchPlot[{Cos,b},{.5,.3},{0,2Pi,2Pi/10}]

HolditchPlot[{Cos,(2+Cos[#])Sin[#]/3&},{.5,.3},{0,2Pi,2Pi/10}]

HolditchMovie[{f_,g_},{p_,q_},{t1_,t2_,dt_},opts___]:=Module[{t,tt,
fc=FunctionCurve[{f,g},{t1,t2}],
hc=HolditchCurve[{f,g},{p,q},{t1,t2}]},Table[Show[Graphics[{fc,hc,{Thickness[.01],Table[HolditchLine[{f,g,t},{p,q}],{t,t1,tt,dt}]}},opts,AspectRatio->Automatic]],{tt,t1,t2,dt}];
]

HolditchMovie[{Cos,Sin},{.5,.3},{0,2Pi,2Pi/10}]