Mathematica 行列の固有値(座標変換と図形変形)

計算機代数ノート

本稿は『数学アラカルト 行列の固有値とリーマン予想』で使用したMathematicaのソースコードの公開と簡単な解説です。Mathematicaの環境が無い場合はこちらを参考に環境を整備してください。

初期化

念のため最初に1度だけ実行してください。

(* Mathematica *)
ClearAll["Global`*"]

描画関数や座標変換関数等のセットアップ

コピペして上記初期化後1度だけ実行してください。

(*Mathematica*)rt[a_] := {{Cos[a], -Sin[a]}, {Sin[a], Cos[a]}};
axs[scp_] := {Plot[{x, -x}, {x, scp[[1]], scp[[2]]}, 
    AspectRatio -> Automatic, 
    PlotStyle -> {{Gray, Dashed, Thin}, {Gray, Dashed, Thin}}, 
    GridLines -> {Table[ix, {ix, scp[[1]], scp[[2]]}], 
      Table[ix, {ix, scp[[1]], scp[[2]]}]}]};

vec[s_, v_, tx_, txadj_: 0.15 N[rt[3 Pi/8]]] := 
 Graphics[Append[s, 
   Table[{Arrow[{{0, 0}, v[[ix]]}], 
     Text[tx[[ix]], v[[ix]] + txadj.Normalize[v[[ix]]]]}, {ix, 
     Length[v]}]]]
plotCpSpc[c_, rd_: 1] := 
  Show[{Graphics[{{cBluL, Dashed, 
       Circle[{0, 0}, 
        rd]}, {Arrowheads[{{0.04, 1, Graphics[Disk[]]}}], cBluH, 
       Thick, Arrow[{{0, 0}, {Re[c], Im[c]}}]}}]}];
t[m_] := Transpose[m];
i[m_] := Inverse[m];
dm[v_] := DiagonalMatrix[v];
mf[list_] := MatrixForm[list];

