# Create a Manipulate of a nonlinear transformation of R3

The following Manipulate animates a nonlinear transformation of R2: (x,y)->(x+Cos[y],y+Cos[x])

Manipulate[
f1[x_, y_] = (1 - t) x + t (x + Cos[y]);
f2[x_, y_] = (1 - t) y + t (y + Sin[x]);
Show[{
ParametricPlot[{x, y}, {x, -4, 4}, {y, -4, 4}, PlotPoints -> 50,
Mesh -> 8, PlotStyle -> Opacity[.01]],
ParametricPlot[{f1[x, y], f2[x, y]}, {x, -4, 4}, {y, -4, 4},
PlotPoints -> 50, Mesh -> 8]},
PlotRange -> 5, Axes -> False, Mesh -> 8, Frame -> False]
, {t, 0, 1}, TrackedSymbols :> {t}]


I would like to create a Manipulate for a nonlinear transformation of R3 like:

(x,y,z)->(x + Cos[y],y + Sin[x],z + Sin[y])

I'm not sure how to get started. Any ideas?

## Edit

DisplayFunction make such transformation easy construct and also faster.

Manipulate[
RegionPlot3D[
BoundaryDiscretizeRegion@Cuboid[{-4, -4, -4}, {4, 4, 4}],
Mesh -> 10,
DisplayFunction ->
ReplaceAll[{x_Real, y_Real, z_Real} :> (1 - t) {x, y, z} +
t {x + Cos[y], y + Sin[x], z + Sin[y]}], PlotPoints -> 20,
MaxRecursion -> 2, Boxed -> False], {t, 0, 1}]


Original

identity = {x, y, z};
trans = {x + Cos[y], y + Sin[x], z + Sin[y]};
plots = Table[
BoundaryDiscretizeRegion[
ParametricRegion[(1 - t)*identity +
t*trans, {{x, -4, 4}, {y, -4, 4}, {z, -4, 4}}],
PerformanceGoal -> "Speed", PlotRange -> 5], {t, 0, 1, .05}];

Manipulate[
Graphics3D[{EdgeForm[], {FaceForm[Opacity[.2]],
plots[[1]]}, {FaceForm[Orange], plots[[i]]}}, PlotRange -> 5,
Boxed -> False], {i, 1, Length@plots, 1}, ControlPlacement -> Top]


• Edit

Maybe another possible way,but I don't know how to animate the region by the vector field.

identity = {x, y, z};
trans = {x + Cos[y], y + Sin[x], z + Sin[y]};
f = D[identity*(1 - t) + trans*t, t];
VectorDisplacementPlot3D[f, {x, y, z} ∈
Cuboid[{-4, -4, -4}, {4, 4, 4}], PlotRange -> 6, PlotPoints -> 50]


• Mapping only the boundary surfaces.

Althouth it is not always the exact region since maybe some interoir points of the cuboid go outside of the region after the mapping.

identity = {x, y, z};
trans = {x + Cos[y], y + Sin[x], z + Sin[y]};
F[t_][x_, y_, z_] = identity*(1 - t) + trans*t;
SetOptions[ParametricPlot3D, PerformanceGoal -> "Quality",
PlotPoints -> 20, Lighting -> {{"Ambient", White}}, Boxed -> False,
Axes -> False,Mesh -> 10];
Manipulate[
Show[Graphics3D[{FaceForm[Opacity[.2]], EdgeForm[],
Cuboid[{-4.05, -4.05, -4.05}, {4.05, 4.05, 4.05}]},
Boxed -> False],
ParametricPlot3D[
F[t][x, y, z] /. z -> {-4, 4} // Thread, {x, -4, 4}, {y, -4, 4},
PlotStyle -> LightOrange],
ParametricPlot3D[
F[t][x, y, z] /. x -> {-4, 4} // Thread, {y, -4, 4}, {z, -4, 4},
PlotStyle -> LightMagenta],
ParametricPlot3D[
F[t][x, y, z] /. y -> {-4, 4} // Thread, {z, -4, 4}, {x, -4, 4},
PlotStyle -> LightBlue], PlotRange -> 5], {t, 0, 1}]


• Very cool! It took over a minute to execute, almost gave up waiting. This is what I was looking for. Can you think of any way to speed up compiling? Jun 27, 2022 at 16:51
• Thank you. I awarded the points for Michael's answer below, becuase it was clean using the wireframe method. Although, I'm going to see if I can make your method work as it looks better. Jun 28, 2022 at 0:48
• Nice! This is even better. Jun 28, 2022 at 2:41
• I used your code and set PerformanceGoal -> "Speed" and Mesh->All. This speeds it up and looks just as good. Thanks CVGMT! Jun 28, 2022 at 3:23

For "fast," I usually just do straight graphics:

