Inverse stereographic projection for 3d printing

[edmundmorris5 (Eddie Morris)]

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

Open in Wolfram Cloud ↗

[henrikschachner]

… 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]

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"]

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.

[henrikschachner]

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}}]]

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}]]

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 !?!

[edmundmorris5 (Eddie Morris)]

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

[henrikschachner]

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]

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:

RegionUnion does work and at least shows my idea:

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!