4
$\begingroup$

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

enter image description here

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?

$\endgroup$

4 Answers 4

9
$\begingroup$
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]

enter image description here

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

enter image description here

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

enter image description here

$\endgroup$
4
  • $\begingroup$ 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? $\endgroup$
    – B flat
    Jun 27 at 16:51
  • $\begingroup$ 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. $\endgroup$
    – B flat
    Jun 28 at 0:48
  • $\begingroup$ Nice! This is even better. $\endgroup$
    – B flat
    Jun 28 at 2:41
  • 1
    $\begingroup$ I used your code and set PerformanceGoal -> "Speed" and Mesh->All. This speeds it up and looks just as good. Thanks CVGMT! $\endgroup$
    – B flat
    Jun 28 at 3:23
5
$\begingroup$

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):

enter image description here

$\endgroup$
3
  • $\begingroup$ 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. $\endgroup$
    – B flat
    Jun 28 at 0:08
  • $\begingroup$ @Bflat Sorry about that. You were right. There was a line missing. $\endgroup$
    – Michael E2
    Jun 28 at 0:26
  • $\begingroup$ Wow this is perfect! $\endgroup$
    – B flat
    Jun 28 at 0:35
3
$\begingroup$

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

enter image description here

$\endgroup$
2
  • 1
    $\begingroup$ (+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. $\endgroup$
    – cvgmt
    Jun 28 at 2:34
  • $\begingroup$ Oh yes. You're right! I missed that. $\endgroup$
    – B flat
    Jun 28 at 2:39
1
$\begingroup$

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

enter image description here

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

$\endgroup$
1
  • $\begingroup$ 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. $\endgroup$
    – B flat
    Jun 27 at 17:35

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.