J[X_, U_] := Table[D[X[[i]], U[[j]]], {i, Length[X]}, {j, Length[U]}];
(*//PowerExpand//ExpandAll//*)

Metric[FM_, TF_, TC_, B_] := 
  Module[{sz}, sz = Length[TC]; 
   Table[Sum[
     Sum[FM[[i, j]]*D[Apply[TF, {TC, B}][[i]], TC[[k]]]*
       D[Apply[TF, {TC, B}][[j]], TC[[l]]], {i, sz}], {j, sz}], {k, 
     sz}, {l, sz}]];

delta = DiagonalMatrix[{1, 1}];
eta = DiagonalMatrix[{1, -1}];

lplot[y_] := 
 Table[Line[{{ix - 1, y[[ix]]}, {ix, y[[ix]]}}], {ix, 1, Length[y]}]
rplot[y_] := 
 Table[Rectangle[{ix - 1, 0}, {ix, y[[ix]]}], {ix, 1, Length[y]}]

OpL[V_, C_] := 
  ParametricPlot[(V[[1]] + (V[[2]] - V[[1]])*t)[[{2, 1}]], {t, 0, 1}, 
   PlotStyle -> C];
cBluH = RGBColor[0, 0.1, 0.5, 1]; cBluL = RGBColor[0, 0.1, 0.5, 0.3];
cGrnH = RGBColor[0, 0.5, 0.1, 1]; cGrnL = RGBColor[0, 0.5, 0.1, 0.4];
LPe = 0.3 rt[-2 Pi/8];
LPf = 0.3 rt[-1 Pi/8];

(*線形変換*)
LTF[X_, W_] := W.X;
e = dm[{1, 1}];

(*---------------描画パッケージ-----------------*)

dPoint[TF_, B_, xy_, nt_] := 
  Table[Apply[
    TF, {xy[[ix + 1]] + id*(xy[[ix + 2]] - xy[[ix + 1]])/nt, B}], {ix,
     0, Length[xy] - 2}, {id, 0, nt}];
dLine[TF_, B_, xy_, nt_] := Line[Flatten[dPoint[TF, B, xy, nt], 1]];
dArrow[TF_, B_, xy_, nt_] := Arrow[Flatten[dPoint[TF, B, xy, nt], 1]];

rv[dim_] := 
  Table[Position[dim, Range[Length[dim]][[ix]]][[1, 1]], {ix, 
    Length[dim]}];
ms[X_] := If[Length[X] == 2, X[[{2, 1}]], X[[{2, 1, 3}]]];

grdLines[dim_, base_, TF_, B_, grRange_, nt_] := 
  Table[dLine[TF, 
    B, {({ix, grRange[[dim]][[2, 1]], 0} + base)[[rv[
        dim]]], ({ix, grRange[[dim]][[2, 2]], 0} + base)[[rv[dim]]]}, 
    nt], {ix, grRange[[dim]][[1, 1]], grRange[[dim]][[1, 2]]}];

grdScText[dim_, base_, TF_, B_, grRange_, scText_, scOfst_] := 
  If[scText[[dim]][[1, 1]] == 0, {}, 
   Table[Text[
     Style[StringJoin[ToString[ix*scText[[dim]][[1, 1]]], 
       scText[[dim]][[1, 2]]], Medium, FontFamily -> "Times"], 
     Apply[TF, {({ix, 0, 0} + base)[[rv[dim]]] + 
         If[Length[Dimensions[scOfst[[rv[dim][[1]]]]]] == 2, 
          scOfst[[rv[dim][[1]]]][[2]], 0], B}] + 
      If[Length[Dimensions[scOfst[[rv[dim][[1]]]]]] == 2, 
       scOfst[[rv[dim][[1]]]][[1]], scOfst[[rv[dim][[1]]]]]], {ix, 
     Flatten[{Range[grRange[[dim]][[1, 1]], -1], 
       Range[1, grRange[[dim]][[1, 2]]]}]}]];

axsArrow[TF_, B_, axVector_, axText_, axOfst_, 
  nt_] := {dArrow[TF, B, {axVector[[1]], axVector[[2]]}, nt], 
  Text[Style[axText,(*Large,*)FontFamily -> "Times"], 
   Apply[TF, {axVector[[2]], B}] + axOfst]}

tfCrdSys2D[TF_, B_, grRange_, axVectors_, axTexts_, scText_, scOfst_, 
   axOfst_, figColor_, nPints_] := 
  Graphics[{figColor, AbsoluteThickness[0.1], 
    grdLines[{1, 2}, 0, TF, B, grRange, nPints], 
    grdScText[{1, 2}, 0, TF, B, grRange, scText, scOfst], 
    grdLines[{2, 1}, 0, TF, B, grRange, nPints], 
    grdScText[{2, 1}, 0, TF, B, grRange, scText, scOfst], figColor, 
    AbsoluteThickness[2], 
    axsArrow[TF, B, axVectors[[1]], axTexts[[1]], axOfst[[1]], 
     nPints], figColor, AbsoluteThickness[2], 
    axsArrow[TF, B, axVectors[[2]], axTexts[[2]], axOfst[[2]], 
     nPints]}];
tfCrdSys2Dg[TF_, B_, grRange_, scText_, scOfst_, figColor_, nPints_] :=
   Graphics[{figColor, AbsoluteThickness[0.1], 
    grdLines[{1, 2}, 0, TF, B, grRange, nPints], 
    grdScText[{1, 2}, 0, TF, B, grRange, scText, scOfst], 
    grdLines[{2, 1}, 0, TF, B, grRange, nPints], 
    grdScText[{2, 1}, 0, TF, B, grRange, scText, scOfst]}];

tfCrdSys3D[TF_, B_, grRange_, axVectors_, axTexts_, scText_, scOfst_, 
  axOfst_, figColor_, nPints_] := 
 Graphics3D[{figColor, AbsoluteThickness[0.1], 
   grdLines[{1, 2, 3}, 0, TF, B, grRange, nPints], figColor, 
   grdScText[{1, 2, 3}, 0, TF, B, grRange, scText, scOfst], figColor, 
   AbsoluteThickness[2], 
   axsArrow[TF, B, axVectors[[1]], axTexts[[1]], axOfst[[1]], nPints],
    figColor, AbsoluteThickness[0.1], 
   grdLines[{2, 1, 3}, 0, TF, B, grRange, nPints], figColor, 
   grdLines[{2, 3, 1}, 0, TF, B, grRange, nPints], figColor, 
   grdScText[{2, 3, 1}, 0, TF, B, grRange, scText, scOfst], figColor, 
   AbsoluteThickness[2], 
   axsArrow[TF, B, axVectors[[2]], axTexts[[2]], axOfst[[2]], nPints],
    figColor, AbsoluteThickness[0.1], 
   grdLines[{1, 3, 2}, 0, TF, B, grRange, nPints], figColor, 
   grdLines[{3, 1, 2}, 0, TF, B, grRange, nPints], figColor, 
   grdLines[{3, 2, 1}, 0, TF, B, grRange, nPints], figColor, 
   grdScText[{3, 2, 1}, 0, TF, B, grRange, scText, scOfst], figColor, 
   AbsoluteThickness[2], 
   axsArrow[TF, B, axVectors[[3]], axTexts[[3]], axOfst[[3]], nPints]}]
tfCrdSys3Dm1[TF_, B_, grRange_, axVectors_, axTexts_, scText_, 
  scOfst_, axOfst_, figColor_, nPints_] := 
 Graphics3D[{figColor, AbsoluteThickness[0.1], 
   grdLines[{1, 2, 3}, 0, TF, B, grRange, nPints], figColor, 
   grdScText[{1, 2, 3}, 0, TF, B, grRange, scText, scOfst], figColor, 
   AbsoluteThickness[2], 
   axsArrow[TF, B, axVectors[[1]], axTexts[[1]], axOfst[[1]], nPints],
    figColor, AbsoluteThickness[0.1], 
   grdLines[{2, 1, 3}, 0, TF, B, grRange, nPints], figColor, 
   grdLines[{2, 3, 1}, 0, TF, B, grRange, nPints], figColor, 
   grdScText[{2, 3, 1}, 0, TF, B, grRange, scText, scOfst], figColor, 
   AbsoluteThickness[2], 
   axsArrow[TF, B, axVectors[[2]], axTexts[[2]], axOfst[[2]], 
    nPints],(*figColor,grdLines[{1,3,2},0,TF,B,grRange,nPints],
   figColor,grdLines[{3,1,2},0,TF,B,grRange,nPints],*)figColor, 
   AbsoluteThickness[0.1], 
   grdLines[{3, 2, 1}, {0, 0, 0}, TF, B, grRange, nPints], figColor, 
   grdScText[{3, 2, 1}, {0, 0, 0}, TF, B, grRange, scText, scOfst], 
   figColor, AbsoluteThickness[2], 
   axsArrow[TF, B, axVectors[[3]], axTexts[[3]], axOfst[[3]], 
    nPints]}]

描画出力 無し

1. ベクトル空間]の描画に対応

