Notebook prompts that elicit complete solutions and interpret equations in PDF file

Questions
, , ,
1

I have limited math skills and am working on developing an animated visual of a non-standard physics concept. To achieve this, I am using AI and Mathematica. However, I’m facing a challenge as the 3D model I need was developed by a mathematician 20 years ago using MathCAD 11, which is no longer available. To address this issue, I presented a Chat-enabled Notebook with the relevant prompt:

Can you produce the function to match this graphic: https://sota.aetherwizard.com/images/Book/spin_2.jpg ? It represents 4 tubular loxodromes plotted over the surface of two adjacent spheres. The surface area of the four tubular loxodromes equals the surface area of the two spheres. Make sure the tubular loxodromes are centered on the sphere’s surface. Make each sphere and each loxodrome a different color. See if you can understand the equations for this project at this page: https://sota.aetherwizard.com/images/MathCAD/Aether_Unit_graphics.pdf

I tried using the chatbot to interpret a graphic image and a PDF file containing MathCAD equations that describe the 3D graphic, but it only partially succeeded. Unfortunately, I am not able to write the equations myself, so I am wondering if there is a better way to phrase my prompt to get a complete solution.

2

Here is a first attempt:

Clear[l, h1, g1];
sphereRadius = 13;
tubeRadius = 1;
l = 2;
h1[t_] = t;
g1[t_] = t/l;
Graphics3D[{{Opacity[.5], Sphere[{0, 0, 0}, sphereRadius]}, Thick, 
  Blue, Tube[
   Table[fsc[sphereRadius, g1[t], h1[t]], {t, 0, 2 Pi, Pi/40}], 
   tubeRadius],
  RGBColor[.36, .78, .72], 
  Tube[Table[
    fsc[sphereRadius, g1[t], -h1[t] + Pi], {t, 0, 2 Pi, Pi/40}], 
   tubeRadius]}]
3

Sorry I forgot this line:

fsc[r_, \[Theta]_, \[CurlyPhi]_] = 
 FromSphericalCoordinates[{r, \[Theta], \[CurlyPhi]}];
4

Thanks, you are on the right track. It is Pi/4 and not Pi/40. I can see that you are working from the MathCAD sheet, which the AI couldn’t do. You have given me something to study and maybe I will be able to piece this together.

5

I tried running the code, and then turning the new code back into another chat-enabled prompt. After several iterations, I am now to this point, which still has errors:

Improve the following code to represent 4 tubular loxodromes plotted over the surface of two adjacent spheres. The surface area of the four tubular loxodromes equals the surface area of the two spheres. Make sure the tubular loxodromes are centered on the sphere’s surface. Make each sphere and each loxodrome a different color. The final image should look like this image: https://sota.aetherwizard.com/images/Book/spin_2.jpg

fsc[r_, \[Theta]_, \[CurlyPhi]_] := {r*Cos[\[Theta]]*Sin[\[CurlyPhi]], r*Sin[\[Theta]]*Sin[\[CurlyPhi]], r*Cos[\[CurlyPhi]]};

sphereRadius = 13;
tubeRadius = sphereRadius^2 / (2 * Pi * sphereRadius);
l = 2 * Pi * sphereRadius * Sqrt[1 + Tan[45 Degree]^2]; (* Length of loxodromes *)

h1[t_] := t;
g1[t_] := t/l;

plot1 = ParametricPlot3D[
    fsc[sphereRadius, g1[t], h1[t]], {t, 0, l},
    PlotStyle -> Directive[Blue, Tube[tubeRadius]],
    PlotRange -> All
];

plot2 = ParametricPlot3D[
    fsc[sphereRadius, g1[t], -h1[t] + Pi], {t, 0, l},
    PlotStyle -> Directive[Yellow, Tube[tubeRadius]],
    PlotRange -> All
];

plot3 = ParametricPlot3D[
    fsc[sphereRadius, g1[t] + Pi/2, h1[t]] + {2*sphereRadius, 0, 0}, {t, 0, l},
    PlotStyle -> Directive[Cyan, Tube[tubeRadius]],
    PlotRange -> All
];

plot4 = ParametricPlot3D[
    fsc[sphereRadius, g1[t] + Pi/2, -h1[t] + Pi] + {2*sphereRadius, 0, 0}, {t, 0, l},
    PlotStyle -> Directive[Magenta, Tube[tubeRadius]],
    PlotRange -> All
];

Show[
    Graphics3D[
        {Opacity[.5], Red, Sphere[{0, 0, 0}, sphereRadius]},
        {Opacity[.5], Green, Sphere[{2*sphereRadius, 0, 0}, sphereRadius]}
    ],
    plot1,
    plot2,
    plot3,
    plot4,
    PlotLabel -> "Tubular Loxodromes on Spheres",
    AxesLabel -> {"x", "y", "z"},
    Axes -> True,
    Boxed -> True,
    ImageSize -> 400,
    PlotLegends -> {"Sphere 1", "Sphere 2", "Loxodrome 1", "Loxodrome 2", "Loxodrome 3", "Loxodrome 4"}
]
6

Just syntax. This gives no errors, but it looks very different from the picture you gave:

Show[Graphics3D[{{Opacity[.5], Red, 
    Sphere[{0, 0, 0}, sphereRadius]}, {Opacity[.5], Green, 
    Sphere[{2*sphereRadius, 0, 0}, 
     sphereRadius]}}], plot1, plot2, plot3, plot4, 
 PlotLabel -> "Tubular Loxodromes on Spheres", 
 AxesLabel -> {"x", "y", "z"}, Axes -> True, Boxed -> True, 
 ImageSize -> 400]

Those curves are not loxodromes.

7

I shared the code to display what the chat-enabled notebook is creating, but it’s not generating loxodromes like it should. The AI insists that it’s producing the desired output, but that’s not the case.