シェパードトーン(無限音階)の作成
Shepard Tone (Infinite Musical Scale)

2003/6/7 平野拓一（東京工業大学）
Takuichi Hirano (Tokyo Institute of Technology)

R.N. Shepard によって提案された無限に音が高くなり続けるように感じる無限音階を作る。
スペクトルの包絡線をつりがね状にする必要があるが、実際どのような関数を使えばよいか文献には書かれていなかったため、２つの関数を試した。１つは正弦波の一部（の冪乗）を用いるものであり、もう一つは正規分布（ガウス分布）を用いた。正弦波の一部を用いる方法の方はうまくいった。

周波数を求める関数（平均律）

[Input]
オクターブ
音 (c,c#,d,d#,e,f,f#,g,g#,a,a#,b)

<< Miscellaneous`Audio`;
ABCToNumOfHalfTone[ABC_] := 
          Which[
ABC == "C"  ||  ABC == "c", 
            0, 
ABC == "C#"  ||  ABC == "c#", 
            1, 
ABC == "D"  ||  ABC == "d", 
            2, 
ABC == "D#"  ||  ABC == "d#", 
            3, 
ABC == "E"  ||  ABC == "e", 
            4, 
ABC == "F"  ||  ABC == "f", 
            5, 
ABC == "F#"  ||  ABC == "f#", 
            6, 
ABC == "G"  ||  ABC == "g", 
            7, 
ABC == "G#"  ||  ABC == "g#", 
            8, 
ABC == "A"  ||  ABC == "a", 
            9, 
ABC == "A#"  ||  ABC == "a#", 
            10, 
ABC == "B"  ||  ABC == "b", 
            11];

FreqTemperament[Octave_, ABC_]:=Module[{r = (2^(1/12))},
  
ABCNum = 
              ABCToNumOfHalfTone[
                ABC]; 
(440*(r^((Octave - 4)*12)))*
                (r^(ABCNum - 9))  // N
];
FreqTemperament[OctABCList_List] := 
        Map[(FreqTemperament[#[[1]], #[[2]]] &), 
          OctABCList];

Sine Weighting

スペクトル包絡線を固定し、ドレミ・・・にと音を出すときは基本周波数を上げていく。そのとき、高次の倍音はある場所にしきいを設けてはみ出るならば打ち切る（重みを０にする）方がよい。そうしないと音に角が出来て違った音色に聞こえてしまう。

<< Graphics`Graphics`;
n = 10;
r = (2^(1/12));
LevLow = 1;
sinList[cent_, ord_, t_] := 
        N[ Table[{(2^(i - 1)), 
              If[i + t - n < 
                  0, (LevLow + (((Cos[π*((i - 1 + t)/(n - 1) - cent)]))^ord)), 0]}, {i, 1, n}] ];

    
lis = sinList[0.5, 2, 0];
LogLinearListPlot[
      lis, 
Epilog -> {AbsoluteThickness[2], 
          RGBColor[1, 0, 0], 
          Map[(Line[{{Log[10, #[[1]]], 
                      0}, {Log[10, #[[1]]], #[[2]]}}] &), 
            lis]}, 
PlotRange -> {0, 
          Automatic}, 
PlotJoined -> 
        True, 
PlotStyle -> {Dashing[{0.05, 0.05}], 
          AbsoluteThickness[1], 
          RGBColor[0, 0, 
            0]}, 
PlotLabel -> "Overtone \
Spectrum", 
Frame -> 
        True, 
FrameLabel -> {"Relative \
frequency", "Relative amplitude", "", ""}]

実際にはスペクトル包絡線は固定しないで、より倍音の変化を強調するようにした。Log[]の前に2がかかっているが、もしスペクトル包絡線を固定するならばこれを1にすべきだが、2として倍音変化をより強調した。

freq[1] = 
        FreqTemperament[-2, "C"];
freq[2] = 
        FreqTemperament[-2, "D"];
freq[3] = 
        FreqTemperament[-2, "E"];
freq[4] = 
        FreqTemperament[-2, "F"];
freq[5] = 
        FreqTemperament[-2, "G"];
freq[6] = 
        FreqTemperament[-2, "A"];
freq[7] = 
        FreqTemperament[-2, "B"];

    
wvLis = 
      Table[ListWaveform[
          sinList[0.5, 2, 2*Log[2, freq[Mod[(i - 1), 7] + 1]/freq[1]]], 
          freq[Mod[(i - 1), 7] + 1], 0.5, SampleRate -> 44100, 
          PlayRange -> All], {i, 1, 14}]

Show[wvLis]

Sine Weighting

上の場合で、スペクトルの相対的な形は同じにした。従って、この場合は無限音階に感じないはず。

<< Graphics`Graphics`;
n = 10;
r = (2^(1/12));
LevLow = 1;
sinList[cent_, ord_, t_] := 
        N[ Table[{(2^(i - 1)), 
              If[i + t - n < 
                  0, (LevLow + (((Cos[π*((i - 1 + t)/(n - 1) - cent)]))^ord)), 0]}, {i, 1, n}] ];

    
lis = sinList[0.5, 2, 0];
LogLinearListPlot[
      lis, 
Epilog -> {AbsoluteThickness[2], 
          RGBColor[1, 0, 0], 
          Map[(Line[{{Log[10, #[[1]]], 
                      0}, {Log[10, #[[1]]], #[[2]]}}] &), 
            lis]}, 
PlotRange -> {0, 
          Automatic}, 
PlotJoined -> 
        True, 
PlotStyle -> {Dashing[{0.05, 0.05}], 
          AbsoluteThickness[1], 
          RGBColor[0, 0, 
            0]}, 
PlotLabel -> "Overtone \
Spectrum", 
Frame -> 
        True, 
FrameLabel -> {"Normalized \
frequency", "Amplitude", "", ""}]

freq[1] = 
        FreqTemperament[-2, "C"];
freq[2] = 
        FreqTemperament[-2, "D"];
freq[3] = 
        FreqTemperament[-2, "E"];
freq[4] = 
        FreqTemperament[-2, "F"];
freq[5] = 
        FreqTemperament[-2, "G"];
freq[6] = 
        FreqTemperament[-2, "A"];
freq[7] = 
        FreqTemperament[-2, "B"];

    
wvLis = 
      Table[ListWaveform[sinList[0.5, 2, 0], freq[Mod[(i - 1), 7] + 1], 
          0.5, SampleRate -> 44100, PlayRange -> All], {i, 1, 
          14}]

Show[wvLis]

Sine Weighting 2

この場合うまくいかなかった。高音の倍音は減衰させないと（打ち切らないと）うまくいかない？

<< Graphics`Graphics`;
n = 10;
r = (2^(1/12));
LevLow = 0.5;
sinList[cent_, ord_, t_] := 
        N[ Table[{(2^(i - 1)), 
              If[-0.5 ≤ ((i - 1 + t)/(n - 1) - 
                      cent) ≤ 
                  0.5, (LevLow + (((Cos[π*((i - 1 + t)/(n - 1) - cent)]))^ord)), LevLow]}, {i, 1, n}] ];

    
lis = sinList[0.5, 2, 1];
LogLinearListPlot[
      lis, 
Epilog -> {AbsoluteThickness[2], 
          RGBColor[1, 0, 0], 
          Map[(Line[{{Log[10, #[[1]]], 
                      0}, {Log[10, #[[1]]], #[[2]]}}] &), 
            lis]}, 
PlotRange -> {0, 
          Automatic}, 
PlotJoined -> 
        True, 
PlotStyle -> {Dashing[{0.05, 0.05}], 
          AbsoluteThickness[1], 
          RGBColor[0, 0, 
            0]}, 
PlotLabel -> "Overtone \
Spectrum", 
Frame -> 
        True, 
FrameLabel -> {"Normalized \
frequency", "Amplitude", "", ""}]

freq[1] = 
        FreqTemperament[-2, "C"];
freq[2] = 
        FreqTemperament[-2, "D"];
freq[3] = 
        FreqTemperament[-2, "E"];
freq[4] = 
        FreqTemperament[-2, "F"];
freq[5] = 
        FreqTemperament[-2, "G"];
freq[6] = 
        FreqTemperament[-2, "A"];
freq[7] = 
        FreqTemperament[-2, "B"];

    
wvLis = 
      Table[ListWaveform[
          sinList[0.5, 2, 2*Log[2, freq[Mod[(i - 1), 7] + 1]/freq[1]]], 
          freq[Mod[(i - 1), 7] + 1], 0.5, SampleRate -> 44100, 
          PlayRange -> All], {i, 1, 14}]

Show[wvLis]

Normal Distribution Weighting

試してはみたけど、結局正弦波を採用した。

<< Graphics`Graphics`;
n = 10;
r = (2^(1/12));
NormalDist[μ_, σ_, x_] := 
        (1/((Sqrt[2*π])*σ))*
          Exp[-((((x - μ))^2)/(2*(σ^2)))];
LevLow = 0.75;
normList[μ_, σ_, t_] := 
        N[ Table[{(2^(i - 1)), (((Sqrt[2*π])*σ)*
                      NormalDist[μ, σ, ((i + t)/n)] + 
                    LevLow)/(1 + LevLow)}, {i, 1, 
              n}] ];

    
σ = 0.2;
μ = 0.6;
lis = normList[μ, σ, 0];
\(LogLinearListPlot[
      lis, 
Epilog -> {AbsoluteThickness[2], 
          RGBColor[1, 0, 0], 
          Map[\((Line[{{Log[10, #[\([1]\)]], 
                      0}, {Log[10, #[\([1]\)]], #[\([2]\)]}}] &)\), 
            lis]}, 
PlotRange -> {0, 
          Automatic}, 
PlotJoined -> 
        True, 
PlotLabel -> "Overtone Spectrum", 
PlotStyle -> {Dashing[{0.05, 0.05}], 
          AbsoluteThickness[1], 
          RGBColor[0, 0, 0]}, 
Frame -> 
        True, 
FrameLabel -> {"Normalized frequency", "Amplitude", "", ""}]\)

freq[1] = 
        FreqTemperament[-2, "C"];
freq[2] = 
        FreqTemperament[-2, "D"];
freq[3] = 
        FreqTemperament[-2, "E"];
freq[4] = 
        FreqTemperament[-2, "F"];
freq[5] = 
        FreqTemperament[-2, "G"];
freq[6] = 
        FreqTemperament[-2, "A"];
freq[7] = 
        FreqTemperament[-2, "B"];

    
wvLis = 
      Table[ListWaveform[
          normList[0.6, 0.2, 
            2*Log[2, freq[Mod[(i - 1), 7] + 1]/freq[1]]], 
          freq[Mod[(i - 1), 7] + 1], 0.5, SampleRate -> 44100, 
          PlayRange -> All], {i, 1, 14}]

Show[wvLis]

Constant Weighting

スペクトル包絡線は定数にした。
人間の可聴域いっぱいに倍音スペクトルを取っている。ラウドネス曲線の人間の聴覚特性を考えれば自然にスペクトルの中域で重みを大きくした効果があるが、それにしては、錯覚の効果が大きいように思える。

<< Graphics`Graphics`;
n = 12;
lis = 
        N[ Table[{(2^(i - 1)), 1}, {i, 1, 
              n}] ];
LogLinearListPlot[
      lis, 
Epilog -> {AbsoluteThickness[2], 
          RGBColor[1, 0, 0], 
          Map[(Line[{{Log[10, #[[1]]], 
                      0}, {Log[10, #[[1]]], #[[2]]}}] &), 
            lis]}, 
PlotRange -> {0, 
          Automatic}, 
PlotJoined -> 
        True, 
PlotStyle -> {Dashing[{0.05, 0.05}], 
          AbsoluteThickness[1], 
          RGBColor[0, 0, 
            0]}, 
PlotLabel -> "Overtone \
Spectrum", 
Frame -> 
        True, 
FrameLabel -> {"Relative \
frequency", "Relative amplitude", "", ""}]

freq[1] = 
        FreqTemperament[-2, "C"];
freq[2] = 
        FreqTemperament[-2, "D"];
freq[3] = 
        FreqTemperament[-2, "E"];
freq[4] = 
        FreqTemperament[-2, "F"];
freq[5] = 
        FreqTemperament[-2, "G"];
freq[6] = 
        FreqTemperament[-2, "A"];
freq[7] = 
        FreqTemperament[-2, "B"];

    
wvLis = 
      Table[ListWaveform[lis, freq[Mod[(i - 1), 7] + 1], 0.5, 
          SampleRate -> 44100, PlayRange -> All], {i, 1, 
          14}]

Show[wvLis]

Single Frequency

単一周波数。倍音の細工がないからどう聞いても音が下がるように感じてしまう。

freq[1] = FreqTemperament[5, "C"];
freq[2] = FreqTemperament[5, "D"];
freq[3] = FreqTemperament[5, "E"];
freq[4] = FreqTemperament[5, "F"];
freq[5] = FreqTemperament[5, "G"];
freq[6] = FreqTemperament[5, "A"];
freq[7] = FreqTemperament[5, "B"];

    
wvLis = 
      Table[ListWaveform[{{1, 1}}, freq[Mod[(i - 1), 7] + 1], 0.5, 
          SampleRate -> 44100, PlayRange -> All], {i, 1, 
          14}]

Show[wvLis]