以下各章節にリンクを貼りました。読み比べながら実行してみてください。

描画出力は代表の画像を1枚のみ貼り付けてあります。実行するとその他も描画されます。

1.1 基底とベクトルの成分の関係

(*グラフのフォーム設定*)
Gh = {{-5, 5}, {-5, 5}};
Gt = {{-5, 5}, {-5, 5}};
gX = 3 {{-1, 1}, {-1, 1}};
gU = 2 {{-1, 1}, {-1, 1}};
scText = {{1, ""}, {1, ""}};
(*{{Post Offset},{Pre Offset}}*) 
scOfst = {{0.2, -0.15}, {-0.2, 0.15}};

r = 2 {1, 1}
b = {{1, 0.25}, {0, 1}};
(*b={{1,1/4},{0.2,0.8}};*)
Print["B=", b // mf]
Print["\!\(\*SuperscriptBox[\(B\), \(-1\)]\)=", i[b] // mf]

s = i[b].r;
cdm = dm[s];
% // mf
vb = vec[{cGrnH, Thick}, t[b], {"b1", "b2"}, 1.4 LPf];
vr = vec[{Red, Thick}, {r}, {"R"}, 1.7 LPf];
br2 = (t[b].r)[[2]] t[b][[2]]
lbr2 = Graphics[{cBluH, Dashed, Line[{{0, 0}, br2, r}]}];
grXsys = tfCrdSys2Dg[LTF, e, gX, scText, scOfst, cBluH, 1];
Show[grXsys, vb, vr, lbr2]
grXsys = tfCrdSys2Dg[LTF, e, gX, scText, scOfst, cBluL, 1];
grUsys = tfCrdSys2Dg[LTF, b, {2 {-1, 1}, 3 {-1, 1}}, scText, scOfst, 
   cGrnH, 1];
Show[grXsys, grUsys, vb, vr]
vbu = vec[{cGrnH, Thick}, t[i[b].b], {"b1", "b2"}, 1.4 LPf];
vru = vec[{Red, 
    Thick}, {i[b].r}, {"S=\!\(\*SuperscriptBox[\(B\), \(-1\)]\)R"}, 
   1.7 LPf];
grXsys = tfCrdSys2Dg[LTF, i[b], gX, scText, scOfst, cBluL, 1];
grUsys = tfCrdSys2Dg[LTF, e, {2 {-1, 1}, 3 {-1, 1}}, scText, scOfst, 
   cGrnH, 1];
Show[grXsys, grUsys, vbu, vru]


vr = vec[{Red, Thick}, {r}, {"R"}, 1.7 LPf];
rb1 = t[b.cdm][[1]]; (*cdm=b^-1S成分の注入*)
rb2 = t[b.cdm][[2]];
(*rb=rb1+rb2;*)
rb = b.s;
rl = Graphics[{cBluH, Dashed, Line[{{rb1, rb}, {rb2, rb}}]}];
vrb = vec[{cBluH, Dashed}, {rb1, rb2, rb}, {"rb1", "rb2", "rb1+rb2"}];
grXsys = tfCrdSys2Dg[LTF, e, gX, scText, scOfst, cBluH, 1];
Show[grXsys, vb, vr]
Show[grXsys, vb, vr, vrb, rl]
Show[grXsys, grUsys, vb, vr]

1.2 座標変換と固有値の関係]に対応

回転変換の例

(*位置ベクトル p を計算する作業1*)
f[t_] := 2 N[{Cos[t], -Sin[t]}]
pltVf[cc_, txt_, w_: dm[{1, 1}]] := 
 Module[{p12, p, vf, vp, vp12, robj},
  p12 = w.dm[f[1.75 Pi]];
  vp12 = vec[{cc, Thick, Dashed}, t[p12], {txt[[1]], txt[[2]]}, LPf];
  p = t[p12][[1]] + t[p12][[2]];
  
  vp = vec[{cc, Thick}, {p}, {txt[[3]]}, LPf];
  vf = Graphics[{cc, Thick, 
     Line[Table[w.f[t], {t, 0, 1.75 Pi, 0.01}]]}];
  robj = {vp12, vp, vf};
  robj
  ]
B = e;
L = dm[{1, 0.5}];

W = B; Print["W=", 
 W // mf]; Print["\!\(\*SuperscriptBox[\(W\), \(-1\)]\)=", i[W] // mf]

(*基準系を表示*)

grXsys = tfCrdSys2Dg[LTF, e, gX, scText, scOfst, cBluH, 1];
vW = vec[{cBluH, Thick}, t[B], {"e1", "e2"}];
pVfe = pltVf[Red, {" Px1", "Px2", "Px"}, B];
Show[grXsys, vW, 
 PlotRange -> {{Gh[[1, 1]], Gh[[1, 2]] + 0.01}, {Gh[[2, 1]] + 0.7, 
    Gh[[2, 2]]}}]
Show[grXsys, vW, pVfe, 
 PlotRange -> {{Gh[[1, 1]], Gh[[1, 2]] + 0.01}, {Gh[[2, 1]] + 0.7, 
    Gh[[2, 2]]}}]

(*基準系に回転ベクトルBを表示*)
B = rt[1/4 Pi].e;
(*B={{1,1/Sqrt[2]},{0,1/Sqrt[2]}};*)
W = B; Print["W=", 
 W // mf]; Print["\!\(\*SuperscriptBox[\(W\), \(-1\)]\)=", i[W] // mf]

vW = vec[{cGrnH, Thick}, t[B], {"   b1", "b2"}, 0.7 LPe];
Show[grXsys, vW, pVfe, 
 PlotRange -> {{Gh[[1, 1]], Gh[[1, 2]] + 0.01}, {Gh[[2, 1]] + 0.7, 
    Gh[[2, 2]]}}]

(*基準系に斜交ベクトルBと斜交座標と変換オブジェクトを表示*)
grXsys = tfCrdSys2Dg[LTF, e, gX, scText, scOfst, cBluL, 1];
grUsys = tfCrdSys2Dg[LTF, B, {2 {-1, 1}, 3 {-1, 1}}, scText, scOfst, 
   cGrnH, 1];
Show[grXsys, vW, grUsys, pVfe]


(*回転座標系に移動しベクトルBとと変換オブジェクトを表示*)
vW = vec[{cGrnH, Thick}, 
   t[i[B].B], {"\!\(\*SuperscriptBox[\(B\), \(-1\)]\)b1", 
    "       \!\(\*SuperscriptBox[\(B\), \(-1\)]\)b2"}, 0.7 LPe];
grXsys = tfCrdSys2Dg[LTF, i[B], gX, scText, scOfst, cBluL, 1];
grUsys = tfCrdSys2Dg[LTF, i[B].B, {2 {-1, 1}, 3 {-1, 1}}, scText, 
   scOfst, cGrnH, 1];
Show[grXsys, grUsys, vW, 
 pltVf[Red, {"\!\(\*SuperscriptBox[\(B\), \(-1\)]\)Px1", 
   "\!\(\*SuperscriptBox[\(B\), \(-1\)]\)Px2", 
   "             \!\(\*SuperscriptBox[\(B\), \(-1\)]\)Px"}, i[B]]]

(*回転座標系に移動しLを乗じベクトルBとと変換オブジェクトを表示*)
grXsys = tfCrdSys2Dg[LTF, i[B], {3 {-1, 1}, 3 {-1, 1}}, scText, 
   scOfst, cBluL, 1];
grUsys = tfCrdSys2Dg[LTF, i[B].B, {2 {-1, 1}, 3 {-1, 1}}, scText, 
   scOfst, cGrnH, 1];
p = pltVf[
   Red, {"\!\(\*SuperscriptBox[\(LB\), \(-1\)]\)Px1           ", 
    "\!\(\*SuperscriptBox[\(LB\), \(-1\)]\)Px2         ", 
    "           \!\(\*SuperscriptBox[\(LB\), \(-1\)]\)Px"}, L.i[B]];
Show[grXsys, vW, grUsys, p[[1]], p[[2]], p[[3]]]



(*基準系に斜交ベクトルBと斜交座標と変換オブジェクトを表示*)
grXsys = tfCrdSys2Dg[LTF, e, gX, scText, scOfst, cBluH, 1];
grUsys = tfCrdSys2Dg[LTF, B, {2 {-1, 1}, 3 {-1, 1}}, scText, scOfst, 
   cGrnL, 1];
p = pltVf[
   Red, {"", "", 
    "            \!\(\*SuperscriptBox[\(BLB\), \(-1\)]\)Px"}, 
   B.L.i[B]];
Show[grXsys, grUsys, p[[2]], p[[3]]]

斜交座標変換の例

B = e;
L = dm[{0.5, 2/Sqrt[2]}];
W = B; Print["W=", 
 W // mf]; Print["\!\(\*SuperscriptBox[\(W\), \(-1\)]\)=", i[W] // mf]

(*基準系を表示*)

grXsys = tfCrdSys2Dg[LTF, e, gX, scText, scOfst, cBluH, 1];
vW = vec[{cBluH, Thick}, t[B], {"e1", "e2"}];
pVfe = pltVf[Red, {" Px1", "Px2", "Px"}, B];
Show[grXsys, vW, 
 PlotRange -> {{Gh[[1, 1]], Gh[[1, 2]] + 0.01}, {Gh[[2, 1]] + 0.7, 
    Gh[[2, 2]]}}]
Show[grXsys, vW, pVfe, 
 PlotRange -> {{Gh[[1, 1]], Gh[[1, 2]] + 0.01}, {Gh[[2, 1]] + 0.7, 
    Gh[[2, 2]]}}]

(*基準系に斜交ベクトルBを表示*)
B = {{1, 1}, {0, 1}};
(*B={{1,1/Sqrt[2]},{0,1/Sqrt[2]}};*)
W = B; Print["W=", 
 W // mf]; Print["\!\(\*SuperscriptBox[\(W\), \(-1\)]\)=", i[W] // mf]
pVfe = pltVf[RGBColor[1, 0, 0, 0.3], {" Px1", "Px2", "Px"}, e];
vW = vec[{cGrnH, Thick}, t[B], {"b1", "b2             "}, 0.7 LPe];
Show[grXsys, vW, pVfe, 
 PlotRange -> {{Gh[[1, 1]], Gh[[1, 2]] + 0.01}, {Gh[[2, 1]] + 0.7, 
    Gh[[2, 2]]}}]

(*基準系に斜交ベクトルBと斜交座標と変換オブジェクトを表示*)
grXsys = tfCrdSys2Dg[LTF, e, gX, scText, scOfst, cBluL, 1];
grUsys = tfCrdSys2Dg[LTF, B, {2 {-1, 1}, 3 {-1, 1}}, scText, scOfst, 
   cGrnH, 1];
Show[grXsys, vW, grUsys, pVfe]


(*斜交座標系に移動しベクトルBとと変換オブジェクトを表示*)
vW = vec[{cGrnH, Thick}, 
   t[i[B].B], {"\!\(\*SuperscriptBox[\(B\), \(-1\)]\)b1", 
    "\!\(\*SuperscriptBox[\(B\), \(-1\)]\)b2"}, 0.7 LPe];
grXsys = tfCrdSys2Dg[LTF, i[B], gX, scText, scOfst, cBluL, 1];
grUsys = tfCrdSys2Dg[LTF, i[B].B, {2 {-1, 1}, 3 {-1, 1}}, scText, 
   scOfst, cGrnH, 1];
Show[grXsys, grUsys, vW, 
 pltVf[Red, {"\!\(\*SuperscriptBox[\(B\), \(-1\)]\)Px1", 
   "\!\(\*SuperscriptBox[\(B\), \(-1\)]\)Px2", 
   "             \!\(\*SuperscriptBox[\(B\), \(-1\)]\)Px"}, i[B]]]

(*斜交座標系に移動しLを乗じベクトルBとと変換オブジェクトを表示*)
grXsys = tfCrdSys2Dg[LTF, i[B], {3 {-1, 1}, 3 {-1, 1}}, scText, 
   scOfst, cBluL, 1];
grUsys = tfCrdSys2Dg[LTF, i[B].B, {2 {-1, 1}, 3 {-1, 1}}, scText, 
   scOfst, cGrnH, 1];
p = pltVf[
   Red, {"\!\(\*SuperscriptBox[\(LB\), \(-1\)]\)Px1           ", 
    "\!\(\*SuperscriptBox[\(LB\), \(-1\)]\)Px2         ", 
    "           \!\(\*SuperscriptBox[\(LB\), \(-1\)]\)Px"}, L.i[B]];
Show[grXsys, vW, grUsys, p[[1]], p[[2]], p[[3]]]



(*基準系に斜交ベクトルBと斜交座標と変換オブジェクトを表示*)
grXsys = tfCrdSys2Dg[LTF, e, gX, scText, scOfst, cBluH, 1];
grUsys = tfCrdSys2Dg[LTF, B, {2 {-1, 1}, 3 {-1, 1}}, scText, scOfst, 
   cGrnL, 1];
p = pltVf[
   Red, {"", "", 
    "            \!\(\*SuperscriptBox[\(BLB\), \(-1\)]\)Px"}, 
   B.L.i[B]];
Show[grXsys, grUsys, p[[2]], p[[3]]]
(*アダマール変換*)
n = 8

B = HadamardMatrix[n];
A = i[B];
(*Print["B=",B//mf,",  B^-1=",i[B]//Simplify//mf];*)
vp = Table[
   DiscretePlot[t[B][[iy, ix + 1]], {ix, 0, n - 1}, ExtentSize -> 0.2,
     AspectRatio -> 0.125, AxesOrigin -> {0, 0}, 
    Ticks -> {Range[0, n - 1], {-0.5, 0, 0.5}}, 
    PlotRange -> {{-1, n - 1 + 0.5}, 0.5 {-1, 1}}, 
    PlotStyle -> {cBluL, PointSize[0.02]}], {iy, n}];
GraphicsColumn[vp, Frame -> All]

1.3 時間-周波数領域変換]に対応

アダマール変換

n = 8

B = HadamardMatrix[n];
A = i[B];
(*Print["B=",B//mf,",  B^-1=",i[B]//Simplify//mf];*)
vp = Table[
   DiscretePlot[t[B][[iy, ix + 1]], {ix, 0, n - 1}, ExtentSize -> 0.2,
     AspectRatio -> 0.125, AxesOrigin -> {0, 0}, 
    Ticks -> {Range[0, n - 1], {-0.5, 0, 0.5}}, 
    PlotRange -> {{-1, n - 1 + 0.5}, 0.5 {-1, 1}}, 
    PlotStyle -> {cBluL, PointSize[0.02]}], {iy, n}];
GraphicsColumn[vp, Frame -> All]
(*参照信号Rの生成*)
R = Table[Cos[2 Pi 1/n t], {t, 0, n - 1}];
(*R=Table[Sin[2Pi 1/n t],{t,0,n-1}];*)

vp = Table[
   DiscretePlot[R[[ix + 1]], {ix, 0, n - 1}, ExtentSize -> 0.2, 
    AspectRatio -> 0.125, AxesOrigin -> {0, 0}, 
    Ticks -> {Range[0, n - 1], {-1, 0, 1}}, 
    PlotRange -> {{-1, n - 1 + 0.5}, 1.5 {-1, 1}}, 
    PlotStyle -> {cBluL, PointSize[0.02]}], {iy, 1}];
GraphicsColumn[vp, Frame -> All]


S = A.R;
vp = Table[
   DiscretePlot[S[[ix + 1]], {ix, 0, n - 1}, ExtentSize -> 0.2, 
    AspectRatio -> 0.125, AxesOrigin -> {0, 0}, 
    Ticks -> {Range[0, n - 1], {-1, 0, 1}}, 
    PlotRange -> {{-1, n - 1 + 0.5}, 2 {-1, 1}}, 
    PlotStyle -> {cBluL, PointSize[0.02]}], {iy, 1}];
GraphicsColumn[vp, Frame -> All]

Rd = B.S;
vp = Table[
   DiscretePlot[Rd[[ix + 1]], {ix, 0, n - 1}, ExtentSize -> 0.2, 
    AspectRatio -> 0.125, AxesOrigin -> {0, 0}, 
    Ticks -> {Range[0, n - 1], {-1, 0, 1}}, 
    PlotRange -> {{-1, n - 1 + 0.5}, 1.5 {-1, 1}}, 
    PlotStyle -> {cBluL, PointSize[0.02]}], {iy, 1}];
GraphicsColumn[vp, Frame -> All]

離散コサイン変換(DCT)

(*離散コサイン変換(DCT)*)
n = 8
B = N[FourierDCTMatrix[n]];
A = i[B];
(*Print["B=",B//mf,",  B^-1=",i[B]//Simplify//mf];*)
vp = Table[
   DiscretePlot[t[B][[iy, ix + 1]], {ix, 0, n - 1}, ExtentSize -> 0.2,
     AspectRatio -> 0.125, AxesOrigin -> {0, 0}, 
    Ticks -> {Range[0, n - 1], {-1, -0.5, 0, 0.5, 1}}, 
    PlotRange -> {{-1, n - 1 + 0.5}, 0.5 {-1, 1}}, 
    PlotStyle -> {cBluL, PointSize[0.02]}], {iy, n}];
GraphicsColumn[vp, Frame -> All]

(*GraphicsGrid[Table[plotCpSpc[B[[ix,iy]],1/n^0.5],{ix,1,n},{iy,1,n}],\
Frame\[Rule]All]
*)
R = Table[Cos[2 Pi 1/n t], {t, 0, n - 1}];
vp = Table[
   DiscretePlot[R[[ix + 1]], {ix, 0, n - 1}, ExtentSize -> 0.2, 
    AspectRatio -> 0.125, AxesOrigin -> {0, 0}, 
    Ticks -> {Range[0, n - 1], {-1, 0, 1}}, 
    PlotRange -> {{-1, n - 1 + 0.5}, 1.5 {-1, 1}}, 
    PlotStyle -> {cBluL, PointSize[0.02]}], {iy, 1}];
GraphicsColumn[vp, Frame -> All]
S = A.R;
vp = Table[
   DiscretePlot[S[[ix + 1]], {ix, 0, n - 1}, ExtentSize -> 0.2, 
    AspectRatio -> 0.125, AxesOrigin -> {0, 0}, 
    Ticks -> {Range[0, n - 1], {-1, 0, 1}}, 
    PlotRange -> {{-1, n - 1 + 0.5}, 3 {-1, 1}}, 
    PlotStyle -> {cBluL, PointSize[0.02]}], {iy, 1}];
GraphicsColumn[vp, Frame -> All]

Rd = B.S;
vp = Table[
   DiscretePlot[Rd[[ix + 1]], {ix, 0, n - 1}, ExtentSize -> 0.2, 
    AspectRatio -> 0.125, AxesOrigin -> {0, 0}, 
    Ticks -> {Range[0, n - 1], {-1, 0, 1}}, 
    PlotRange -> {{-1, n - 1 + 0.5}, 1.5 {-1, 1}}, 
    PlotStyle -> {cBluL, PointSize[0.02]}], {iy, 1}];
GraphicsColumn[vp, Frame -> All]

(*lv=Graphics[{cBluL,rplot[1/3S]}];
grXsys=tfCrdSys2Dg[LTF,e,{{0,8},{-1,1}},{{1,""},{3,""}}
,scOfst,cBluH,1];
Show[{grXsys,lv}]*)

離散フーリエ変換(DFT)

B = FourierMatrix[n];
Print[1/Sqrt[n], Sqrt[n] B // mf]
A = i[B];
GraphicsGrid[
 Table[plotCpSpc[B[[ix, iy]], 1/n^0.5], {ix, 1, n}, {iy, 1, n}], 
 Frame -> All]

GraphicsGrid[
 Table[plotCpSpc[A[[ix, iy]], 1/n^0.5], {ix, 1, n}, {iy, 1, n}], 
 Frame -> All]
(*参照信号Rの生成 Cos*)
R = Table[Cos[2 Pi 1/n t], {t, 0, n - 1}];
GraphicsRow[Table[plotCpSpc[R[[ix]], 1], {ix, 1, n}], Frame -> All]
S = A.R;
GraphicsRow[Table[plotCpSpc[S[[ix]], 1], {ix, 1, n}], Frame -> All]
Rd = B.S;
GraphicsRow[Table[plotCpSpc[Rd[[ix]], 1], {ix, 1, n}], Frame -> All]
(*参照信号Rの生成 Sin*)
R = Table[Sin[2 Pi 1/n t], {t, 0, n - 1}];
vp = Table[
   DiscretePlot[R[[ix + 1]], {ix, 0, n - 1}, ExtentSize -> 0.2, 
    AspectRatio -> 0.125, AxesOrigin -> {0, 0}, 
    Ticks -> {Range[0, n - 1], {-1, 0, 1}}, 
    PlotRange -> {{-1, n - 1 + 0.5}, 1.5 {-1, 1}}, 
    PlotStyle -> {cBluL, PointSize[0.02]}], {iy, 1}];
GraphicsColumn[vp, Frame -> All]
GraphicsRow[Table[plotCpSpc[R[[ix]], 1], {ix, 1, n}], Frame -> All]
S = A.R;
GraphicsRow[Table[plotCpSpc[S[[ix]], 1], {ix, 1, n}], Frame -> All]
Rd = B.S;
GraphicsRow[Table[plotCpSpc[Rd[[ix]], 1], {ix, 1, n}], Frame -> All]

以上

(時間が出来たら、もう少し補足・説明を追加します)

コメント

タイトルとURLをコピーしました