Revisions to Figure in animated GIF is oscillating as it rotates

Commonmark migration

Source Link

edited Jun 16, 2020 at 9:23

1

Perhaps the following will work for you. Since I worked it out more by trial-and-error than by expertise, there may be unnecessary code that remains. Mainly what I did was the following:

Computed the camera position before doing the export by a better method. Your computation of the camera position was the source of the oscillation.
Eliminated many options, some of which caused problems and others which were simply redundant. I also added a few options the improve the look of graphics.

Δϕ = π 14.0/13.0;

p1 =
  Table[
    RegionPlot3D[
      x^2 + y^2 + (z - j)^2 < 0.5^2 && 
      (x - 0.4 Cos[j Δϕ]) Cos[j Δϕ] + (y - 0.4 Sin[j Δϕ]) Sin[j Δϕ] < 0, 
      {x, -0.5, 0.5}, {y, -0.5, 0.5}, {z, -0.5 + j, 0.5 + j},
      PlotStyle -> Blue,  Lighting -> "Neutral", Mesh -> None],
    {j, 0, 5}];

p2 =
  Graphics3D[{
    Black,
    Table[
      Arrow @ Tube[{{0.4 Cos[j Δϕ], 0.4 Sin[j Δϕ], j}, {Cos[j Δϕ], Sin[j Δϕ], j}}], 
      {j, 0, 5}]}];

vp = 
  Table[
    RotationTransform[θ, {0, 0, 1}, {0, 0, 0}][{0, -50, 3}], 
    {θ, N[2 π Subdivide[36]]}];

