6
$\begingroup$

I'm doing a project trying to 3D print the stereographic projections of 4D shapes, and I need it so that the lines are thinner towards the origin for structural reasons. I've written functions to do the projection and to draw the projected line between two vertices, and this works fine for just lines:

f[{x_, y_, z_, w_}] := {x/(1 - w), y/(1 - w), z/(1 - w)} (*formula for stereographic projection*)

drawing[{{x1_, x2_, x3_, x4_}, {y1_, y2_, y3_, y4_}}] := 
 Module[{v1, v2, u}, v1 = {x1, x2, x3, x4}/2;
  v2 = {y1, y2, y3, y4}/2;
  u = v2 - v1;
  ParametricPlot3D[f[RotationMatrix[{v1, v1 + t*u}] . v1], {t, 0, 1}, PlotRange -> All]] (*this is drawing the geodesic on the unit 3-sphere and then projecting it to 3D*)

Which gives stuff like this: But just drawing the lines doesn't work for 3D printing, so I've tried lots of ways to continuously vary Tube radius but none quite work as I want.

My first try was /. Line[pts_] -> Tube[pts, 0.03 + Norm[pts]/100] at the end, which gives constant tube radius for each edge, but does change depending on the starting vertex, and annoyingly on which end of each edge you start at. some of the tubes connecting the inner and outer cubes are different thicknesses

