BeginPackage["Sphere`", "Orthogonalize`"]
ResolveCircle3D::usage = "ResolveCircle3D is a set of rules to convert
Circle[center, radius, normal] into a Mathematica Line primitive representing
the circle in 3D graphics."
ResolveSpheres::usage = "ResolveSpheres is a set of rules to convert
Sphere[center, radius] into appropriate Mathematica graphics primitives
to simulate the effect of a sphere in the given position. To do this
ResolveSpheres must know the PlotRange and ViewPoint options in use
and in particular, both must be set. To set these values use
(ResolveSpheres /. Options[Graphics3D]) or similar. TSphere[center, radius]
represents a transparent sphere in the same way."
ResolveSpheres::noplotrange = "Sphere in this picture will be incorrectly
positioned since the PlotRange option has not been set."
Sphere::usage = "Sphere[center, radius] represents a solid sphere
with the given center and radius. ResolveSpheres converts this into
a disk which seen from the current viewpoint should look like the
required sphere."
TSphere::usage = "TSphere[center, radius] represents a transparent sphere
with the given center and radius. ResolveSpheres converts this into
a circle which seen from the current viewpoint should look like the
required sphere."
(*
Circle::usage = "Circle[center, radius, normal] represents a Circle in
3 dimensional space. ResolveCircle3D converts this into a Line graphics
primitive which Mathematica recognizes."
Disk::usage = "Disk[center, radius, normal] represents a Disk in
3 dimensional space. ResolveCircle3D converts this into a Polygon graphics
primitive which Mathematica recognizes."
*)
Begin["`private`"]
pi = N[Pi]
(* functions for computing the ViewPoint in user coordinates *)
longestSide[plotrange_]:=
Max[- Apply[Subtract, plotrange, {1}]]
boxCenter[plotrange_]:=
(Plus @@ Transpose[plotrange])/2
trueViewPoint[viewpoint_, plotrange_]:=
longestSide[plotrange] viewpoint + boxCenter[plotrange]//N
trueViewPoint[viewpoint_, Automatic]:=
(Message[ResolveSpheres::noplotrange]; viewpoint)
(* rules for drawing 3D Circles and Spheres *)
ResolveCircle3D = {
Circle[c_, r_, n_]:> Block[{u,v},
{u,v} = r Drop[ONBasis[{n}],1];
Line[Table[u Cos[a] + v Sin[a] + c,
{a, 0, 2 pi, 2 pi/30}]]],
Disk[c_, r_, n_]:> Polygon[
Drop[(Circle[c,r,n] /. ResolveCircle3D)[[1]],-1]]}
ResolveSpheres = {
TSphere[c_,r_]:> Block[
{n = trueViewPoint[ViewPoint, PlotRange] - c},
Circle[c,r/Sqrt[1 - r r/(n.n)],n] /. ResolveCircle3D],
Sphere[c_,r_]:> Block[
{n = trueViewPoint[ViewPoint, PlotRange] - c},
Disk[c,r/Sqrt[1 - r r/(n.n)],n] /. ResolveCircle3D]};
End[]
EndPackage[]