Export[
  FileNameJoin[{$HomeDirectory, "Desktop", "RotatingSpheres.gif"}],
  Show[p1, p2,
    PlotRange -> {{-1, 1}, {-1, 1}, {-.5, 5.5}},
    Axes -> False,
    Boxed -> False,
    BoxRatios -> Automatic,
    SphericalRegion -> True,
    ViewPoint -> #] & /@ vp];

###Update

Update

At Yves Klett's behest, I have made the arrows into 3D tube-based arrows.

Perhaps the following will work for you. Since I worked it out more by trial-and-error than by expertise, there may be unnecessary code that remains. Mainly what I did was the following:

Computed the camera position before doing the export by a better method. Your computation of the camera position was the source of the oscillation.
Eliminated many options, some of which caused problems and others which were simply redundant. I also added a few options the improve the look of graphics.

Δϕ = π 14.0/13.0;

p1 =
  Table[
    RegionPlot3D[
      x^2 + y^2 + (z - j)^2 < 0.5^2 && 
      (x - 0.4 Cos[j Δϕ]) Cos[j Δϕ] + (y - 0.4 Sin[j Δϕ]) Sin[j Δϕ] < 0, 
      {x, -0.5, 0.5}, {y, -0.5, 0.5}, {z, -0.5 + j, 0.5 + j},
      PlotStyle -> Blue,  Lighting -> "Neutral", Mesh -> None],
    {j, 0, 5}];

p2 =
  Graphics3D[{
    Black,
    Table[
      Arrow @ Tube[{{0.4 Cos[j Δϕ], 0.4 Sin[j Δϕ], j}, {Cos[j Δϕ], Sin[j Δϕ], j}}], 
      {j, 0, 5}]}];

vp = 
  Table[
    RotationTransform[θ, {0, 0, 1}, {0, 0, 0}][{0, -50, 3}], 
    {θ, N[2 π Subdivide[36]]}];

Export[
  FileNameJoin[{$HomeDirectory, "Desktop", "RotatingSpheres.gif"}],
  Show[p1, p2,
    PlotRange -> {{-1, 1}, {-1, 1}, {-.5, 5.5}},
    Axes -> False,
    Boxed -> False,
    BoxRatios -> Automatic,
    SphericalRegion -> True,
    ViewPoint -> #] & /@ vp];

###Update

At Yves Klett's behest, I have made the arrows into 3D tube-based arrows.

Perhaps the following will work for you. Since I worked it out more by trial-and-error than by expertise, there may be unnecessary code that remains. Mainly what I did was the following:

Computed the camera position before doing the export by a better method. Your computation of the camera position was the source of the oscillation.
Eliminated many options, some of which caused problems and others which were simply redundant. I also added a few options the improve the look of graphics.

Δϕ = π 14.0/13.0;

p1 =
  Table[
    RegionPlot3D[
      x^2 + y^2 + (z - j)^2 < 0.5^2 && 
      (x - 0.4 Cos[j Δϕ]) Cos[j Δϕ] + (y - 0.4 Sin[j Δϕ]) Sin[j Δϕ] < 0, 
      {x, -0.5, 0.5}, {y, -0.5, 0.5}, {z, -0.5 + j, 0.5 + j},
      PlotStyle -> Blue,  Lighting -> "Neutral", Mesh -> None],
    {j, 0, 5}];

p2 =
  Graphics3D[{
    Black,
    Table[
      Arrow @ Tube[{{0.4 Cos[j Δϕ], 0.4 Sin[j Δϕ], j}, {Cos[j Δϕ], Sin[j Δϕ], j}}], 
      {j, 0, 5}]}];

vp = 
  Table[
    RotationTransform[θ, {0, 0, 1}, {0, 0, 0}][{0, -50, 3}], 
    {θ, N[2 π Subdivide[36]]}];

Export[
  FileNameJoin[{$HomeDirectory, "Desktop", "RotatingSpheres.gif"}],
  Show[p1, p2,
    PlotRange -> {{-1, 1}, {-1, 1}, {-.5, 5.5}},
    Axes -> False,
    Boxed -> False,
    BoxRatios -> Automatic,
    SphericalRegion -> True,
    ViewPoint -> #] & /@ vp];

Update

At Yves Klett's behest, I have made the arrows into 3D tube-based arrows.

Added further explanation

Source Link

edited Feb 25, 2016 at 8:11

m_goldberg

108.2k
16
104
259

Perhaps the following will work for you. Since I worked it out more by trial-and-error than by expertise, there may be unnecessary code that remains. Mainly what I did was tothe following:

computeComputed the camera position in advance ofbefore doing the export stepby a better method. Your computation of the camera position was the source of the oscillation.
eliminateEliminated many options, some of which caused problems and others which were simply redundant. I also added a few options the improve the look of graphics.

Δϕ = π 14.0/13.0;

p1 =
  Table[
    RegionPlot3D[
      x^2 + y^2 + (z - j)^2 < 0.5^2 && 
      (x - 0.4 Cos[j Δϕ]) Cos[j Δϕ] + (y - 0.4 Sin[j Δϕ]) Sin[j Δϕ] < 0, 
      {x, -0.5, 0.5}, {y, -0.5, 0.5}, {z, -0.5 + j, 0.5 + j},
      PlotStyle -> Blue,  Lighting -> "Neutral", Mesh -> None],
    {j, 0, 5}];

p2 =
  Graphics3D[{
    Black,
    Table[
      Arrow @ Tube[{{0.4 Cos[j Δϕ], 0.4 Sin[j Δϕ], j}, {Cos[j Δϕ], Sin[j Δϕ], j}}], 
      {j, 0, 5}]}];

vp = 
  Table[
    RotationTransform[θ, {0, 0, 1}, {0, 0, 0}][{0, -50, 3}], 
    {θ, N[2 π Subdivide[36]]}];

Export[
  FileNameJoin[{$HomeDirectory, "Desktop", "RotatingSpheres.gif"}],
  Show[p1, p2,
    PlotRange -> {{-1, 1}, {-1, 1}, {-.5, 5.5}},
    Axes -> False,
    Boxed -> False,
    BoxRatios -> Automatic,
    SphericalRegion -> True,
    ViewPoint -> #] & /@ vp];

###Update

At Yves Klett's behest, I have made the arrowarrows into 3D tube-based arrows.

Perhaps the following will work for you. Since I worked it out more by trial-and-error than by expertise, there may be unnecessary code that remains. Mainly what I did was to

compute the camera position in advance of the export step
eliminate many options, some of which caused problems and others which were simply redundant

Δϕ = π 14.0/13.0;

p1 =
  Table[
    RegionPlot3D[
      x^2 + y^2 + (z - j)^2 < 0.5^2 && 
      (x - 0.4 Cos[j Δϕ]) Cos[j Δϕ] + (y - 0.4 Sin[j Δϕ]) Sin[j Δϕ] < 0, 
      {x, -0.5, 0.5}, {y, -0.5, 0.5}, {z, -0.5 + j, 0.5 + j},
      PlotStyle -> Blue,  Lighting -> "Neutral", Mesh -> None],
    {j, 0, 5}];

p2 =
  Graphics3D[{
    Black,
    Table[
      Arrow @ Tube[{{0.4 Cos[j Δϕ], 0.4 Sin[j Δϕ], j}, {Cos[j Δϕ], Sin[j Δϕ], j}}], 
      {j, 0, 5}]}];

vp = 
  Table[
    RotationTransform[θ, {0, 0, 1}, {0, 0, 0}][{0, -50, 3}], 
    {θ, N[2 π Subdivide[36]]}];

Export[
  FileNameJoin[{$HomeDirectory, "Desktop", "RotatingSpheres.gif"}],
  Show[p1, p2,
    PlotRange -> {{-1, 1}, {-1, 1}, {-.5, 5.5}},
    Axes -> False,
    Boxed -> False,
    BoxRatios -> Automatic,
    SphericalRegion -> True,
    ViewPoint -> #] & /@ vp];

###Update

At Yves Klett's behest, I have made the arrow into 3D tube-based arrows.

Perhaps the following will work for you. Since I worked it out more by trial-and-error than by expertise, there may be unnecessary code that remains. Mainly what I did was the following:

Computed the camera position before doing the export by a better method. Your computation of the camera position was the source of the oscillation.
Eliminated many options, some of which caused problems and others which were simply redundant. I also added a few options the improve the look of graphics.

Δϕ = π 14.0/13.0;

p1 =
  Table[
    RegionPlot3D[
      x^2 + y^2 + (z - j)^2 < 0.5^2 && 
      (x - 0.4 Cos[j Δϕ]) Cos[j Δϕ] + (y - 0.4 Sin[j Δϕ]) Sin[j Δϕ] < 0, 
      {x, -0.5, 0.5}, {y, -0.5, 0.5}, {z, -0.5 + j, 0.5 + j},
      PlotStyle -> Blue,  Lighting -> "Neutral", Mesh -> None],
    {j, 0, 5}];

p2 =
  Graphics3D[{
    Black,
    Table[
      Arrow @ Tube[{{0.4 Cos[j Δϕ], 0.4 Sin[j Δϕ], j}, {Cos[j Δϕ], Sin[j Δϕ], j}}], 
      {j, 0, 5}]}];

vp = 
  Table[
    RotationTransform[θ, {0, 0, 1}, {0, 0, 0}][{0, -50, 3}], 
    {θ, N[2 π Subdivide[36]]}];

Export[
  FileNameJoin[{$HomeDirectory, "Desktop", "RotatingSpheres.gif"}],
  Show[p1, p2,
    PlotRange -> {{-1, 1}, {-1, 1}, {-.5, 5.5}},
    Axes -> False,
    Boxed -> False,
    BoxRatios -> Automatic,
    SphericalRegion -> True,
    ViewPoint -> #] & /@ vp];

###Update

At Yves Klett's behest, I have made the arrows into 3D tube-based arrows.

Improved arrows

Source Link

edited Feb 25, 2016 at 7:58

m_goldberg

108.2k
16
104
259

Perhaps the following will work for you. Since I worked it out more by trial-and-error than by expertise, there may be unnecessary code that remains. Mainly what I did was to

compute the camera position in advance of the export step
eliminate many options, some of which caused problems and others which were simply redundant

Δϕ = π 14.0/13.0;

p1 =
  Table[
    RegionPlot3D[
      x^2 + y^2 + (z - j)^2 < 0.5^2 && 
      (x - 0.4 Cos[j Δϕ]) Cos[j Δϕ] + (y - 0.4 Sin[j Δϕ]) Sin[j Δϕ] < 0, 
      {x, -0.5, 0.5}, {y, -0.5, 0.5}, {z, -0.5 + j, 0.5 + j},
      PlotStyle -> Blue,  Lighting -> "Neutral", Mesh -> None],
    {j, 0, 5}];

p2 =
  Graphics3D[{
    Black,
    Table[
     Arrow[ Arrow @ Tube[{{0.4 Cos[j Δϕ], 0.4 Sin[j Δϕ], j}, {Cos[j Δϕ], Sin[j Δϕ], j}}], 
      {j, 0, 5}]];]}];

vp = 
  Table[
    RotationTransform[θ, {0, 0, 1}, {0, 0, 0}][{0, -50, 3}], 
    {θ, N[2 π Subdivide[36]]}];

Export[
  FileNameJoin[{$HomeDirectory, "Desktop", "RotatingSpheres.gif"}],
  Show[p1, p2,
    PlotRange -> {{-1, 1}, {-1, 1}, {-.5, 5.5}},
    Axes -> False,
    Boxed -> False,
    BoxRatios -> Automatic,
    SphericalRegion -> True,
    ViewPoint -> #] & /@ vp];

###Update

At Yves Klett's behest, I have made the arrow into 3D tube-based arrows.

Perhaps the following will work for you. Since I worked it out more by trial-and-error than by expertise, there may be unnecessary code that remains. Mainly what I did was to

compute the camera position in advance of the export step
eliminate many options, some of which caused problems and others which were simply redundant

Δϕ = π 14.0/13.0;

p1 =
  Table[
    RegionPlot3D[
      x^2 + y^2 + (z - j)^2 < 0.5^2 && 
      (x - 0.4 Cos[j Δϕ]) Cos[j Δϕ] + (y - 0.4 Sin[j Δϕ]) Sin[j Δϕ] < 0, 
      {x, -0.5, 0.5}, {y, -0.5, 0.5}, {z, -0.5 + j, 0.5 + j},
      PlotStyle -> Blue,  Lighting -> "Neutral", Mesh -> None],
    {j, 0, 5}];

p2 =
  Graphics3D[
   Table[
     Arrow[{{0.4 Cos[j Δϕ], 0.4 Sin[j Δϕ], j}, {Cos[j Δϕ], Sin[j Δϕ], j}}],
     {j, 0, 5}]];

vp = 
  Table[
    RotationTransform[θ, {0, 0, 1}, {0, 0, 0}][{0, -50, 3}], 
    {θ, N[2 π Subdivide[36]]}];

Export[
  FileNameJoin[{$HomeDirectory, "Desktop", "RotatingSpheres.gif"}],
  Show[p1, p2,
    PlotRange -> {{-1, 1}, {-1, 1}, {-.5, 5.5}},
    Axes -> False,
    Boxed -> False,
    BoxRatios -> Automatic,
    SphericalRegion -> True,
    ViewPoint -> #] & /@ vp];

Perhaps the following will work for you. Since I worked it out more by trial-and-error than by expertise, there may be unnecessary code that remains. Mainly what I did was to

compute the camera position in advance of the export step
eliminate many options, some of which caused problems and others which were simply redundant

Δϕ = π 14.0/13.0;

p1 =
  Table[
    RegionPlot3D[
      x^2 + y^2 + (z - j)^2 < 0.5^2 && 
      (x - 0.4 Cos[j Δϕ]) Cos[j Δϕ] + (y - 0.4 Sin[j Δϕ]) Sin[j Δϕ] < 0, 
      {x, -0.5, 0.5}, {y, -0.5, 0.5}, {z, -0.5 + j, 0.5 + j},
      PlotStyle -> Blue,  Lighting -> "Neutral", Mesh -> None],
    {j, 0, 5}];

p2 =
  Graphics3D[{
    Black,
    Table[
      Arrow @ Tube[{{0.4 Cos[j Δϕ], 0.4 Sin[j Δϕ], j}, {Cos[j Δϕ], Sin[j Δϕ], j}}], 
      {j, 0, 5}]}];

vp = 
  Table[
    RotationTransform[θ, {0, 0, 1}, {0, 0, 0}][{0, -50, 3}], 
    {θ, N[2 π Subdivide[36]]}];

Export[
  FileNameJoin[{$HomeDirectory, "Desktop", "RotatingSpheres.gif"}],
  Show[p1, p2,
    PlotRange -> {{-1, 1}, {-1, 1}, {-.5, 5.5}},
    Axes -> False,
    Boxed -> False,
    BoxRatios -> Automatic,
    SphericalRegion -> True,
    ViewPoint -> #] & /@ vp];

###Update

At Yves Klett's behest, I have made the arrow into 3D tube-based arrows.

deleted 6 characters in body

Source Link

edited Feb 25, 2016 at 4:18

m_goldberg

108.2k
16
104
259

Loading

Source Link

created Feb 25, 2016 at 4:08

m_goldberg

108.2k
16
104
259

Loading

Stack Exchange Network

Return to Answer

Update

Update