Message Boards Message Boards

Inverse stereographic projection for 3d printing

Posted 2 years ago

Hi Folks, My first post here as a Mathematica newbie. I would like to 3d print the boolean operation of a logarithmic spiral projected onto a sphere, ie, the spiral is the cutter. The is idea is to to shine a light at the north pole of the sphere to see the spiral shadow on a plan(Wall). I have asked this question on Mathematica exchange here but did not get the final crucial steps so I thought I would ask here.

I have attached my latest attempt which outputs an error "reg1 must be a boolean function"

Any tips would be appreciated! Thanks

POSTED BY: Eddie Morris
4 Replies
Posted 2 years ago

Hi Henrik,

Many thanks for your response. That looks like a very useful approach in Mathematica. Although I not sure if your approach is stereo projection from a plane to the sphere. I think this example (the butter fly curve) demonstrates it more clearly.

https://resources.wolframcloud.com/FunctionRepository/resources/InverseStereographicProjection/ Thanks for your efforts. I will certainly take note of it. Best regards, Ed

POSTED BY: Eddie Morris

Hi Eddie,

I actually had the wrong idea about stereographic projection - sorry! I thought the light source were located at an infinite distance above the north pole.

Now I tried a hopefully correct approach - but failed! Here is what I did:

I first calculated a "focused" version of this 3D-spiral:

spiralRegion3D = DiscretizeRegion@RegionProduct[spiralRegion, DiscretizeRegion@Line[{{-1}, {1}}]];
polygs = MeshPrimitives[spiralRegion3D, 2];
invStTr[x_, y_, z_] := With[{mag = 1. - (z + 1.)/2.}, {x mag, y mag, z}]
polygsTrans = polygs /. Polygon[cl_] :> Polygon[invStTr @@@ cl];
focusSpiralRegion3D = DiscretizeGraphics@Graphics3D[polygsTrans]

enter image description here

The tip of this structure is located at {0,0,1}, i.e. at the north pole of the sphere, (Normally the above transformation is supposed to be done using TransformedRegion, but I could not make that work!)

OK, the simple remaining task is to calculate the difference of this and - as a simplified case - a ball, but this does not work either:

enter image description here

RegionUnion does work and at least shows my idea:

enter image description here

If I am doing something wrong I have no idea what my mistake could be! So - either anyone can help us here, or we have to wait for an improved version of Mathematica. Again: Sorry!

POSTED BY: Henrik Schachner

OK, good - here is a much cleaner solution:

From above I use the expression spiralRegion; from this I calculate a 3D-spiral:

spiralRegion3D = DiscretizeRegion@
  RegionProduct[spiralRegion, DiscretizeRegion@Line[{{-.1}, {1.1}}]]

enter image description here

And then:

(* 3D-spiral cut out of a ball: *)
spiralBall = RegionDifference[DiscretizeRegion@Ball[], spiralRegion3D];
sphereThickness = .05;
(* sphere with thickness 'sphereThickness' as difference of two isocentric balls: *)
spiralSphere = RegionDifference[spiralBall, DiscretizeRegion@Ball[{0, 0, 0}, 1 - sphereThickness]];
(* lower half cut off: *)
spiralHalfSphere = RegionDifference[spiralSphere, Cuboid[{-2, -2, -2}, {2, 2, 0}]]

enter image description here

Now the cut is strictly parallel to an axis through the pole. The whole procedure seems to work only with the excessive use of DiscretizeRegion. Being a Region this structure should definitely be suitable for 3D-Printing.

Isn't Mathematica just great !?!

POSTED BY: Henrik Schachner

... a logarithmic spiral projected onto a sphere, ie, the spiral is the cutter.

Eddie,

I hope I understand your question correctly. My approach is to start with the wanted shadow. So I begin by constructing the respective region:

logSpiral[t_] := {Sin[t], Cos[t]} Exp[.1 t];
thickn = .02;
img = AlphaChannel[ppl = ParametricPlot[logSpiral[t], {t, -10 Pi, 0}, 
     PlotStyle -> {Black, Thickness[thickn]}, Axes -> False, 
     PlotRangePadding -> thickn .75]];
plRange = PlotRange /. AbsoluteOptions[ppl, PlotRange];
spiralRegion = RegionResize[DiscretizeRegion[ImageMesh[img]], plRange];
shadowRegion = DiscretizeRegion @ RegionDifference[DiscretizeRegion@Disk[], spiralRegion]

enter image description here

Now a spherical function can simple be plotted onto that region:

Plot3D[Sqrt[1 - x^2 - +y^2], {x, y} \[Element] shadowRegion, 
 PlotPoints -> 100, ImageSize -> Large, Boxed -> False, Axes -> False,
 BoxRatios -> Automatic,
 PlotTheme -> "ThickSurface"]

enter image description here

Notice the option PlotTheme -> "ThickSurface" witch makes it suitable for 3D printing.

Well, at first glance this looks good, but in fact it does not really work the way you probably want. The problem is that now the sphere is cut perpendicular to the surface - and not along the z-axis. I tried with RegionProduce and RegionDilation and ShellRegion, etc., but I could not get a better result. Nevertheless I hope this is helpful.

POSTED BY: Henrik Schachner
Reply to this discussion
Community posts can be styled and formatted using the Markdown syntax.
Reply Preview
Attachments
Remove
or Discard

Group Abstract Group Abstract