Skip to main content

plotting - How can I draw a 3D cross-section of a 3-torus embedded in 4D Euclidean space?


I have a 3-torus (S1×S1×S1) embedded in 4D Euclidean space. How can I draw the cross-section of this 3-torus cut by a 3D Euclidean space in an arbitrary direction? The equations are:


x=(r+(t+dcosa)cosb)coscy=(r+(t+dcosa)cosb)sincz=(t+dcosa)sinbw=dsina


where x,y,z,w are the orthogonal coordinates in 4D space, r,t,d are the radii of three circles, and a,b,c denote the angles of the point with respect to the three circles.



Answer



Take r=1,t=5,d=10 for example:



r = 1; t = 5; d = 10;

The parametric equation for the 3-torus is given by:


torus3 = {(r + (t + d Cos[a]) Cos[b]) Cos[c],
(r + (t + d Cos[a]) Cos[b]) Sin[c],
(t + d Cos[a]) Sin[b], d Sin[a]};

Suppose the plane is determined by its normal n and a point o on it:


\[DoubleStruckN] = Normalize[RandomReal[{0, 1}, 4]]
\[DoubleStruckO] = RandomReal[{-.5, .5}, 4]



{0.0266919, 0.556735, 0.561821, 0.611302}
{-0.4925, 0.182885, -0.174828, 0.394413}

So the cross section gives a constraint on a,b,c, which is (torus3o)n=0, which then defines a contour surface paraRegion in 3D Euclidean space (didn't take the full [0,2π] ranges, so later we can see some inner structure of the cross section surface):


paraRegion = 
ContourPlot3D[
Evaluate[(torus3 - \[DoubleStruckO]).\[DoubleStruckN] == 0],
{a, .4 π, 2π - .93 π}, {b, 0, 2 π-.1 π}, {c, 0, 2 π - .2 π},

PlotRange -> All,
ColorFunction -> Function[{a, b, c, f}, Hue[b, c, a]],
PlotPoints -> 6, MaxRecursion -> 2,
BoundaryStyle -> Directive[{Thickness[.01], GrayLevel[.7]}],
MeshFunctions -> {#1 &, #2 &, #3 &},
MeshStyle -> {RGBColor[1, .5, .5], RGBColor[.5, 1, .5], RGBColor[.5, .5, 1]},
Lighting -> "Neutral",
AxesLabel -> (Style[#, 20, Bold] & /@ {a, b, c})]

initial contour surface



Thanks to the plane, we can reduce the cross section into 3D Euclidean space:


crossEq = RotationMatrix[{\[DoubleStruckN], {0, 0, 0, 1}}].torus3 // Most

So we can further transform the feasible (a,b,c) set paraRegion to the cross section surface we want:


Cases[paraRegion,
GraphicsComplex[pts_, others_,
opts1___, VertexNormals -> vn_, opts2___] :>
GraphicsComplex[
Function[{a, b, c}, Evaluate[crossEq]] @@ # & /@ pts,
others, opts1, opts2], ∞][[1]] // Graphics3D[#,

Axes -> True, PlotRange -> All, Lighting -> "Neutral"] &

3-torus with cut-away



Please beware that there are disadvantages of the above method, because Polygons in the cross section surface are directly inherited from the feasible parameter surface. To make sure this is correct, an assumption has to be made that the cross section surface must be continuous over the whole of paraRegion.


Comments

Popular posts from this blog

functions - Get leading series expansion term?

Given a function f[x] , I would like to have a function leadingSeries that returns just the leading term in the series around x=0 . For example: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x)] x and leadingSeries[(1/x + 2 + (1 - 1/x^3)/4)/(4 + x)] -(1/(16 x^3)) Is there such a function in Mathematica? Or maybe one can implement it efficiently? EDIT I finally went with the following implementation, based on Carl Woll 's answer: lds[ex_,x_]:=( (ex/.x->(x+O[x]^2))/.SeriesData[U_,Z_,L_List,Mi_,Ma_,De_]:>SeriesData[U,Z,{L[[1]]},Mi,Mi+1,De]//Quiet//Normal) The advantage is, that this one also properly works with functions whose leading term is a constant: lds[Exp[x],x] 1 Answer Update 1 Updated to eliminate SeriesData and to not return additional terms Perhaps you could use: leadingSeries[expr_, x_] := Normal[expr /. x->(x+O[x]^2) /. a_List :> Take[a, 1]] Then for your examples: leadingSeries[(1/x + 2)/(4 + 1/x^2 + x), x] leadingSeries[Exp[x], x] leadingSeries[(1/x + 2 + (1 - 1/x...

mathematical optimization - Minimizing using indices, error: Part::pkspec1: The expression cannot be used as a part specification

I want to use Minimize where the variables to minimize are indices pointing into an array. Here a MWE that hopefully shows what my problem is. vars = u@# & /@ Range[3]; cons = Flatten@ { Table[(u[j] != #) & /@ vars[[j + 1 ;; -1]], {j, 1, 3 - 1}], 1 vec1 = {1, 2, 3}; vec2 = {1, 2, 3}; Minimize[{Total@((vec1[[#]] - vec2[[u[#]]])^2 & /@ Range[1, 3]), cons}, vars, Integers] The error I get: Part::pkspec1: The expression u[1] cannot be used as a part specification. >> Answer Ok, it seems that one can get around Mathematica trying to evaluate vec2[[u[1]]] too early by using the function Indexed[vec2,u[1]] . The working MWE would then look like the following: vars = u@# & /@ Range[3]; cons = Flatten@{ Table[(u[j] != #) & /@ vars[[j + 1 ;; -1]], {j, 1, 3 - 1}], 1 vec1 = {1, 2, 3}; vec2 = {1, 2, 3}; NMinimize[ {Total@((vec1[[#]] - Indexed[vec2, u[#]])^2 & /@ R...

What is and isn't a valid variable specification for Manipulate?

I have an expression whose terms have arguments (representing subscripts), like this: myExpr = A[0] + V[1,T] I would like to put it inside a Manipulate to see its value as I move around the parameters. (The goal is eventually to plot it wrt one of the variables inside.) However, Mathematica complains when I set V[1,T] as a manipulated variable: Manipulate[Evaluate[myExpr], {A[0], 0, 1}, {V[1, T], 0, 1}] (*Manipulate::vsform: Manipulate argument {V[1,T],0,1} does not have the correct form for a variable specification. >> *) As a workaround, if I get rid of the symbol T inside the argument, it works fine: Manipulate[ Evaluate[myExpr /. T -> 15], {A[0], 0, 1}, {V[1, 15], 0, 1}] Why this behavior? Can anyone point me to the documentation that says what counts as a valid variable? And is there a way to get Manpiulate to accept an expression with a symbolic argument as a variable? Investigations I've done so far: I tried using variableQ from this answer , but it says V[1...