Haskellでスクラッチから作曲してみた

元ネタ: [Making Music with Haskell From Scratch](https://www.youtube.com/watch?v=FYTZkE5BZ-0)
（YouTube動画へのリンクです）

# Haskellでスクラッチから作曲してみた

　元ネタとして貼った動画が非常に面白かったので、自分でも真似をしてみました。
　この記事では、sin波を直接ゴニョゴニョして音を作っていきます。最終的には、簡易的な楽譜モナドを作り、楽譜に書いた通りの曲を再生して耳で聴けることを確認します。

## 最初の音

　まずは音を出せるようにします。`0`から`44800`までの数を`sin`にぶち込み、sin波を生成します。
　`44800`という数字はサンプルレートです。単位時間あたりに`44800`回`sin`から値を取り出すということです。

```Haskell
sampleRate :: Float
sampleRate = 44800.0

wave :: [Float]
wave = sin <$> [0.0 .. sampleRate]
```

　これは既に再生可能な一秒間の音です。再生してみましょう。
　一度ファイルに書き出してからFFmpegを叩くことでこれを再生しようと思います。再生にはFFmpegが必要なので、これをインストールしてあげてください。ダウンロードはこちらです -> https://ffmpeg.org/
　エンディアンとサンプルレートを揃えてあげることに注意してください。また、超高音(7018Hz, 音楽の基準となるA=440Hz)なので、なるべく音を絞って恐る恐る聞いてください。

```Haskell
save :: FilePath -> IO ()
save filePath = B.writeFile filePath $ B.toLazyByteString $ fold $ B.floatLE <$> wave

play :: FilePath -> IO ()
play filepath = callProcess "ffplay" ["-f", "f32le", "-ar", show sampleRate, "-showmode", "1", filepath]

saveAndPlay :: IO ()
saveAndPlay = do
    let filepath = "output"
    save filepath
    play filepath
```

　REPLで下のようにするか、`main`に`saveAndPlay`を入れてプログラムを実行すれば、音が出るはずです。

```Haskell
>>> saveAndPlay
```

## 任意の周波数の音を作成する

　次は、望みの音が出るようにしていきましょう。
　wave関数を少し改造して、任意の周波数の音を作れるようにします。ある周波数の波ということで、名前を`frequency`としました。

```Haskell
frequency :: Float -> [Float]
frequency hz = sin . (* step) <$> [0.0 .. sampleRate]
    where
    step = (hz * 2 * pi) / sampleRate
```

　この`frequency`は、任意の周波数の音を一秒間生成するものです。`wave`を下のように作り直しました。`440`は調律の基準になる[ラの音](https://ja.wikipedia.org/wiki/A440)です。
　次のリンクと同じ音が出ていれば、音程の調整は成功です。[A440 - tuning pitch (1-hour)](https://www.youtube.com/results?search_query=A440)（YouTubeへのリンクです）

```Haskell
>>> wave :: [Float]
>>> wave = frequency 440
>>> saveAndPlay
```

## 音量を調整する

　今までの`frequency`は私の環境では音が少し大きかったので、ボリューム調整をできるようにします。

```Haskell
type Volume = Float
type Hz = Float

frequency :: Volume -> Hz -> [Float]
frequency volume hz = (* volume) . sin . (* step) <$> [0.0 .. sampleRate]
    where
    step = (hz * 2 * pi) / sampleRate
```

## 音の長さの単位を「拍」にする

　今までの`frequency`は、1秒の波しか作れませんでした。そこで、波の長さを引数に取るようにします。

```Haskell
type Seconds = Float

frequency :: Volume -> Hz -> Seconds -> [Pulse]
frequency volume hz duration = (* volume) . sin . (* step) <$> [0.0 .. sampleRate * duration]
    where
    step = (hz * 2 * pi) / sampleRate
```

　下の`wave`を再生すれば、A4（ラ）が1秒流れた後に、1オクターブ高いA5（ラ）の音が2秒流れるはずです。
　周波数を倍にすると、聞こえる音は1オクターブ高くなります。

```Haskell
>>> wave :: [Float]
>>> wave = concat [frequency 0.5 440 1, frequency 0.5 880 2]
>>> saveAndPlay
```

　`frequency`は秒単位での音を生成していたので、`duration`の単位は秒です。ところで、音楽を作るうえで、音の長さの単位が1秒では困ります。そこで、音の長さの単位を「拍」にしたいと思います。
　まずは拍を秒に直す関数を書きます。1拍の長さ(秒数)はテンポ(BPM, Beats per minute)によって決定されるため、この関数はBPMを引数に取ります。

```Haskell
type BPM = Float
type Beats = Float

beatsToSeconds :: BPM -> Beats -> Seconds
beatsToSeconds bpm = (60.0 / bpm *)
```

　これがあれば、音の周波数と拍を受け取って音の波を返す関数を書けます。

```Haskell
note :: Volume -> BPM -> Hz -> Beats -> [Float]
note volume bpm hz = frequency volume hz . beatsToSeconds bpm
```

## 音の高さの単位を音階にする

　音階をいちいち周波数で書いていたら大変です。それに、ラ以外の音はどうすればいいのでしょうか？
　1オクターブ音が高くなると、周波数は2倍になります。A4 = 440Hzと定義しましたので、A5 = 880Hzですね。
　A4とA5が半音で12個離れていて、隣り合う半音の周波数比が等しいとすれば、音階から周波数を割り出すことが可能です（[十二平均律](https://ja.wikipedia.org/wiki/%E5%B9%B3%E5%9D%87%E5%BE%8B)）。ちなみに、この比は$\sqrt[12]{2}:1$になるらしいです。

```Haskell
type Semitones = Float

pitchStandard :: Hz
pitchStandard = 440.0

semitonesToHz :: Semitones -> Hz
semitonesToHz n = pitchStandard * (2 ** (1.0 / 12.0)) ** n

note :: Volume -> BPM -> Hz -> Beats -> [Float]
note volume bpm n = frequency volume (semitonesToHz n) . beatsToSeconds bpm
```

　基準がA4 = 440であるため、`semitonesToHz 0 == 440Hz`です。
　下のような関数を用意すれば、ピアノの白鍵を叩く感覚で音階を指定することが可能です。楽譜でいえばCメジャー/Aマイナーですね。
　例えば`a 4 == 0 :: Semitones == 440 :: Hz`という感じで鍵盤から周波数を得られます。

```Haskell
a :: Float -> Semitones
a x = 12 * x - 48.0 -- -48.0 == A0

b :: Float -> Semitones
b x = a x + 2.0 -- +2.0 == B4

c :: Float -> Semitones
c x = a x - 9.0 -- -9.0 == C4

d :: Float -> Semitones
d x = a x - 7.0 -- -7.0 == D4

e :: Float -> Semitones
e x = a x - 5.0 -- -5.0 == E4

f :: Float -> Semitones
f x = a x - 4.0 -- -4.0 == F4

g :: Float -> Semitones
g x = a x - 2.0 -- -2.0 == G4
```

　これで一通りの道具は揃いました。

## アタックとリリース

　ところで、上の実装では同じ音を続けて鳴らすと音が完全につながってしまいます。そこで、`frequency`を少し改造して、アタックとリリースを実装します。
　具体的には、音の出始めでは音量を段階的に上げ（アタック）、音の終わりでは音量を段階的に落とします（リリース）。

```Haskell
frequency :: Volume -> Hz -> Seconds -> [Pulse]
frequency volume hz duration = (* volume) <$> zipWith3 (\a b -> (a * b *)) attack release freq
    where
    step = (hz * 2 * pi) / sampleRate
    freq :: [Pulse]
    freq = sin . (* step) <$> [0.0 .. sampleRate * duration]
    attack :: [Pulse]
    attack = min 1.0 <$> [0, 0.001 ..]
    release :: [Pulse]
    release = reverse $ take (length freq) attack
```

## 楽譜モナドを作る

　あまり本質的なところではないので、コードだけ貼ります。
　`Reader`モナドでボリュームとBPMを管理して、`Writer`モナドで波を出力していくだけのモナドにしました。`noteT`アクションで音符を継ぎ足していきます。

```Haskell
type Pulse = Float

newtype ScoreT m a = ScoreT
    { unScoreT :: ReaderT Volume (ReaderT BPM (WriterT [Pulse] m)) a
    } deriving (Functor, Applicative, Monad)
type Score = ScoreT Identity

runScoreT :: ScoreT m a -> Volume -> BPM -> m (a, [Pulse])
runScoreT (ScoreT score) volume bpm = runWriterT $ runReaderT (runReaderT score volume) bpm

runScore :: Score a -> Volume -> BPM -> (a, [Pulse])
runScore = (fmap . fmap) runIdentity . runScoreT

instance MonadTrans ScoreT where
    lift = ScoreT . lift . lift . lift

askVolume :: Monad m => ScoreT m Volume
askVolume = ScoreT ask

askBPM :: Monad m => ScoreT m BPM
askBPM = ScoreT $ lift ask

tellPulse :: Monad m => [Pulse] -> ScoreT m ()
tellPulse = ScoreT . lift . lift . tell

noteT :: Monad m => Semitones -> Beats -> ScoreT m ()
noteT semitones beats = do
    v <- askVolume
    bpm <- askBPM
    tellPulse $ note v bpm semitones beats
```

## 曲を打ち込む

　残念ながら、私には音楽の教養が全く、作曲などできるはずもないので、テトリスのテーマを打ち込んでみました。

```Haskell
score :: Score ()
score = do
    noteT (e 5) 1.0
    noteT (b 4) 0.5
    noteT (c 5) 0.5
    noteT (d 5) 1.0
    noteT (c 5) 0.5
    noteT (b 4) 0.5

    noteT (a 4) 1.0
    noteT (a 4) 0.5
    noteT (c 5) 0.5
    noteT (e 5) 1.0
    noteT (d 5) 0.5
    noteT (c 5) 0.5

    noteT (b 4) 1.0
    noteT (b 4) 0.5
    noteT (c 5) 0.5
    noteT (d 5) 1.0
    noteT (e 5) 1.0

    noteT (c 5) 1.0
    noteT (a 4) 1.0
    noteT (a 4) 2.0
```

　　`wave`を次のようにしました。再生するときちんとテトリスのテーマが流れます。余談ですが、この曲にはコロベイニキという名前があるらしいです。

```Haskell
>>> wave :: [Pulse]
>>> wave = snd $ runScore score volume bpm
>>>     where
>>>     volume = 0.5
>>>     bpm = 120.0
>>> saveAndPlay
```

## 和音

　波は、単に足し合わせるだけで和音にすることができます。

```Haskell
chord :: [Pulse] -> [Pulse] -> [Pulse]
chord = zipWith (+)

chord' :: [[Pulse]] -> [Pulse]
chord' = foldr chord [0.0, 0.0 ..]

notesT :: Monad m => [Semitones] -> Beats -> ScoreT m ()
notesT semitones beats = do
    v <- askVolume
    bpm <- askBPM
    tellPulse $ chord' $ flip (note v bpm) beats <$> semitones
```

　また、和音を利用すれば、メロディーとベースのように複数のトラックを作って合成することが可能です。
　トラック合成用の関数を作りましょう。`zipWith`の特性上、この関数は短い方のトラックに長さが合わせられてしまうことに気を付けてください。

```Haskell
mergeTracks :: Monad m => ScoreT m a -> ScoreT m b -> ScoreT m (a, b)
mergeTracks t1 t2 = ScoreT $ ReaderT $ \volume -> ReaderT $ \bpm -> WriterT $ do
    (a, track1) <- runScoreT t1 volume bpm
    (b, track2) <- runScoreT t2 volume bpm
    let merged = chord track1 track2
    return ((a, b), merged)
```

　さっそくテトリスのベースを打ち込んでいきます。繰り返しを`replicateM_`で書けるのはいいですね。

```Haskell
bass :: Score ()
bass = do
    replicateM_ 4 $ do
        noteT (e 2) 0.5
        noteT (e 3) 0.5

    replicateM_ 4 $ do
        noteT (a 2) 0.5
        noteT (a 3) 0.5

    replicateM_ 2 $ do
        noteT (a 2 - 0.5) 0.5
        noteT (a 3 - 0.5) 0.5
    replicateM_ 2 $ do
        noteT (e 2) 0.5
        noteT (e 3) 0.5

    replicateM_ 4 $ do
        noteT (a 2) 0.5
        noteT (a 3) 0.5
```

　聴いてみましょう。`wave`関数を次のようにしました。

```Haskell
>>> wave :: [Pulse]
>>> wave = snd $ runScore (mergeTracks score bass) volume bpm
>>>     where
>>>     volume = 0.5
>>>     bpm = 120.0
>>> saveAndPlay
```

## 発展的な内容

　Scoreモナドには、楽譜に必要な要素をアクションという形で足していくことができます。自分でも書いていないので、ここではアイデアだけいくつか紹介します。興味があったらぜひ作ってみてください。

### 音量やテンポの変更

　範囲を指定して音量やテンポをその中でだけ変更するアクションを書くことができます。恒久的な変更は`State`モナドを使わないとできませんね。

```Haskell
localVolume :: Monad m => (Volume -> Volume) -> ScoreT m a -> ScoreT m a
localVolume mapper = ScoreT . local mapper . unScoreT

localBPM :: Monad m => (BPM -> BPM) -> ScoreT m a -> ScoreT m a
localBPM mapper = ScoreT . ReaderT . fmap (local mapper) . runReaderT . unScoreT
```

### キー（調）の指定

　モナドスタックにキーの情報を追加すれば、楽譜にキーを指定することができます。何もしなければCメジャー/Aマイナーです。

### 音楽記号の再現

　休符、フラット/シャープ/ナチュラル、オクターブ記号等、音符に影響を与える記号から、繰り返し記号や強弱記号等の演奏記号に至るまで、大抵のものは素直に実装することができると思います。

## まとめ

　非常に興味深かったし、やっていて楽しかったです。みなさんも動画を見ながら作ってはいかがでしょうか。
　音楽については全くの素人ですので、間違ったことを言っていたらごめんなさい。

## Credit

　この記事は、[Tsoding](https://www.youtube.com/channel/UCEbYhDd6c6vngsF5PQpFVWg)さんの許可のもと、元ネタである[Making Music with Haskell From Scratch](https://www.youtube.com/watch?v=FYTZkE5BZ-0)の内容を基にして作成しました。
　快く記事作成の許可をくださったTsodingさん、ありがとうございました。

This article is based on the video, [Making Music with Haskell From Scratch](https://www.youtube.com/watch?v=FYTZkE5BZ-0). Thank you [Tsoding](https://www.youtube.com/channel/UCEbYhDd6c6vngsF5PQpFVWg) for the quite interesting video and readily consent!

## コード全文

　おまけです。動かなくて困ったときはこれを見たりコピペしてみてください。

```Haskell
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
module MonadComposer where

import Control.Monad.Reader
import Control.Monad.Writer
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Builder as B
import Data.Foldable (fold)
import Data.Functor.Identity
import System.Process (callProcess)

-- basic tools
type Seconds = Float
type Hz = Float
type Pulse = Float
type Semitones = Float
type Beats = Float
type BPM = Float
type Volume = Float

pitchStandard :: Hz
pitchStandard = 440.0

sampleRate :: Hz
sampleRate = 44100.0

frequency :: Volume -> Hz -> Seconds -> [Pulse]
frequency volume hz duration = (* volume) <$> zipWith3 (\a b -> (a * b *)) attack release freq
    where
    step = (hz * 2 * pi) / sampleRate
    freq :: [Pulse]
    freq = sin . (* step) <$> [0.0 .. sampleRate * duration]
    attack :: [Pulse]
    attack = min 1.0 <$> [0, 0.001 ..]
    release :: [Pulse]
    release = reverse $ take (length freq) attack

beatsToSeconds :: BPM -> Beats -> Seconds
beatsToSeconds bpm = (60.0 / bpm *)

semitonesToHz :: Semitones -> Hz
semitonesToHz n = pitchStandard * (2 ** (1.0 / 12.0)) ** n

note :: Volume -> BPM -> Semitones -> Beats -> [Pulse]
note volume bpm n = frequency volume (semitonesToHz n) . beatsToSeconds bpm

chord :: [Pulse] -> [Pulse] -> [Pulse]
chord = zipWith (+)

chord' :: [[Pulse]] -> [Pulse]
chord' = foldr chord [0.0, 0.0 ..]

-- ScoreT monad and its actions
newtype ScoreT m a = ScoreT
    { unScoreT :: ReaderT Volume (ReaderT BPM (WriterT [Pulse] m)) a
    } deriving (Functor, Applicative, Monad)
type Score = ScoreT Identity

runScoreT :: ScoreT m a -> Volume -> BPM -> m (a, [Pulse])
runScoreT (ScoreT score) volume bpm = runWriterT $ runReaderT (runReaderT score volume) bpm

runScore :: Score a -> Volume -> BPM -> (a, [Pulse])
runScore = (fmap . fmap) runIdentity . runScoreT

instance MonadTrans ScoreT where
    lift = ScoreT . lift . lift . lift

askVolume :: Monad m => ScoreT m Volume
askVolume = ScoreT ask

askBPM :: Monad m => ScoreT m BPM
askBPM = ScoreT $ lift ask

tellPulse :: Monad m => [Pulse] -> ScoreT m ()
tellPulse = ScoreT . lift . lift . tell

noteT :: Monad m => Semitones -> Beats -> ScoreT m ()
noteT semitones beats = do
    v <- askVolume
    bpm <- askBPM
    tellPulse $ note v bpm semitones beats

notesT :: Monad m => [Semitones] -> Beats -> ScoreT m ()
notesT semitones beats = do
    v <- askVolume
    bpm <- askBPM
    tellPulse $ chord' $ flip (note v bpm) beats <$> semitones

localVolume :: Monad m => (Volume -> Volume) -> ScoreT m a -> ScoreT m a
localVolume mapper = ScoreT . local mapper . unScoreT

localBPM :: Monad m => (BPM -> BPM) -> ScoreT m a -> ScoreT m a
localBPM mapper = ScoreT . ReaderT . fmap (local mapper) . runReaderT . unScoreT

mergeTracks :: Monad m => ScoreT m () -> ScoreT m () -> ScoreT m ()
mergeTracks t1 t2 = ScoreT $ ReaderT $ \volume -> ReaderT $ \bpm -> WriterT $ do
    (_, track1) <- runScoreT t1 volume bpm
    (_, track2) <- runScoreT t2 volume bpm
    let merged = chord track1 track2
    return ((), merged)

-- Labeled semitones, C major/A minor
a :: Float -> Semitones
a x = 12 * x - 48.0 -- -48.0 == A0

b :: Float -> Semitones
b x = a x + 2.0 -- +2.0 == B4

c :: Float -> Semitones
c x = a x - 9.0 -- -9.0 == C4

d :: Float -> Semitones
d x = a x - 7.0 -- -7.0 == D4

e :: Float -> Semitones
e x = a x - 5.0 -- -5.0 == E4

f :: Float -> Semitones
f x = a x - 4.0 -- -4.0 == F4

g :: Float -> Semitones
g x = a x - 2.0 -- -2.0 == G4

-- Theme of Tetris
melody :: Score ()
melody = do
    noteT (e 5) 1.0
    noteT (b 4) 0.5
    noteT (c 5) 0.5
    noteT (d 5) 1.0
    noteT (c 5) 0.5
    noteT (b 4) 0.5

    noteT (a 4) 1.0
    noteT (a 4) 0.5
    noteT (c 5) 0.5
    noteT (e 5) 1.0
    noteT (d 5) 0.5
    noteT (c 5) 0.5

    noteT (b 4) 1.0
    noteT (b 4) 0.5
    noteT (c 5) 0.5
    noteT (d 5) 1.0
    noteT (e 5) 1.0

    noteT (c 5) 1.0
    noteT (a 4) 1.0
    noteT (a 4) 2.0

bass :: Score ()
bass = do
    replicateM_ 4 $ do
        noteT (e 2) 0.5
        noteT (e 3) 0.5

    replicateM_ 4 $ do
        noteT (a 2) 0.5
        noteT (a 3) 0.5

    replicateM_ 2 $ do
        noteT (a 2 - 0.5) 0.5
        noteT (a 3 - 0.5) 0.5
    replicateM_ 2 $ do
        noteT (e 2) 0.5
        noteT (e 3) 0.5

    replicateM_ 4 $ do
        noteT (a 2) 0.5
        noteT (a 3) 0.5

-- Wave to play
wave :: [Pulse]
wave = snd $ runScore (mergeTracks melody bass) volume bpm
    where
    volume = 0.5
    bpm = 120.0

-- other utiliyies
outputFilePath :: FilePath
outputFilePath = "output"

save :: FilePath -> IO ()
save filePath = B.writeFile filePath $ B.toLazyByteString $ fold $ B.floatLE <$> wave

play :: FilePath -> IO ()
play filepath = callProcess "ffplay" ["-f", "f32le", "-ar", show sampleRate, "-showmode", "1", filepath]

saveAndPlay :: IO ()
saveAndPlay = do
    save outputFilePath
    play outputFilePath
```