元ネタ: Making Music with Haskell From Scratch
（YouTube動画へのリンクです）

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

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

最初の音

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

sampleRate :: Float
sampleRate = 44800.0

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

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

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を入れてプログラムを実行すれば、音が出るはずです。

>>> saveAndPlay

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

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

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

　このfrequencyは、任意の周波数の音を一秒間生成するものです。waveを下のように作り直しました。440は調律の基準になるラの音です。
　次のリンクと同じ音が出ていれば、音程の調整は成功です。A440 - tuning pitch (1-hour)（YouTubeへのリンクです）

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

音量を調整する

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

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秒の波しか作れませんでした。そこで、波の長さを引数に取るようにします。

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オクターブ高くなります。

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

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

type BPM = Float
type Beats = Float

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

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

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

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

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

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という感じで鍵盤から周波数を得られます。

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を少し改造して、アタックとリリースを実装します。
　具体的には、音の出始めでは音量を段階的に上げ（アタック）、音の終わりでは音量を段階的に落とします（リリース）。

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アクションで音符を継ぎ足していきます。

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

曲を打ち込む

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

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

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

和音

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

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の特性上、この関数は短い方のトラックに長さが合わせられてしまうことに気を付けてください。

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_で書けるのはいいですね。

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関数を次のようにしました。

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

発展的な内容

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

音量やテンポの変更

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

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さんの許可のもと、元ネタであるMaking Music with Haskell From Scratchの内容を基にして作成しました。
　快く記事作成の許可をくださったTsodingさん、ありがとうございました。

This article is based on the video, Making Music with Haskell From Scratch. Thank you Tsoding for the quite interesting video and readily consent!

コード全文

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

{-# 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