module Music.Theory.Pitch where
import Data.Char
import Data.Function
import Data.List
import Data.Maybe
import Text.Printf
import qualified Music.Theory.List as T
import qualified Music.Theory.Math as T
import qualified Music.Theory.Pitch.Note as T
type Octave_PitchClass i = (i,i)
octave_pitchclass_nrm :: Integral i => Octave_PitchClass i -> Octave_PitchClass i
octave_pitchclass_nrm (o,pc) =
if pc > 11
then octave_pitchclass_nrm (o+1,pc12)
else if pc < 0
then octave_pitchclass_nrm (o1,pc+12)
else (o,pc)
octave_pitchclass_trs :: Integral i => i -> Octave_PitchClass i -> Octave_PitchClass i
octave_pitchclass_trs n (o,pc) =
let pc' = fromIntegral pc
k = pc' + n
(i,j) = k `divMod` 12
in (fromIntegral o + fromIntegral i,fromIntegral j)
octave_pitchclass_to_midi :: Integral i => Octave_PitchClass i -> i
octave_pitchclass_to_midi (o,pc) = 60 + ((o 4) * 12) + pc
midi_to_octave_pitchclass :: Integral i => i -> Octave_PitchClass i
midi_to_octave_pitchclass n = (n 12) `divMod` 12
type PitchClass = Int
type Octave = Int
type OctPC = (Octave,PitchClass)
to_octpc :: (Integral pc, Integral oct) => (oct,pc) -> OctPC
to_octpc (oct,pc) = (fromIntegral oct,fromIntegral pc)
octpc_nrm :: OctPC -> OctPC
octpc_nrm = octave_pitchclass_nrm
octpc_trs :: Int -> OctPC -> OctPC
octpc_trs = octave_pitchclass_trs
octpc_range :: (OctPC,OctPC) -> [OctPC]
octpc_range (l,r) =
let (l',r') = (octpc_to_midi l,octpc_to_midi r)
in map midi_to_octpc [l' .. r']
type Midi = Int
octpc_to_midi :: OctPC -> Midi
octpc_to_midi = octave_pitchclass_to_midi
midi_to_octpc :: Midi -> OctPC
midi_to_octpc = midi_to_octave_pitchclass
type FMidi = Double
type FOctPC = (Int,Double)
octpc_to_fmidi :: (Integral i,Num n) => Octave_PitchClass i -> n
octpc_to_fmidi = fromIntegral . octave_pitchclass_to_midi
fmidi_to_foctpc :: RealFrac f => f -> (Octave,f)
fmidi_to_foctpc n = let o = (floor n 12) `div` 12 in (o,n (fromIntegral (o + 1) * 12))
fmidi_octave :: RealFrac f => f -> Octave
fmidi_octave = fst . fmidi_to_foctpc
foctpc_to_fmidi :: RealFrac f => (Octave,f) -> f
foctpc_to_fmidi (o,pc) = (fromIntegral (o + 1) * 12) + pc
fmidi_in_octave :: RealFrac f => Octave -> f -> f
fmidi_in_octave o m = let (_,pc) = fmidi_to_foctpc m in foctpc_to_fmidi (o,pc)
data Pitch = Pitch {note :: T.Note_T
,alteration :: T.Alteration_T
,octave :: Octave}
deriving (Eq,Show)
instance Ord Pitch where
compare = pitch_compare
pitch_clear_quarter_tone :: Pitch -> Pitch
pitch_clear_quarter_tone p =
let Pitch n a o = p
in Pitch n (T.alteration_clear_quarter_tone a) o
pitch_to_octpc :: Integral i => Pitch -> Octave_PitchClass i
pitch_to_octpc = midi_to_octave_pitchclass . pitch_to_midi
pitch_is_12et :: Pitch -> Bool
pitch_is_12et = T.alteration_is_12et . alteration
pitch_to_midi :: Integral i => Pitch -> i
pitch_to_midi (Pitch n a o) =
let a' = T.alteration_to_diff_err a
n' = T.note_to_pc n
o' = fromIntegral o
in 12 + o' * 12 + n' + a'
pitch_to_fmidi :: Fractional n => Pitch -> n
pitch_to_fmidi (Pitch n a o) =
let a' = T.alteration_to_fdiff a
o' = fromIntegral o
n' = fromInteger (T.note_to_pc n)
in 12 + o' * 12 + n' + a'
pitch_to_pc :: Pitch -> PitchClass
pitch_to_pc (Pitch n a _) = (T.note_to_pc n + T.alteration_to_diff_err a) `mod` 12
pitch_compare :: Pitch -> Pitch -> Ordering
pitch_compare =
let f = pitch_to_fmidi :: Pitch -> Double
in compare `on` f
type Spelling n = n -> (T.Note_T,T.Alteration_T)
type Spelling_M i = i -> Maybe (T.Note_T,T.Alteration_T)
octpc_to_pitch :: Integral i => Spelling i -> Octave_PitchClass i -> Pitch
octpc_to_pitch sp (o,pc) =
let (n,a) = sp pc
in Pitch n a (fromIntegral o)
midi_to_pitch :: Integral i => Spelling i -> i -> Pitch
midi_to_pitch sp = octpc_to_pitch sp . midi_to_octave_pitchclass
fmidi_et12_cents_pp :: Spelling PitchClass -> Double -> String
fmidi_et12_cents_pp sp =
let f (m,c) =
let d = T.num_diff_str (round c :: Int)
d' = if null d then "" else "(" ++ d ++ ")"
in pitch_pp (midi_to_pitch sp m) ++ d'
in f . midi_detune_normalise . fmidi_to_midi_detune
fmidi_to_pitch :: RealFrac n => Spelling PitchClass -> n -> Maybe Pitch
fmidi_to_pitch sp m =
let m' = round m
(Pitch n a o) = midi_to_pitch sp m'
q = m fromIntegral m'
in case T.alteration_edit_quarter_tone q a of
Nothing -> Nothing
Just a' -> Just (Pitch n a' o)
fmidi_to_pitch_err :: (Show n,RealFrac n) => Spelling Int -> n -> Pitch
fmidi_to_pitch_err sp m = fromMaybe (error (show ("fmidi_to_pitch",m))) (fmidi_to_pitch sp m)
pitch_tranpose :: (RealFrac n,Show n) => Spelling Int -> n -> Pitch -> Pitch
pitch_tranpose sp n p =
let m = pitch_to_fmidi p
in fmidi_to_pitch_err sp (m + n)
fmidi_in_octave_of :: RealFrac f => f -> f -> f
fmidi_in_octave_of p = fmidi_in_octave (fmidi_octave p)
fmidi_in_octave_nearest :: RealFrac n => n -> n -> n
fmidi_in_octave_nearest m1 m2 =
let m2' = fmidi_in_octave (fmidi_octave m1) m2
m2'' = [m2' 12,m2',m2' + 12]
d = map (abs . (m1 )) m2''
z = sortOn snd (zip m2'' d)
in fst (head z)
fmidi_in_octave_above :: RealFrac a => a -> a -> a
fmidi_in_octave_above p q = let r = fmidi_in_octave_nearest p q in if r < p then r + 12 else r
fmidi_in_octave_below :: RealFrac a => a -> a -> a
fmidi_in_octave_below p q = let r = fmidi_in_octave_nearest p q in if r > p then r 12 else r
cps_in_octave' :: Floating f => (f -> f -> f) -> f -> f -> f
cps_in_octave' f p = fmidi_to_cps . f (cps_to_fmidi p) . cps_to_fmidi
cps_in_octave_nearest :: (Floating f,RealFrac f) => f -> f -> f
cps_in_octave_nearest = cps_in_octave' fmidi_in_octave_nearest
cps_in_octave_above :: (Ord a, Fractional a) => a -> a -> a
cps_in_octave_above p =
let go q = if q > p * 2 then go (q / 2) else if q < p then go (q * 2) else q
in go
cps_in_octave_above' :: (Floating f,RealFrac f) => f -> f -> f
cps_in_octave_above' = cps_in_octave' fmidi_in_octave_above
cps_in_octave_below :: (Floating f,RealFrac f) => f -> f -> f
cps_in_octave_below = cps_in_octave' fmidi_in_octave_below
pitch_in_octave_nearest :: Pitch -> Pitch -> Pitch
pitch_in_octave_nearest p1 p2 =
let f = pitch_to_fmidi :: Pitch -> Double
o = fmidi_octave (fmidi_in_octave_nearest (f p1) (f p2))
in p2 {octave = o}
pitch_note_raise :: Pitch -> Pitch
pitch_note_raise (Pitch n a o) =
if n == maxBound
then Pitch minBound a (o + 1)
else Pitch (succ n) a o
pitch_note_lower :: Pitch -> Pitch
pitch_note_lower (Pitch n a o) =
if n == minBound
then Pitch maxBound a (o 1)
else Pitch (pred n) a o
pitch_rewrite_threequarter_alteration :: Pitch -> Pitch
pitch_rewrite_threequarter_alteration (Pitch n a o) =
case a of
T.ThreeQuarterToneFlat -> pitch_note_lower (Pitch n T.QuarterToneSharp o)
T.ThreeQuarterToneSharp -> pitch_note_raise (Pitch n T.QuarterToneFlat o)
_ -> Pitch n a o
pitch_edit_octave :: (Octave -> Octave) -> Pitch -> Pitch
pitch_edit_octave f (Pitch n a o) = Pitch n a (f o)
midi_to_cps_f0 :: (Integral i,Floating f) => f -> i -> f
midi_to_cps_f0 f0 = fmidi_to_cps_f0 f0 . fromIntegral
midi_to_cps :: (Integral i,Floating f) => i -> f
midi_to_cps = midi_to_cps_f0 440
fmidi_to_cps_f0 :: Floating a => a -> a -> a
fmidi_to_cps_f0 f0 i = f0 * (2 ** ((i 69) * (1 / 12)))
fmidi_to_cps :: Floating a => a -> a
fmidi_to_cps = fmidi_to_cps_f0 440
pitch_to_cps_f0 :: Floating n => n -> Pitch -> n
pitch_to_cps_f0 f0 = fmidi_to_cps_f0 f0 . pitch_to_fmidi
pitch_to_cps :: Floating n => Pitch -> n
pitch_to_cps = pitch_to_cps_f0 440
cps_to_fmidi_f0 :: Floating a => a -> a -> a
cps_to_fmidi_f0 f0 a = (logBase 2 (a * (1 / f0)) * 12) + 69
cps_to_fmidi :: Floating a => a -> a
cps_to_fmidi = cps_to_fmidi_f0 440
cps_to_midi :: (Integral i,Floating f,RealFrac f) => f -> i
cps_to_midi = round . cps_to_fmidi
octpc_to_cps_f0 :: (Integral i,Floating n) => n -> Octave_PitchClass i -> n
octpc_to_cps_f0 f0 = midi_to_cps_f0 f0 . octave_pitchclass_to_midi
octpc_to_cps :: (Integral i,Floating n) => Octave_PitchClass i -> n
octpc_to_cps = octpc_to_cps_f0 440
cps_to_octpc :: (Floating f,RealFrac f,Integral i) => f -> Octave_PitchClass i
cps_to_octpc = midi_to_octave_pitchclass . cps_to_midi
cps_octave :: (Floating f,RealFrac f) => f -> Octave
cps_octave = fst . cps_to_octpc
type Midi_Detune' c = (Int,c)
cents_is_normal :: (Num c, Ord c) => c -> Bool
cents_is_normal c = c > (50) && c <= 50
midi_detune_is_normal :: (Num c, Ord c) => Midi_Detune' c -> Bool
midi_detune_is_normal = cents_is_normal . snd
midi_detune_normalise :: (Ord c,Num c) => Midi_Detune' c -> Midi_Detune' c
midi_detune_normalise (m,c) =
if c > 50
then midi_detune_normalise (m + 1,c 100)
else if c > (50)
then (m,c)
else midi_detune_normalise (m 1,c + 100)
midi_detune_to_cps_f0 :: Real c => Double -> Midi_Detune' c -> Double
midi_detune_to_cps_f0 f0 (m,c) = fmidi_to_cps_f0 f0 (fromIntegral m + (realToFrac c / 100))
midi_detune_to_cps :: Real c => Midi_Detune' c -> Double
midi_detune_to_cps = midi_detune_to_cps_f0 440
midi_detune_to_fmidi :: Real c => Midi_Detune' c -> Double
midi_detune_to_fmidi (mnn,c) = fromIntegral mnn + (realToFrac c / 100)
midi_detune_to_pitch :: Real c => Spelling Int -> Midi_Detune' c -> Pitch
midi_detune_to_pitch sp = fmidi_to_pitch_err sp . cps_to_fmidi . midi_detune_to_cps
type Midi_Detune = Midi_Detune' Double
fmidi_to_midi_detune :: Double -> Midi_Detune
fmidi_to_midi_detune mnn =
let (n,c) = T.integral_and_fractional_parts mnn
in (n,c * 100)
cps_to_midi_detune :: Double -> Midi_Detune
cps_to_midi_detune = fmidi_to_midi_detune . cps_to_fmidi
midi_detune_nearest_24et :: Midi_Detune -> Midi_Detune
midi_detune_nearest_24et (m,dt) = midi_detune_normalise (m,T.round_to 50 dt)
type Midi_Cents = Midi_Detune' Int
midi_detune_to_midi_cents :: Midi_Detune -> Midi_Cents
midi_detune_to_midi_cents (m,c) = (m,round c)
midi_cents_pp :: Midi_Cents -> String
midi_cents_pp (m,c) = if cents_is_normal c then printf "%d.%02d" m c else error "midi_cents_pp"
parse_octave :: Num a => a -> String -> Maybe a
parse_octave def_o o =
case o of
[] -> Just def_o
[n] -> if isDigit n
then Just (fromIntegral (digitToInt n))
else Nothing
_ -> Nothing
parse_iso_pitch_oct :: Octave -> String -> Maybe Pitch
parse_iso_pitch_oct def_o s =
let mk n a o = case T.parse_note_t True n of
Nothing -> Nothing
Just n' -> fmap (Pitch n' a) (parse_octave def_o o)
in case s of
[] -> Nothing
n:'b':'b':o -> mk n T.DoubleFlat o
n:'#':'#':o -> mk n T.DoubleSharp o
n:'x':o -> mk n T.DoubleSharp o
n:'b':o -> mk n T.Flat o
n:'#':o -> mk n T.Sharp o
n:o -> mk n T.Natural o
parse_iso_pitch :: String -> Maybe Pitch
parse_iso_pitch = parse_iso_pitch_oct (error "parse_iso_pitch: no octave")
parse_iso_pitch_err :: String -> Pitch
parse_iso_pitch_err = fromMaybe (error "parse_iso_pitch") . parse_iso_pitch
pitch_pp_opt :: (Bool,Bool) -> Pitch -> String
pitch_pp_opt (show_nat,show_oct) (Pitch n a o) =
let a' = if a == T.Natural && not show_nat then "" else [T.alteration_symbol a]
rem_oct_f c = isDigit c || c == '-'
rem_oct = if show_oct then id else T.dropWhileRight rem_oct_f
in rem_oct (show n ++ a' ++ show o)
pitch_pp :: Pitch -> String
pitch_pp = pitch_pp_opt (False,True)
pitch_class_pp :: Pitch -> String
pitch_class_pp = pitch_pp_opt (False,False)
pitch_class_names_12et :: Integral n => Spelling n -> n -> n -> [String]
pitch_class_names_12et sp k n =
let f = pitch_class_pp . midi_to_pitch sp
in map f [60 + k .. 60 + k + n 1]
pitch_pp_iso :: Pitch -> String
pitch_pp_iso (Pitch n a o) = show n ++ T.alteration_iso a ++ show o
pitch_pp_hly :: Pitch -> String
pitch_pp_hly (Pitch n a o) =
let n' = map toLower (show n)
in n' ++ T.alteration_tonh a ++ show o
pitch_pp_tonh :: Pitch -> String
pitch_pp_tonh (Pitch n a o) =
let o' = show o
in case (n,a) of
(T.B,T.Natural) -> "H" ++ o'
(T.B,T.Flat) -> "B" ++ o'
(T.B,T.DoubleFlat) -> "Heses" ++ o'
(T.A,T.Flat) -> "As" ++ o'
(T.E,T.Flat) -> "Es" ++ o'
_ -> show n ++ T.alteration_tonh a ++ o'
pc24et_univ :: [Pitch]
pc24et_univ =
let a = [T.Natural,T.QuarterToneSharp,T.Sharp,T.ThreeQuarterToneSharp]
f (n,k) = map (\i -> Pitch n (a !! i) 4) [0 .. k 1]
in concatMap f (zip T.note_seq [4,4,2,4,4,4,2])
pc24et_to_pitch :: Integral i => i -> Pitch
pc24et_to_pitch = genericIndex pc24et_univ
data Pitch_R = Pitch_R T.Note_T T.Alteration_R Octave
deriving (Eq,Show)
pitch_r_pp :: Pitch_R -> String
pitch_r_pp (Pitch_R n (_,a) o) = show n ++ a ++ show o
pitch_r_class_pp :: Pitch_R -> String
pitch_r_class_pp = T.dropWhileRight isDigit . pitch_r_pp