Create a Manipulate of a nonlinear transformation of R3

Question

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?

Answer 1

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

Answer 2

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[
           MapThread[
            #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):

Answer 3

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

Answer 4

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 -> Region`Mesh`MeshCellNormals[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}]
  ]]

Answer 5

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.