动画3d绘图，在mathematica中有一些进一步的要求

Question

我之前在this post发布了，但我仍然无法完全解决以下问题。举个例子：

{pA, pB, pC, pD} = {{0, 0, Sqrt[61/3]}, {Sqrt[7], 4*Sqrt[2/3], 0}, {0, -5*Sqrt[2/3], 0}, {-Sqrt[71], 4*Sqrt[2/3], 0}};
axis={1,0,0};pt={0,1,0};
plotPolygon[{a_, b_, c_}] := {Opacity[.4], Polygon[{a, b, c}]};
graph=Graphics3D[{plotPolygon[{pA, pB, pC}], plotPolygon[{pA, pB, pD}], 
            plotPolygon[{pB, pC, pD}], plotPolygon[{pA, pC, pD}]}, 
            Axes -> True, AxesOrigin->pt];
Animate[graph/.gg : Graphics3D[___] :> Rotate[gg, theta, axis], {theta, 0., 2.*Pi}]

我想沿着通过点axis={1,0,0}的轴pt={0,1,0}旋转。但我不知道如何指定点信息。此外，旋转动画看起来非常混乱，我预计至少有一个点（在这种情况下，原点？）不会旋转。

Answer 1

您需要先更改多边形顶点的原点，旋转并平移。你可以手动完成这个

(RotationMatrix[theta,axis].(#-pt) + pt)& /@ {pA, pB, pC, pD}

或者，您可以使用Composition

组合转换

Composition[
 AffineTransform[{RotationMatrix[theta,axis],pt}],TranslationTransform[-pt]
] /@ {pA, pB, pC, pD}

或者，您可以将之前的构图直接应用到Graphics对象

GeometricTransformation[ <graphics>, Composition[ ... ]]

此documentation提供了可以执行的操作的完整列表。

编辑：这是一个有效的动画脚本

Animate[
  graph /. Graphics3D[prims__, opts : OptionsPattern[]] :> 
    Graphics3D[
      GeometricTransformation[prims,
        Composition[
          AffineTransform[{RotationMatrix[theta, axis], pt}],
          TranslationTransform[-pt]
        ]
      ],
      opts
    ], 
  {theta, 0., 2.*Pi}
]

这里有几点需要注意。首先，GeometricTransformation似乎只对基元本身起作用，因此我不得不通过规则Graphics3D从Graphics3D[prims__, opts : OptionsPattern[]]中的选项中分离出基元。此外，转换本身必须在Animate范围内才能使用theta的本地版本。