{-# LANGUAGE FlexibleContexts #-}
import Diagrams.Prelude
import Diagrams.Backend.Cairo (Cairo)
import Control.Monad
type Dia = QDiagram Cairo V2 Double Any
import Data.Ratio
keyboard :: Dia
keyboard = hcat [ rect 1 8 & fc (c k) & opacity 0.1
| k <- " ❚ ❚ ❚ ❚ ❚ " ]
where c ' ' = white
c '❚' = black
type Freq = Double -- relative to C
data AccidentalChoice = PreferSharps | PreferFlats
labelFreq :: AccidentalChoice -> Freq -> String
labelFreq accCh ν = noteNames!!s
++ (if ε<0 then id else ('+':)) (show $ round ε) ++ "ct"
where lν = logBase 2 ν
s = round $ lν * 12
ε = lν*1200 - fromIntegral s*100
noteNames = case accCh of
PreferSharps -> words "C C♯ D D♯ E F F♯ G G♯ A A♯ B"
PreferFlats -> words "C D♭ D E♭ E F G♭ G A♭ A B♭ B"
showRatio :: Rational -> String
showRatio q = map toSup (show $ numerator q) ++ "⁄" ++ map toSub (show $ denominator q)
where toSup = ("⁰¹²³⁴⁵⁶⁷⁸⁹"!!) . subtract (fromEnum '0') . fromEnum
toSub = ("₀₁₂₃₄₅₆₇₈₉"!!) . subtract (fromEnum '0') . fromEnum
constructNote :: AccidentalChoice -> [Rational] -> Dia
constructNote accCh = go 1
where go _ [] = mempty
go ν₀ (qν:qνs)
= (fromVertices [ p₀^&1, pn^&0 ] # opacity 0.5
<> circle 0.1 # moveTo (pn^&0)
<> text (showRatio qν) # scale 0.5 # moveTo ((p₀+pn)/2^& 0.2)
<> text (labelFreq accCh νn) # scale 0.5 # moveTo (pn^& 0.5) )
===
go νn qνs
where νn = ν₀ * realToFrac qν
[p₀,pn] = (*12) . logBase 2 <$> [ν₀,νn]
onKeyboard :: Dia -> Dia
onKeyboard pth
= strutX 2 ||| (pth # alignT <> keyboard # alignT) ||| strutX 2
onKeyboard $ constructNote PreferSharps [3/2, 3/4, 3/2, 3/4, 3/2, 3/4, 3/4]
onKeyboard $ constructNote PreferFlats [4/3, 4/3, 2/3, 4/3, 2/3]
onKeyboard $ constructNote PreferSharps [3/2, 3/4, 5/4, 3/4]
Alternative:
onKeyboard $ constructNote PreferSharps [4/3, 5/4, 5/8]
onKeyboard $ constructNote PreferFlats [4/3, 4/5]