アフィン変換3D@Mathematica

回転、平行移動、拡大、スキューの変形を実装したプログラムを作りました。
行列をかけると実際にどういう変化が起こるのか、視覚的にわかりやすいです。
「Print」を押すと変形後の画像のみを出力します。

Mathematicaはなぜか実行結果をswfファイルに出力できるので、出力してみました。
実際の動きはこんな感じになっとります。
ボタンがあったりスライダーがあったり、Mathematicaにこんな機能があるのを知らない人は結構多いようで。意外とGUIが優秀だと思います。
面白いコンポーネントはたくさんあるので、いろいろ試してみるといいかも。Slider2Dなんか変わってて好きです。

そういえばFlexでも2D版を作ったんですけど、公開するの忘れてましたねぇ・・・

以下ソース(みたい人なんているんだろうか)

(*
This program is written for Mathematica6.0.
Mathematica 5.2 cannot execute this program.
*)
Clear[t, s, u];
F = {{1, 1, 1}, {1, 1, -1}, {1, -1, -1}, {1, -1, 1},
   {-1, 1, 1}, {-1, 1, -1}, {-1, -1, -1}, {-1, -1, 1}};
Fi = {{1, 2, 3, 4}, {5, 6, 7, 8}, {1, 5, 6, 2}, {2, 6, 7, 3}, {3, 7, 
    8, 4}, {4, 8, 5, 1}};

A1[t_] := {
   {Cos[t], -Sin[t], 0},
   {Sin[t], Cos[t], 0},
   {0, 0, 1}};
A2[t_] := {
   {1, 0, 0},
   {0, Cos[t], -Sin[t]},
   {0, Sin[t], Cos[t]}};
A3[t_] := {
   {Cos[t], 0, Sin[t]},
   {0, 1, 0},
   {-Sin[t], 0, Cos[t]}};

MyScale[t_] := {
   {t, 0, 0},
   {0, t, 0},
   {0, 0, t}
   };

MyAffine[x_, y_] := {
   {1, Tan[x], 0},
   {Tan[y], 1, 0},
   {0, 0, 1}};


Manipulate[
 (*Rotate*)
 F' = Map[A3[u].# &, Map[A2[s].# &, Map[A1[t].# &, F]]];
 (*Affine*)
 F'' = Map[MyAffine[affineX, affineY].# &, F'];
 (*Scale*)
 F''' = Map[MyScale[Schlar].# &, F''];
 (*Translate*)
 F'''' = Map[{x, y, z} + # &, F'''];
 
 Show[
  (*描画*)
  Graphics3D[
   {EdgeForm[None],
    RGBColor[0.1, 0.1, 0.1, 0.1],
    GraphicsComplex[F, Polygon[Fi]],
    {RGBColor[t/(2 Pi), s/(2 Pi), u/(2 Pi), 0.4], 
     GraphicsComplex[F'''', Polygon[Fi]]},
    RGBColor[1.0, 0, 0, 0.7],
    PointSize[Large],
    Point[F'''']
    }
   ],
  (*Option*)
  Axes -> True, AspectRatio -> Automatic,
  PlotRange -> {{-3, 3}, {-3, 3}, {-3, 3}}],
 
 Button["print",
  Print[
   Show[
    Graphics3D[
     {EdgeForm[None],
      (*RGBColor[0.1,0.1,0.1,0.1],
      GraphicsComplex[F,Polygon[Fi]],*)
      {RGBColor[t/(2 Pi), s/(2 Pi), u/(2 Pi), 0.4], 
       GraphicsComplex[F'''', Polygon[Fi]]},
      RGBColor[1.0, 0, 0, 0.7],
      PointSize[Large],
      Point[F'''']
      }
     ],
    
    (*Option*)
    Axes -> True, AspectRatio -> Automatic,
    PlotRange -> {{-5, 5}, {-5, 5}, {-5, 5}}]
   ]
  ],
 (*Dynamic[Text[Style[Table[{i;F[[i]]->F''''[[i]],"\n\
"},{i,1,8}],FontSize->20]]],*)
 
 
 (*変数*)
 {t, 0, 2 Pi},
 {s, 0, 2 Pi},
 {u, 0, 2 Pi},
 {{x, 0}, -5, 5},
 {{y, 0}, -5, 5},
 {{z, 0}, -5, 5},
 {Schlar, 1, 3},
 {affineX, 0, Pi/2},
 {affineY, 0, Pi/2}
 ]