module Music.Theory.Tuning.ET where
import Data.List
import Data.List.Split
import Data.Ratio
import Text.Printf
import qualified Music.Theory.List as T
import Music.Theory.Pitch
import Music.Theory.Pitch.Note
import Music.Theory.Pitch.Spelling.Table
import Music.Theory.Tuning
octpc_to_pitch_cps_f0 :: (Floating n) => n -> OctPC -> (Pitch,n)
octpc_to_pitch_cps_f0 f0 x = (octpc_to_pitch pc_spell_ks x,octpc_to_cps_f0 f0 x)
octpc_to_pitch_cps :: (Floating n) => OctPC -> (Pitch,n)
octpc_to_pitch_cps = octpc_to_pitch_cps_f0 440
tbl_12et_f0 :: Double -> [(Pitch,Double)]
tbl_12et_f0 f0 =
let z = [(o,pc) | o <- [0..10], pc <- [0..11]]
in map (octpc_to_pitch_cps_f0 f0) z
tbl_12et :: [(Pitch,Double)]
tbl_12et = tbl_12et_f0 440
tbl_24et_f0 :: Double -> [(Pitch,Double)]
tbl_24et_f0 f0 =
let f x = let p = fmidi_to_pitch_err pc_spell_ks x
p' = pitch_rewrite_threequarter_alteration p
in (p',fmidi_to_cps_f0 f0 x)
in map f [12,12.5 .. 143.5]
tbl_24et :: [(Pitch,Double)]
tbl_24et = tbl_24et_f0 440
bounds_et_table :: Ord s => [(t,s)] -> s -> Maybe ((t,s),(t,s))
bounds_et_table = T.find_bounds True (compare . snd)
bounds_12et_tone :: Double -> Maybe ((Pitch,Double),(Pitch,Double))
bounds_12et_tone = bounds_et_table tbl_12et
type HS_R p = (Double,p,Double,Double,Cents)
ndp :: Int -> Double -> String
ndp = printf "%.*f"
hs_r_pp :: (p -> String) -> Int -> HS_R p -> [String]
hs_r_pp pp n (f,p,pf,fd,c) =
let dp = ndp n
in [dp f
,pp p
,dp pf
,dp fd
,dp c]
hs_r_pitch_pp :: Int -> HS_R Pitch -> [String]
hs_r_pitch_pp = hs_r_pp pitch_pp
nearest_et_table_tone :: [(p,Double)] -> Double -> HS_R p
nearest_et_table_tone tbl f =
case bounds_et_table tbl f of
Nothing -> error "nearest_et_table_tone: no bounds?"
Just ((lp,lf),(rp,rf)) ->
let ld = f lf
rd = f rf
in if abs ld < abs rd
then (f,lp,lf,ld,fratio_to_cents (f/lf))
else (f,rp,rf,rd,fratio_to_cents (f/rf))
nearest_12et_tone :: Double -> HS_R Pitch
nearest_12et_tone = nearest_et_table_tone tbl_12et
nearest_24et_tone :: Double -> HS_R Pitch
nearest_24et_tone = nearest_et_table_tone tbl_24et
alteration_72et_monzo :: Integral n => n -> String
alteration_72et_monzo n =
let spl = splitOn ","
asc = spl ",+,>,^,#<,#-,#,#+,#>,#^"
dsc = spl ",-,<,v,b>,b+,b,b-,b<,bv"
in case compare n 0 of
LT -> genericIndex dsc ( n)
EQ -> ""
GT -> genericIndex asc n
pitch_72et :: (Int,Int) -> (Pitch_R,Double)
pitch_72et (x,n) =
let p = midi_to_pitch pc_spell_ks x
t = note p
a = alteration p
(t',n') = case a of
Flat -> if n < (3) then (pred t,n + 6) else (t,n 6)
Natural -> (t,n)
Sharp -> if n > 3 then (succ t,n 6) else (t,n + 6)
_ -> error "pitch_72et: alteration?"
a' = alteration_72et_monzo n'
x' = fromIntegral x + (fromIntegral n / 6)
r = (Pitch_R t' (fromIntegral n' % 12,a') (octave p),fmidi_to_cps x')
r' = if n > 3
then pitch_72et (x + 1,n 6)
else if n < (3)
then pitch_72et (x 1,n + 6)
else r
in case a of
Natural -> r'
_ -> r
tbl_72et :: [(Pitch_R,Double)]
tbl_72et =
let f n = map pitch_72et (zip (replicate 6 n) [0..5])
in concatMap f [12 .. 143]
nearest_72et_tone :: Double -> HS_R Pitch_R
nearest_72et_tone = nearest_et_table_tone tbl_72et
type Pitch_Detune = (Pitch,Cents)
hsr_to_pitch_detune :: HS_R Pitch -> Pitch_Detune
hsr_to_pitch_detune (_,p,_,_,c) = (p,c)
nearest_pitch_detune_12et :: Double -> Pitch_Detune
nearest_pitch_detune_12et = hsr_to_pitch_detune . nearest_12et_tone
nearest_pitch_detune_24et :: Double -> Pitch_Detune
nearest_pitch_detune_24et = hsr_to_pitch_detune . nearest_24et_tone
ratio_to_pitch_detune :: (Double -> HS_R Pitch) -> OctPC -> Rational -> Pitch_Detune
ratio_to_pitch_detune near_f f0 r =
let f = octpc_to_cps f0 * realToFrac r
(_,p,_,_,c) = near_f f
in (p,c)
pitch_detune_to_cps :: Floating n => Pitch_Detune -> n
pitch_detune_to_cps (p,d) = cps_shift_cents (pitch_to_cps p) (realToFrac d)
ratio_to_pitch_detune_12et :: OctPC -> Rational -> Pitch_Detune
ratio_to_pitch_detune_12et = ratio_to_pitch_detune nearest_12et_tone
ratio_to_pitch_detune_24et :: OctPC -> Rational -> Pitch_Detune
ratio_to_pitch_detune_24et = ratio_to_pitch_detune nearest_24et_tone
pitch_detune_in_octave_nearest :: Pitch -> Pitch_Detune -> Pitch_Detune
pitch_detune_in_octave_nearest p1 (p2,d2) = (pitch_in_octave_nearest p1 p2,d2)
pitch_detune_md :: Pitch_Detune -> String
pitch_detune_md (p,c) = pitch_pp p ++ cents_diff_md (round c :: Integer)
pitch_detune_html :: Pitch_Detune -> String
pitch_detune_html (p,c) = pitch_pp p ++ cents_diff_html (round c :: Integer)
pitch_class_detune_md :: Pitch_Detune -> String
pitch_class_detune_md (p,c) = pitch_class_pp p ++ cents_diff_md (round c :: Integer)
pitch_class_detune_html :: Pitch_Detune -> String
pitch_class_detune_html (p,c) = pitch_class_pp p ++ cents_diff_html (round c :: Integer)