module Music.Theory.Tuning where
import Data.Fixed
import Data.List
import Data.Maybe
import Data.Ratio
import Safe
import qualified Music.Theory.Either as T
import qualified Music.Theory.List as T
import qualified Music.Theory.Pitch as T
type Approximate_Ratio = Double
type Cents = Double
data Tuning = Tuning {ratios_or_cents :: Either [Rational] [Cents]
,octave_ratio :: Rational}
deriving (Eq,Show)
divisions :: Tuning -> Int
divisions = either length length . ratios_or_cents
ratios :: Tuning -> Maybe [Rational]
ratios = T.fromLeft . ratios_or_cents
ratios_err :: Tuning -> [Rational]
ratios_err = fromMaybe (error "ratios") . ratios
cents :: Tuning -> [Cents]
cents = either (map ratio_to_cents) id . ratios_or_cents
cents_i :: Integral i => Tuning -> [i]
cents_i = map round . cents
cents_octave :: Tuning -> [Cents]
cents_octave t = cents t ++ [ratio_to_cents (octave_ratio t)]
cents_to_ratio :: Floating a => a -> a
cents_to_ratio n = 2 ** (n / 1200)
approximate_ratios :: Tuning -> [Approximate_Ratio]
approximate_ratios =
either (map approximate_ratio) (map cents_to_ratio) .
ratios_or_cents
approximate_ratios_cyclic :: Tuning -> [Approximate_Ratio]
approximate_ratios_cyclic t =
let r = approximate_ratios t
m = realToFrac (octave_ratio t)
g = iterate (* m) 1
f n = map (* n) r
in concatMap f g
reconstructed_ratios :: Double -> Tuning -> Maybe [Rational]
reconstructed_ratios epsilon =
fmap (map (reconstructed_ratio epsilon)) .
T.fromRight .
ratios_or_cents
fratio_to_cents :: (Real r,Floating n) => r -> n
fratio_to_cents = (1200 *) . logBase 2 . realToFrac
approximate_ratio_to_cents :: Approximate_Ratio -> Cents
approximate_ratio_to_cents = fratio_to_cents
approximate_ratio :: Rational -> Approximate_Ratio
approximate_ratio = fromRational
ratio_to_cents :: Rational -> Cents
ratio_to_cents = approximate_ratio_to_cents . approximate_ratio
reconstructed_ratio :: Double -> Cents -> Rational
reconstructed_ratio epsilon c = approxRational (cents_to_ratio c) epsilon
cps_shift_cents :: Floating a => a -> a -> a
cps_shift_cents f = (* f) . cents_to_ratio
cps_difference_cents :: (Real r,Fractional r,Floating n) => r -> r -> n
cps_difference_cents p q = fratio_to_cents (q / p)
syntonic_comma :: Rational
syntonic_comma = 81 % 80
pythagorean_comma :: Rational
pythagorean_comma = 531441 / 524288
mercators_comma :: Rational
mercators_comma = 19383245667680019896796723 / 19342813113834066795298816
nth_root :: (Floating a,Eq a) => a -> a -> a
nth_root n x =
let f (_,x0) = (x0, ((n1)*x0+x/x0**(n1))/n)
e = uncurry (==)
in fst (until e f (x, x/n))
twelve_tone_equal_temperament_comma :: (Floating a,Eq a) => a
twelve_tone_equal_temperament_comma = 12 `nth_root` 2
equal_temperament :: Integral n => n -> Tuning
equal_temperament n =
let c = genericTake n [0,1200 / fromIntegral n ..]
in Tuning (Right c) 2
equal_temperament_12 :: Tuning
equal_temperament_12 = equal_temperament (12::Int)
equal_temperament_19 :: Tuning
equal_temperament_19 = equal_temperament (19::Int)
equal_temperament_31 :: Tuning
equal_temperament_31 = equal_temperament (31::Int)
equal_temperament_53 :: Tuning
equal_temperament_53 = equal_temperament (53::Int)
equal_temperament_72 :: Tuning
equal_temperament_72 = equal_temperament (72::Int)
fold_cps_to_octave_of :: (Ord a, Fractional a) => a -> a -> a
fold_cps_to_octave_of p =
let f q = if q > p * 2 then f (q / 2) else if q < p then f (q * 2) else q
in f
harmonic_series_cps :: (Num t, Enum t) => t -> [t]
harmonic_series_cps n = [n,n * 2 ..]
harmonic_series_cps_n :: (Num a, Enum a) => Int -> a -> [a]
harmonic_series_cps_n n = take n . harmonic_series_cps
subharmonic_series_cps :: (Fractional t,Enum t) => t -> [t]
subharmonic_series_cps n = map (* n) (map recip [1..])
subharmonic_series_cps_n :: (Fractional t,Enum t) => Int -> t -> [t]
subharmonic_series_cps_n n = take n . subharmonic_series_cps
partial :: (Num a, Enum a) => a -> Int -> a
partial f1 k = harmonic_series_cps f1 `at` (k 1)
fold_ratio_to_octave :: Integral i => Ratio i -> Ratio i
fold_ratio_to_octave n =
if n >= 2
then fold_ratio_to_octave (n / 2)
else if n < 1
then fold_ratio_to_octave (n * 2)
else n
ratio_interval_class :: Integral i => Ratio i -> Ratio i
ratio_interval_class i =
let f = fold_ratio_to_octave
in max (f i) (f (recip i))
harmonic_series_cps_derived :: (Ord a, Fractional a, Enum a) => Int -> a -> [a]
harmonic_series_cps_derived k f1 =
let f0 = fold_cps_to_octave_of f1 (partial f1 k)
in harmonic_series_cps f0
harmonic_series_folded :: Integer -> [Rational]
harmonic_series_folded n =
nub (sort (map fold_ratio_to_octave [1 .. n%1]))
harmonic_series_folded_c :: Integer -> [Cents]
harmonic_series_folded_c = map ratio_to_cents . harmonic_series_folded
harmonic_series_folded_21 :: Tuning
harmonic_series_folded_21 = Tuning (Left (harmonic_series_folded 21)) 2
cents_et12_diff :: Integral n => n -> n
cents_et12_diff n =
let m = n `mod` 100
in if m > 50 then m 100 else m
fcents_et12_diff :: Real n => n -> n
fcents_et12_diff n =
let m = n `mod'` 100
in if m > 50 then m 100 else m
cents_interval_class :: Integral a => a -> a
cents_interval_class n =
let n' = n `mod` 1200
in if n' > 600 then 1200 n' else n'
fcents_interval_class :: Real a => a -> a
fcents_interval_class n =
let n' = n `mod'` 1200
in if n' > 600 then 1200 n' else n'
cents_diff_pp :: (Num a, Ord a, Show a) => a -> String
cents_diff_pp n =
case compare n 0 of
LT -> show n
EQ -> ""
GT -> '+' : show n
cents_diff_br :: (Num a, Ord a, Show a) => (String,String) -> a -> String
cents_diff_br br =
let f s = if null s then s else T.bracket_l br s
in f . cents_diff_pp
cents_diff_text :: (Num a, Ord a, Show a) => a -> String
cents_diff_text = cents_diff_br ("(",")")
cents_diff_md :: (Num a, Ord a, Show a) => a -> String
cents_diff_md = cents_diff_br ("^","^")
cents_diff_html :: (Num a, Ord a, Show a) => a -> String
cents_diff_html = cents_diff_br ("<SUP>","</SUP>")
type Midi_Tuning_F = Int -> T.Midi_Detune
type D12_Midi_Tuning = (Tuning,Cents,Int)
d12_midi_tuning_f :: D12_Midi_Tuning -> Midi_Tuning_F
d12_midi_tuning_f (t,c_diff,k) n =
let (_,pc) = T.midi_to_octpc (n + k)
dt = zipWith () (cents t) [0,100 .. 1200]
in (n,(dt `at` pc) + c_diff)
type CPS_Midi_Tuning = (Tuning,Double,Int,Int)
cps_midi_tuning_f :: CPS_Midi_Tuning -> Midi_Tuning_F
cps_midi_tuning_f (t,f0,k,g) n =
let r = approximate_ratios_cyclic t
m = take g (map (T.cps_to_midi_detune . (* f0)) r)
in m `at` (n k)