I realised it might work better if I made the radius function explicitly a function of t, but I got 1/0 errors unless I used an If statement to restrict t: PlotStyle -> Tube[If[0 <= t <= 1, 0.03 + Norm[f[RotationMatrix[{v1, v1 + t*u}] . v1]]/100, 0.03]] But then for some reason the range of t needed to cover the entirety on an edge is much larger than 0<t<1 (more like 0<100, and also depends on which edge you're drawing), and the radius blows up for small t (like t<3).

So my question is why is the range of t different when plotting versus in the tube radius function, and does anyone have any better suggestions for how to get what I want? (And also if there are more efficient ways of drawing stereographic projects in general?)

Hypercube:

Show[projection[#] & /@ {{{-1, -1, -1, 1}, {-1, -1, 1, 1}}, {{-1, -1, -1, 1}, {-1, 1, -1, 1}}, {{-1, -1, -1, 1}, {1, -1, -1, 1}}, {{-1, -1, -1, 1}, {-1, -1, -1, -1}},{{-1, -1, 1, 1}, {1, -1, 1, 1}}, {{-1, -1, 1, 1}, {-1, 1, 1, 1}}, {{-1, -1, 1, 1}, {-1, -1, 1, -1}},{{-1, 1, -1, 1}, {1, 1, -1, 1}}, {{-1, 1, -1, 1}, {-1, 1, 1, 1}}, {{-1, 1, -1, 1}, {-1, 1, -1, -1}},{{-1, 1, 1, 1}, {1, 1, 1, 1}}, {{-1, 1, 1, 1}, {-1, 1, 1, -1}},{{1, -1, -1, 1}, {-1, -1, -1, 1}}, {{1, -1, -1, 1}, {1, 1, -1, 1}}, {{1, -1, -1, 1}, {1, -1, 1, 1}}, {{1, -1, -1, 1}, {1, -1, -1, -1}},{{1, -1, 1, 1}, {1, 1, 1, 1}}, {{1, -1, 1, 1}, {1, -1, -1, 1}}, {{1, -1, 1, 1}, {1, -1, 1, -1}}, {{1, -1, 1, 1}, {-1, -1, 1,1}},{{1, 1, -1, 1}, {1, -1, -1, 1}}, {{1, 1, -1, 1}, {1, 1, 1,1}}, {{1, 1, -1, 1}, {1, 1, -1, -1}},{{1, 1, 1, 1}, {-1, 1, 1, 1}}, {{1, 1, 1, 1}, {1, 1, 1, -1}},{{-1, -1, -1, -1}, {1, -1, -1, -1}}, {{-1, -1, -1, -1}, {-1, 1, -1, -1}}, {{-1, -1, -1, -1}, {-1, -1, 1, -1}},{{-1, -1, 1, -1}, {1, -1, 1, -1}}, {{-1, -1, 1, -1}, {-1, 1, 1, -1}},{{-1, 1, -1, -1}, {1, 1, -1, -1}}, {{-1, 1, -1, -1}, {-1, 1,1, -1}},{{-1, 1, 1, -1}, {1, 1, 1, -1}}, {{-1, 1, 1, -1}, {-1, 1, 1, 1}},{{1, -1, -1, -1}, {1, 1, -1, -1}}, {{1, -1, -1, -1}, {1, -1, 1, -1}}, {{1, -1, -1, -1}, {1, -1, -1, 1}},{{1, -1, 1, -1}, {1, 1, 1, -1}},{{1, 1, -1, -1}, {1, 1, 1, -1}}, {{1, 1, -1, -1}, {1, 1, 1, -1}}},PlotRange -> All, AxesLabel -> {x, y, z}]

5-cell:

Coords4 = {{1/24 (5 - Sqrt[5]) + 1/24 (15 + Sqrt[5]),1/120 (-15 - Sqrt[5]) + 1/30 (5 - Sqrt[5]) + 1/24 (-5 + Sqrt[5]),1/120 (-15 - Sqrt[5]) + 1/30 (5 - Sqrt[5]) + 1/24 (-5 + Sqrt[5]),3/40 (-5 + Sqrt[5]) +1/40 (15 + Sqrt[5])}, {1/120 (-15 - Sqrt[5]) +1/30 (5 - Sqrt[5]) + 1/24 (-5 + Sqrt[5]),1/24 (5 - Sqrt[5]) + 1/24 (15 + Sqrt[5]), 1/120 (-15 - Sqrt[5]) + 1/30 (5 - Sqrt[5]) + 1/24 (-5 + Sqrt[5]),3/40 (-5 + Sqrt[5]) + 1/40 (15 + Sqrt[5])}, {1/120 (-15 - Sqrt[5]) + 1/30 (5 - Sqrt[5]) + 1/24 (-5 + Sqrt[5]),1/120 (-15 - Sqrt[5]) + 1/30 (5 - Sqrt[5]) + 1/24 (-5 + Sqrt[5]),1/24 (5 - Sqrt[5]) + 1/24 (15 + Sqrt[5]),3/40 (-5 + Sqrt[5]) + 1/40 (15 + Sqrt[5])}, {1/40 (-15 - Sqrt[5]) + 1/60 (5 - Sqrt[5]) + 1/24 (-5 + Sqrt[5]),1/40 (-15 - Sqrt[5]) + 1/60 (5 - Sqrt[5]) + 1/24 (-5 + Sqrt[5]),1/40 (-15 - Sqrt[5]) + 1/60 (5 - Sqrt[5]) + 1/24 (-5 + Sqrt[5]),3/40 (-5 + Sqrt[5]) + 1/40 (15 + Sqrt[5])}, {0, 0, 0, -(2/Sqrt[5])}}
AdjMat = {1, 2, 1, 3, 1, 4, 1, 5, 2, 3, 2, 4, 2, 5, 3, 4, 3, 5, 4, 5}
Show[greatCircleArcProjection[#] & /@ Table[{Coords4[[AdjMat[[2 i]]]], Coords4[[AdjMat[[2 i - 1]]]]}, {i,10}], PlotRange -> All, AxesLabel -> {x,y, z}]

(Hence why a more efficient method would be nice)

Improve this question
$\endgroup$
3
  • 1
    $\begingroup$ It would be helpful if you show some of your drawings to make the question clearer! $\endgroup$ Commented Aug 17, 2024 at 10:08
  • $\begingroup$ Thanks, again it would be helpful if one could reproduce your plots. Which parameters drawing[{{x1, x2 , x3 , x4 }, {y1 , y2 , y3 , y4 }}] did you use? $\endgroup$ Commented Aug 17, 2024 at 13:38
  • 1
    $\begingroup$ See mathematica.stackexchange.com/questions/104863/… or mathematica.stackexchange.com/questions/126506/… (apply to parametrizations of the edges) $\endgroup$ Commented Aug 17, 2024 at 17:13

1 Answer 1

Reset to default
7
$\begingroup$

Method-1

Clear["Global`*"];
Needs["NDSolve`FEM`"];
Needs["OpenCascadeLink`"];
pts = Tuples[{1, -1}, 4];
pairs = Select[Subsets[pts, {2}], 
   HammingDistance[#[[1]], #[[2]]] == 1 &];
f[{x_, y_, z_, w_}] = {x/(1 - w), y/(1 - w), z/(1 - w)};
drawing[{{x1_, x2_, x3_, x4_}, {y1_, y2_, y3_, y4_}}] := 
 Module[{v1, v2, u, F, circles, s, loft, bmesh, reg, thickness}, 
  v1 = {x1, x2, x3, x4}/2;
  v2 = {y1, y2, y3, y4}/2;
  u = v2 - v1;
  F[t_] = 
   f[RotationMatrix[{v1, v1 + t*u}] . v1] // ComplexExpand // Simplify;
  thickness = .2;
  circles = 
   circles = 
    Table[OpenCascadeCircle[{F[t], F'[t]} // ComplexExpand // 
       Simplify, 
      thickness*Norm[F[t]]/2 // ComplexExpand // Simplify], {t, 
      Subdivide[0, 1, 17]}];
  s = OpenCascadeShape /@ circles;
  loft = OpenCascadeShapeLoft[s, "BuildSolid" -> True];
  bmesh = 
   OpenCascadeShapeSurfaceMeshToBoundaryMesh[loft, 
    "ShapeSurfaceMeshOptions" -> {"AngularDeflection" -> 0.15}];
  bmesh["Wireframe"[
    "MeshElementStyle" -> Directive[{FaceForm[Cyan], EdgeForm[]}]]]]
drawing /@ pairs // Show

enter image description here

Method-2

  • Set Line[pts_] :> Tube[pts, 0.1 (Norm /@ pts)] or /. Line :> (Tube[#, .1 Norm /@ #] &)
  • But DiscretizeGraphics does not work for this 3D graphics.
Clear["Global`*"];
pts = Tuples[{1, -1}, 4];
pairs = Select[Subsets[pts, {2}], 
   HammingDistance[#[[1]], #[[2]]] == 1 &];
f[{x_, y_, z_, w_}] = {x/(1 - w), y/(1 - w), z/(1 - w)};
drawing[{{x1_, x2_, x3_, x4_}, {y1_, y2_, y3_, y4_}}] := 
 Module[{v1, v2, u, F, circles, s, loft, bmesh, reg, thickness}, 
   v1 = {x1, x2, x3, x4}/2;
   v2 = {y1, y2, y3, y4}/2;
   u = v2 - v1;
   F[t_] = 
    f[RotationMatrix[{v1, v1 + t*u}] . v1] // ComplexExpand // 
     Simplify;
   thickness = .2;
   ParametricPlot3D[F[t], {t, 0, 1}, PlotStyle -> Cyan, 
    PlotPoints -> 40, MaxRecursion -> 2, PlotRange -> All]]/. Line -> (Tube[#, .1 Norm /@ #] &)
Show[drawing /@ pairs, Boxed -> False, Axes -> False]

enter image description here

  • 5-cell:
Show[drawing /@ 
  Table[{Coords4[[AdjMat[[2  i]]]], 
    Coords4[[AdjMat[[2  i - 1]]]]}, {i, 10}], PlotRange -> All, 
 AxesLabel -> {x, y, z}, Boxed -> False, Axes -> False]

enter image description here

Improve this answer
$\endgroup$
1
  • $\begingroup$ This is amazing thank you! $\endgroup$ Commented Aug 24, 2024 at 14:35

Start asking to get answers

Find the answer to your question by asking.

Ask question

Explore related questions

See similar questions with these tags.