(* This program is by Adrian Mariano: adrian@u.washington.edu * * Copyright (c) 1991, The Geometry Center * University of Minnesota * 1300 South Second Street * Minneapolis, MN 55454 * * email address: software@geom.umn.edu * * This software is copyrighted as noted above. It may be freely copied, * modified, and redistributed, provided that the copyright notice is * preserved on all copies. * * There is no warranty or other guarantee of fitness for this software, * it is provided solely "as is". Bug reports or fixes may be sent * to the authors, who may or may not act on them as they desire. * * You may not include this software in a program or other software product * without supplying the source, or without informing the end-user that the * source is available for no extra charge. * * If you modify this software, you should include a notice giving the * name of the person performing the modification, the date of modification, * and the reason for such modification. * * The National Science and Technology Research Center for * Computation and Visualization of Geometric Structures *) (* Modified by David Reiss for WRI to make more Mathematica 3.0 compatible (3/16/98): Changed BeginPackage["Caustic`", "ParallelCurves`", "Algebra`Trigonometry`"] to BeginPackage["Caustic`", "ParallelCurves`"] Package not otherwise tested for 3.0 compatibility or functionality. *) Needs["ParallelCurves`"] BeginPackage["Caustic`", "ParallelCurves`"] EqnEllipse::usage = "EqnEllipse[a, {i, j}, t] If a caustic is drawn to an ellipse with axes a and 1 from a light source at {i,j}, the caustic may have asymptotes. The roots of this equation of t give the t values for the points at infinity, assuming the parametrization {a Cos[t], Sin[x]}."; EqnCircle::usage= "EqnCircle[i, t] If a caustic is drawn to a unit circle from the point {i,0}, it may have asymptotes. The roots of this equation of t give the t values for the points at infinity, assuming the usual parametrization for the circle."; CausticBadEqn::usage= "CausticBadEqn[{fx,fy}, {i,j}, t] Given the mirror defined by {fx,fy}, the caustic from {i,j} may have asymtotes. This function returns an equation whose roots are the parameter values for the points at infinity of the specified caustic."; EllipseCaustic::usage= "EllipseCaustic[a, {i, j}, t] Gives the equation for a caustic to the ellipse {a Cos[t], Sin[t]} from the point {i,j}."; CircleCaustic::usage= "CircleCaustic[i_, t_] Gives the equation for the caustic to the unit circle from the point {i,0}."; CircleCausticBad::usage= "CircleCausticBad[i_] Returns a list of parameter values near which the caustic to the unit circle from {i,0} is not defined."; EllipseCausticBad::usage= "EllipseCausticBad[a, {i, j}] Returns a list of parameter values near which the caustic to the ellipse from {i,j} is not defined."; CausticBad::usage= "CausticBad[{fx,fy}, {i,j}, {t, tmin, tmax}] Returns the points in {tmin, tmax} which give bad sections of the caustic to {fx,fy} from {i,j}."; PlotCircleCaustic::usage= "PlotCircleCaustic[i, plotrange, ] Plot the caustic to a unit circle from the point {i,0}, skipping over asymtotes. Options are ShowSource->False to turn off display of the light source, DotSize->n to change the size of the light source from the default of .015, and ShowCurve->False to turn off display of the mirror curve. Other options are passed to Show."; PlotEllipseCaustic::usage= "PlotEllipseCaustic[a, {i, j}, plotrange, ] Plot the caustic to an ellipse {a Cos[t], Sin[t]} from the point {i,j}, skipping over asymtotes. Options are ShowSource->False to turn off display of the light source, DotSize->n to change the size of the light source from the default of .015, and ShowCurve->False to turn off display of the mirror curve. Other options are passed to Show."; PlotCaustic::usage= "PlotCaustic[{fx,fy}, {i, j}, {t, tmin, tmax}, plotrange, ] Plots the caustic to {fx,fy} from the light source {i,j} over the t range specified, skipping over asymptotes. Options are ShowSource->False to turn off display of the light source, DotSize->n to change the size of the light source from the default of .015, and ShowCurve->False to turn off display of the mirror curve. Other options are passed to Show."; Orthotomic::usage= "Orthotomic[{fx,fy}, {x,y}, t, opts] Returns an expression for the orthotomic of {fx,fy} with respect to the point (x,y). The curve {fx,fy} is specified parametrically in t. The only option is to disable simplification with Simplify->False."; Caustic::usage= "Caustic[{fx,fy}, {x,y}, t, opts] Returns expression for the caustic of the mirror specified parametrically in {fx,fy} with respect to the light source {x,y}. The only option is to disable simplification with Simplify->False."; QuickGraphCaustic::usage= "QuickGraphCaustic[{fx,fy}, {x,y}, {t, tmin, tmax}, opts] Graph the caustic of the curve {fx,fy} with respect to the light source {x,y} as t goes from tmin to tmax. Options are passed on to ParametricPlot. No attempt is made to skip over asymptotes in the caustic."; Begin["`private`"] Options[Orthotomic] = {Simplify->True}; Orthotomic[f:{fx_,fy_}, point:{_, _}, t_, opts___] := Block[ {n, norm, simplify}, simplify = Simplify /. {opts} /. Options[Orthotomic]; If[simplify, simp[expr_]:=TrigReduce[Simplify[expr]], simp[expr_]:=expr]; n = simp[{-D[fy,t], D[fx,t]}]; norm = simp[n / simp[Sqrt[ n . n ]]]; simp[2 ( (f-point) . norm ) norm + point] ] Caustic[mirror:{_,_},source:{_,_}, t_, opts___] := Block[ {f}, f=Orthotomic[mirror, source, t, opts]; Evolute[f,t, opts] ] QuickGraphCaustic[mirror:{_,_},source:{_,_},trange:{t_,_,_},opts___]:= Block[ {f}, f=Caustic[mirror, source, t]; ParametricPlot[f,trange,opts]; ] PlotBad[f_, bad_, {x_, xmin_, xmax_}, opts___]:= Block[{graphs,ranges}, ranges=Partition[Prepend[Append[bad,xmax],xmin],2,1]; count=Length[ranges]; Do[ graphs[i]=ParametricPlot[f, {x, ranges[[i,1]]+.01, ranges[[i,2]]-.01}, DisplayFunction->Identity, opts], {i, 1, count}]; Apply[Show, Join[Map[graphs, Table[n, {n,count}]], {opts, DisplayFunction->$DisplayFunction}]] ] EqnEllipse[a_,{i_,j_}, x_] = 2*a*i^2 + 2*a*j^2 - 4*a^2*i*Cos[x] + 2*a^3*Cos[x]^2 + i*Cos[x]^3 - a*Cos[x]^4 - 4*a*j*Sin[x] + a*j*Cos[x]^2*Sin[x] + 2*a*Sin[x]^2 + a^2*i*Cos[x]*Sin[x]^2 - a*Cos[x]^2*Sin[x]^2 - a^3*Cos[x]^2*Sin[x]^2 + a^3*j*Sin[x]^3 - a^3*Sin[x]^4; EqnCircle[i_, x_] = 1 + 2*i^2-3*i*Cos[x]; AllRoots[f_, {x_, xmin_, xmax_}]:= Block[ {xx,mesh=(xmax-xmin)/107,data,interest={} }, data=N[Table[{xx, Sign[f ]/. x->xx}, {xx, xmin, xmax, mesh}]]; Do[ If[Last[data[[i]]] != Last[data[[i-1]]], AppendTo[interest,(First[data[[i]]]+First[data[[i-1]]])/2]], {i, 2, Length[data]}]; Map[ x /. FindRoot[f==0, {x, #}]&, interest] ] EllipseCaustic[a_,{i_,j_}, x_]= Caustic[{a Cos[x], Sin[x]}, {i,j}, x]; CircleCaustic[i_,x_] := {-i+(3 Cos[x]/2-Cos[3 x]/2) i^2, i^2 / 2 * (3 Sin[x] - Sin[3 x])} / (1-i 3 Cos[x] + 2 i i) CircleCausticBad[i_] := Block[{temp=ArcCos[(1/i+2 i)/3]}, If[i>1 || i<=.5, {},N[{temp, 2 Pi-temp}]] ] EllipseCausticBad[aa_, S:{ii_, jj_}] := Block[{xx}, AllRoots[EqnEllipse[a,S,x],{xx, 0, 2 Pi}] ] Options[PlotCircleCaustic] := { ShowSource->True, ShowCurve->True, DotSize->.015}; PlotCircleCaustic[i_, plotrange_, opts___]:= Block[ {showcurve,showsource,dotsize, dot={}, curve={} }, {showcurve, showsource, dotsize} = {ShowCurve, ShowSource, DotSize} /. {opts} /. Options[PlotCircleCaustic]; If[showcurve, curve=ParametricPlot[{Cos[x],Sin[x]},{x,0,2 Pi}, DisplayFunction->Identity,Axes->None]]; if[showsource, dot=Graphics[{PointSize[dotsize], Point[{i,0}]}]]; Show[ PlotBad[CircleCaustic[i,x], CircleCausticBad[i], {x, 0, 2 Pi}, Axes->None,DisplayFunction->Identity],dot,curve, PlotRange->plotrange, DisplayFunction->$DisplayFunction, Sequence@@Select[{opts}, !MemberQ[First /@ Options[CausticMovie], First[#]]&], AspectRatio->Automatic ] ] Options[PlotEllipseCaustic] := { ShowSource->True, ShowCurve->True, DotSize->.015}; PlotEllipseCaustic[a_, S:{i_,j_}, plotrange_, opts___]:= Block[ {showcurve,showsource,dotsize, dot={}, curve={} }, {showcurve, showsource, dotsize} = {ShowCurve, ShowSource, DotSize} /. {opts} /. Options[PlotCircleCaustic]; If[showcurve, curve=ParametricPlot[{a Cos[x],Sin[x]},{x,0,2 Pi}, DisplayFunction->Identity,Axes->None]]; if[showsource, dot=Graphics[{PointSize[dotsize],Point[{i,j}]}]]; Show[ curve, dot, PlotBad[EllipseCaustic[a, S, x], EllipseCausticBad[a,S], {x, 0, 2 Pi}, Axes->None, DisplayFunction->Identity], PlotRange->plotrange, DisplayFunction->$DisplayFunction, Sequence@@Select[{opts}, !MemberQ[First /@ Options[CausticMovie], First[#]]&], AspectRatio->Automatic ] ] CausticBadEqn[mirror:{mx_, my_}, source_, t_]:= Block[ {n,norm,kappa}, n={-D[my,t],D[mx,t]}; norm=n/Sqrt[n . n]; kappa = D[mirror,t,t] . norm / D[mirror,t] . D[mirror,t]; 2 kappa ((mirror-source) . (mirror-source) ) + (mirror-source). norm ] CausticBad[mirror:{mx_, my_}, source_, trange:{t_, tmin_,tmax_}]:= AllRoots[CausticBadEqn[mirror,source,t], trange] Options[PlotCaustic] := { ShowSource->True, ShowCurve->True, DotSize->.015}; PlotCaustic[mirror_, source_, trange:{t_, tmin_, tmax_}, plotrange_, opts___]:= Block[ {showcurve,showsource,dotsize, dot={}, curve={} }, {showcurve, showsource, dotsize} = {ShowCurve, ShowSource, DotSize} /. {opts} /. Options[PlotCaustic]; If[showcurve, curve=ParametricPlot[mirror,trange, DisplayFunction->Identity,Axes->None]]; if[showsource, dot=Graphics[{PointSize[dotsize], Point[source]}]]; thecaustic=Caustic[mirror,source,t]; badpoints=CausticBad[mirror,source,trange]; Show[ curve, dot , PlotBad[thecaustic, badpoints, {t,tmin,tmax}, Axes->None, DisplayFunction->Identity] , PlotRange->plotrange, DisplayFunction->$DisplayFunction, Sequence@@Select[{opts}, !MemberQ[First /@ Options[CausticMovie], First[#]]&], AspectRatio->Automatic ] ] End[] EndPackage[]