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

onKeyboard $ constructNote PreferSharps [4/3, 5/4, 5/8]

onKeyboard $ constructNote PreferFlats [4/3, 4/5]