Search All of the Math Forum:

Views expressed in these public forums are not endorsed by NCTM or The Math Forum.

Notice: We are no longer accepting new posts, but the forums will continue to be readable.

Topic: Help needed on how plot a stereographic projection
Replies: 7   Last Post: May 31, 2013 3:18 AM

 Messages: [ Previous | Next ]
 Bob Hanlon Posts: 906 Registered: 10/29/11
Re: Help needed on how plot a stereographic projection
Posted: May 31, 2013 3:16 AM

ClearAll[stereographicProjection];

stereographicProjection::usage =
"stereographicProjection[complexnumber] will return the stereoprojection
of \
a complex point considering the Riemann sphere";

SyntaxInformation[stereographicProjection] = {"ArgumentsPattern" -> {_}};

stereographicProjection[complexnumber_] :=
Module[{abs2 = Abs[complexnumber]^2},
If[abs2 == Infinity, {0, 0, 1}, {Re[complexnumber]/(1 + abs2),
Im[complexnumber]/(1 + abs2), abs2/(1 + abs2)}]]

t1 = Timing[tab3Old = Table[stereographicProjection[
(s + 1)/(s^2 (s - 1)) /. {s -> I w}],
{w, -1000, 1000, 0.1}] // Quiet;];

To speed up the calculation of tab3Old

(s + 1)/(s^2 (s - 1)) /. {s -> I w} //
ComplexExpand // Simplify

(I - w)/(w^2 (I + w))

t2 = Timing[tab3New = stereographicProjection[
(I - #)/(#^2 (I + #))] & /@
Range[-1000, 1000, 0.1] //
Quiet;];

Verifying that tab3New is identical to tab3Old and calculated faster

{tab3Old == tab3New, t2[[1]]/t1[[1]]}

{True, 0.58843}

To color the line you could break the line up into small line segments and
color each line segment separately. However, this would significantly slow
down the graphic generation and display. First, thin out the data where it
is dense.

Length[tab3New]

20001

Length[tab3NewRev =
Last /@ (SortBy[#, Abs[.5 - #[[-1]]] &] & /@
Split[tab3New, Abs[#1[[-1]] - #2[[-1]]] < 0.001 &])]

65

Generating and setting colors for line segments

g4 = {Hue[#[[1, -1]]], Line[#]} & /@
Partition[tab3NewRev, 2, 1];

Show[
ParametricPlot3D[
{Cos[p] Sin[t], Sin[p] Sin[t], 1 + Cos[t]}/2,
{p, 0, 2 Pi}, {t, 0, Pi},
PlotStyle -> Opacity[0.5],
Mesh -> Automatic],
Graphics3D[{
Gray,
Table[Line[{{-1, y, 0}, {1, y, 0}}], {y, -1, 1, .25}],
Table[Line[{{x, -1, 0}, {x, 1, 0}}], {x, -1, 1, .25}],
Table[Line[{{-1, -1, z}, {-1, 1, z}}], {z, 0, 1, .25}],
Table[Line[{{-1, y, 0}, {-1, y, 1}}], {y, -1, 1, .25}],
Table[Line[{{-1, 1, z}, {1, 1, z}}], {z, 0, 1, .25}],
Table[Line[{{x, 1, 0}, {x, 1, 1}}], {x, -1, 1, .25}],
Line[{{0, 0, 0}, {0, 0, 1}}],
Darker[Magenta],
AbsoluteThickness[3],
g4,
Red,
PointSize[.02],
Tooltip[
Point[{stereographicProjection[-1]}],
"Projection of -1"]}],
ImageSize -> Large,
AxesLabel -> {"x", "y", "z"},
PlotRange -> {{-1, 1}, {-1, 1}, {-0, 1}},
BoxRatios -> {1, 1, 1/2}]

Bob Hanlon

On Thu, May 30, 2013 at 4:00 PM, Eduardo M. A. M.Mendes <
emammendes@gmail.com> wrote:

> Hello****
>
> ** **
>
> Many many thanks.****
>
> ** **
>
> A couple of questions if I may:
>
> **a) **Does the ToolTip command means that if the mouse over -1 the
> msg =93Project of -1=94will show up? It does not seem to work for me. T=

he
> only thing I can is to rotate the figure.
>

The object that has a Tooltip has to be rotated into direct view for the
mouse to be "over it" and the Tooltip to display.

> ****
>
> **b) **Is there a way to change the line color (tab3) from cold
> (blue) to hot (read) as goes from 0 to infinity and 0 to =96infinity?
>

Break the line up into small line segments and color each line segment
separately. However, this will significantly slow down drawing the plot
unless you thin out the data.

> ****
>
> **c) **Is there a way to get grid lines on the planes x-y,y-z,z-x?
>

Draw lines

> ****
>
> **d) **Another way, faster, to generate tab3.****
>
>
> see above

> Once more, thank you. ****
>
> ** **
>
> Ed****
>
> ** **
>
> ** **
>
> *From:* Bob Hanlon [mailto:hanlonr357@gmail.com]
> *Sent:* Thursday, May 30, 2013 4:03 PM
> *To:* Eduardo M. A. M. Mendes
> *Cc:* MathGroup
> *Subject:* Re: Help needed on how plot a stereographic
> projection****
>
> ** **
>
> Use of ComplexExpand on real values (output of Re, Im, or Abs) is
> unnecessary.****
>
>
> ClearAll[stereographicProjection];****
>
>
> stereographicProjection::usage =
> "stereographicProjection[complexnumber] will return the stereoprojectio=

n
> of \
> a complex point considering the Riemann sphere";****
>
>
> SyntaxInformation[stereographicProjection] = {"ArgumentsPattern" -> {_}=

};*
> ***
>
>
> stereographicProjection[complexnumber_] :=
> Module[
> {abs2 = Abs[complexnumber]^2},
> If[abs2 == Infinity,
> {0, 0, 1},
> {Re[complexnumber]/(1 + abs2),
> Im[complexnumber]/(1 + abs2),
> abs2/(1 + abs2)}]]****
>
>
> tab3 = Table[
> stereographicProjection[
> (s + 1)/(s^2 (s - 1)) /. {s -> I w}],
> {w, -1000, 1000, 0.1}] // Quiet;****
>
>
> Show[
> ParametricPlot3D[
> {Cos[p] Sin[t], Sin[p] Sin[t], 1 + Cos[t]}/2,
> {p, 0, 2 Pi}, {t, 0, Pi},
> PlotStyle -> Opacity[0.5],
> Mesh -> Automatic],
> Graphics3D[{
> Darker[Magenta],
> AbsoluteThickness[3],
> Tooltip[Line[tab3],
> "Projection of (s+1)/(s^2 (s-1))"],
> Red,
> PointSize[.02],
> Tooltip[Point[{stereographicProjection[-1]}],
> "Projection of -1"]}],
> ImageSize -> Large,
> AxesLabel -> {"x", "y", "z"},
> PlotRange -> {{-1, 1}, {-1, 1}, {0, 1}},
> BoxRatios -> {1, 1, 1/2}]****
>
> ** **
>
> ** **
>
> Bob Hanlon****
>
> ** **
>
> ** **
>
> On Thu, May 30, 2013 at 6:14 AM, Eduardo M. A. M. Mendes <
> emammendes@gmail.com> wrote:****
>
> Hello
>
> Although I have been using Mathematica for more than year, I feel that I
> haven't barely scratched the surface of what Mathematica can do.
>
> The following example gives the result that I need but the outcome is ugl=

y
> and slow.
>
> ClearAll[stereographicProjection];
>
> stereographicProjection::usage="stereographicProjection[complexnumber]
> will return the stereoprojection of a complex point considering the Riema=

nn
> sphere";
>
> SyntaxInformation[stereographicProjection]={"ArgumentsPattern"->{_}};
>
> stereographicProjection[complexnumber_]:=
> Module[{a1,a2,a3},
> If[ComplexExpand[Abs[complexnumber]]==Infinity,
> a1=0;a2=0;a3=1,
> =
>
> a1=ComplexExpand[Re[complexnumber]]/(1+ComplexExpand[Abs[complexnumber]=

]^2);
>
>
> a2=ComplexExpand[Im[complexnumber]]/(1+ComplexExpand[Abs[complexnumber]=

]^2);
> =
>
> a3=ComplexExpand[Abs[complexnumber]]^2/(1+ComplexExpand[Abs[complexnumb=

er]]^2)];
> {a1,a2,a3}
> ]
>
> tab3=Table[stereographicProjection[(s+1)/(s^2 (s-1))/.{s-> I
> \[Omega]}],{\[Omega],-1000,1000,0.1}];
>
> =
> Show[ContourPlot3D[x^2+y^2+(z-1/2)^2==(1/2)^2,{x,-1,1},{y,-1,1},{z,0,=

1},Mesh->Automatic,AxesLabel->
> =
> {"x","y","z"},BoxRatios->{1,1,1/2},ImageSize-> =
> Large],ListPointPlot3D[tab3,PlotStyle->Directive[PointSize[Large],Magenta=

],ImageSize->
> =
> Large],ListPointPlot3D[{stereographicProjection[-1]},PlotStyle->Directive=

[PointSize[0.02],Red]],ImageSize->
> Large]
>
> a) Is there another way of getting the same plot?
> b) How to get the points of tab3 connected?
> c) How to change the opacity of the sphere?
>
>
> Improvements, suggestion and critiscims are welcome.
>
> Many thanks
>
> Ed
>
> ****
>
> ** **
>

Date Subject Author
5/31/13 Bob Hanlon
5/31/13 Murray Eisenberg
5/31/13 Bob Hanlon
5/31/13 emammendes@gmail.com
5/31/13 emammendes@gmail.com