basecoords = Table[{{i, j, -4.}, {i, j, 4.}},
{i, -4., 4., 2}, {j, -4., 4., 2}];
npts = 33;
coords = Join[
Map[Subdivide[Sequence @@ #, npts - 1] &,
basecoords, {2}],
Map[Subdivide[Sequence @@ #, npts - 1] &,
Map[RotateLeft, basecoords, {3}], {2}],
Map[Subdivide[Sequence @@ #, npts - 1] &,
Map[RotateRight, basecoords, {3}], {2}]];
With[{p = Transpose@Flatten[coords, 2]},
With[{x = p[[1]], y = p[[2]], z = p[[3]],
np = Length@First@p},
Manipulate[
Graphics3D[{
GraphicsComplex[
Transpose[{x + t Cos[y], y + t Sin[x], z + t Sin[y]}],
Line[Partition[Range@np, npts]]
]
},
Boxed -> False],
{t, 0, 1}
]
]]


With colors and a selector to highlight the different sets of lines/curves:

With[{p = Transpose@Flatten[coords, 2]},
With[{x = p[[1]], y = p[[2]], z = p[[3]],
np = Length@First@p},
Manipulate[
Graphics3D[{
GraphicsComplex[
Dynamic@Transpose[{x + t Cos[y], y + t Sin[x], z + t Sin[y]}],
{Thick,
Line[Partition[Range@np, npts],
VertexColors -> Dynamic@ArrayReshape[
#1 /@ #2 &,
{
{If[MemberQ[lines, 1],
Blend[{Magenta, Pink, Lighter[Purple, 0.5]}, #],
Opacity[0]] &,
If[MemberQ[lines, 2],
Blend[{Darker@Gray, Blue}, 2 #/3],
Opacity[0]] &,
If[MemberQ[lines, 3],
Blend[{Darker@Yellow, LightGray,
Lighter@Darker@Yellow}, #],
Opacity[0]] &},
Mod[Partition[Range@np, np/3],
npts]/(npts - 1.)
}],
{np/npts, npts}]
]
}]
},
Boxed -> False],
{t, 0, 1}, {{lines, {1, 2, 3}}, {1, 2, 3}, TogglerBar}
]
]]


Graphics (stripped of Manipulate):

• I can see how this can be much faster. Your code seems to be missing a definition or two. I don't see basecoords defined. Jun 28, 2022 at 0:08
• @Bflat Sorry about that. You were right. There was a line missing. Jun 28, 2022 at 0:26
• Wow this is perfect! Jun 28, 2022 at 0:35

I used Michael's idea and only mapped the boundary.

 Manipulate[
Region[
TransformedRegion[ir,
Function[(1 - t) {Indexed[#, 1], Indexed[#, 2], Indexed[#, 3]} +
t { Indexed[#, 1] + Cos[Indexed[#, 2]],
Indexed[#, 2] + Sin[Indexed[#, 1]],
Indexed[#, 3] + Sin[Indexed[#, 2]]}]], PlotRange -> 6], {t, 0,
1}, Initialization :> {ir =
DiscretizeRegion[
ImplicitRegion[
Max[Abs[x], Abs[y], Abs[z]] == 4, {x, y, z}], {{-4.2,
4.2}, {-4.2, 4.2}, {-4.2, 4.2}},
MaxCellMeasure -> {"Area" -> 0.2}]}]


• (+1) Faster than my approach althouth it is not always the exact region since maybe some interoir point of the cuboid go outside the region after the mapping. I also updated my answer. Jun 28, 2022 at 2:34
• Oh yes. You're right! I missed that. Jun 28, 2022 at 2:39

With[{a = -4., b = 4., n = 9, m = 40, cf = Compile[{{p, _Real, 1}, t},
With[{x = p[[1]], y = p[[2]], z = p[[3]]}, (1 - t) {x, y, z} +
t {x + Cos[y], y + Sin[x], z + Sin[y]}],  RuntimeAttributes -> {Listable}]},
With[{dt = (b - a)/n, dt2 = (b - a)/m,
gc = Function[{pts},
Module[{cells, reg},
cells = Polygon[Join @@ Table[{0, m + 1, m + 2, 1} + i + m (i - 1) + j - 1, {i, m}, {j, m}]];
reg = MeshRegion[pts, cells];
GraphicsComplex[pts, cells, VertexNormals -> RegionMeshMeshCellNormals[reg, 0]]]]},
Manipulate[Graphics3D[{
{EdgeForm[],  With[{L =  Tuples[{Range[a, b, dt2], Range[a, b, dt2], {#}}]},
{gc[cf[L, t]], gc[cf[L[[All, {2, 3, 1}]], t]], gc[cf[L[[All, {3, 1, 2}]], t]]} & /@ {a, b}]},
{Green, Tube @@@ MeshPrimitives[Cuboid[{a, a, a}, {b, b, b}], 1]},
GrayLevel[0.1],
With[{L = Join @@ Table[{x, y, z}, {x, a, b, dt}, {y, a, b, dt}, {z, a, b, dt2}]},
Tube[cf[Join[L, L[[All, All, {2, 3, 1}]], L[[All, All, {3, 1, 2}]]],t], 0.018]]
}, PlotRange -> 5.5, Boxed -> False, ImageSize -> 600], {t, 0, 1}]
]]


Note that a cube can be defined by :

Norm[{x, y, z}], \[Infinity]] <= 1


To construct the deformed cube, we define the inverse mapping function and define:

mapi[t, {x, y, z}], \[Infinity]] <= 1


With this we can create the Manipulate:

mapi[t_, {x_, y_, z_}] = {x, y, z} - t {Cos[y], Sin[x], Sin[y]};
Manipulate[ RegionPlot3D[ Norm[mapi[t, {x, y, z}], \[Infinity]] <= 1, {x, 0, 2}, {y, 0,  2}, {z, 0, 2}, AspectRatio -> 1, PerformanceGoal -> "Quality"]
, {t, 0, 1}]


To get nicer edges, you may increase the option PlotPoints, but then it takes longer to calculate.

• Very cool idea. It could be my own misunderstanding, but the image of the transformation seems off. It's not warping space in the way I see from the answer above. Jun 27, 2022 at 17:35