module Music.Theory.Pitch where
import Data.Char
import Data.Function
import Data.Maybe
type PitchClass = Integer
type Octave = Integer
type Octave_PitchClass i = (i,i)
type OctPC = (Octave,PitchClass)
data Note_T = C | D | E | F | G | A | B
deriving (Eq,Enum,Bounded,Ord,Show)
data Alteration_T = DoubleFlat
| ThreeQuarterToneFlat | Flat | QuarterToneFlat
| Natural
| QuarterToneSharp | Sharp | ThreeQuarterToneSharp
| DoubleSharp
deriving (Eq,Enum,Bounded,Ord,Show)
data Pitch = Pitch {note :: Note_T
,alteration :: Alteration_T
,octave :: Octave}
deriving (Eq,Show)
instance Ord Pitch where
compare = pitch_compare
pitch_pp :: Pitch -> String
pitch_pp (Pitch n a o) =
let a' = if a == Natural then "" else [alteration_symbol a]
in show n ++ a' ++ show o
pitch_pp_ascii :: Pitch -> String
pitch_pp_ascii (Pitch n a o) =
let n' = map toLower (show n)
in n' ++ alteration_ly_name a ++ show o
note_to_pc :: Integral i => Note_T -> i
note_to_pc n =
case n of
C -> 0
D -> 2
E -> 4
F -> 5
G -> 7
A -> 9
B -> 11
alteration_to_diff :: Integral i => Alteration_T -> Maybe i
alteration_to_diff a =
case a of
DoubleFlat -> Just (2)
Flat -> Just (1)
Natural -> Just 0
Sharp -> Just 1
DoubleSharp -> Just 2
_ -> Nothing
alteration_to_diff_err :: Integral i => Alteration_T -> i
alteration_to_diff_err =
let err = error "alteration_to_diff: quarter tone"
in fromMaybe err . alteration_to_diff
alteration_to_fdiff :: Fractional n => Alteration_T -> n
alteration_to_fdiff a =
case a of
ThreeQuarterToneFlat -> 1.5
QuarterToneFlat -> 0.5
QuarterToneSharp -> 0.5
ThreeQuarterToneSharp -> 1.5
_ -> fromInteger (alteration_to_diff_err a)
fdiff_to_alteration :: (Fractional n,Eq n) => n -> Maybe Alteration_T
fdiff_to_alteration d =
case d of
2 -> Just DoubleFlat
1.5 -> Just ThreeQuarterToneFlat
1 -> Just Flat
0.5 -> Just QuarterToneFlat
0 -> Just Natural
0.5 -> Just QuarterToneSharp
1 -> Just Sharp
1.5 -> Just ThreeQuarterToneSharp
2 -> Just DoubleSharp
_ -> undefined
alteration_symbol :: Alteration_T -> Char
alteration_symbol a = case a of
DoubleFlat -> '𝄫'
ThreeQuarterToneFlat -> '𝄭'
Flat -> '♭'
QuarterToneFlat -> '𝄳'
Natural -> '♮'
QuarterToneSharp -> '𝄲'
Sharp -> '♯'
ThreeQuarterToneSharp -> '𝄰'
DoubleSharp -> '𝄪'
alteration_ly_name :: Alteration_T -> String
alteration_ly_name a =
case a of
DoubleFlat -> "eses"
ThreeQuarterToneFlat -> "eseh"
Flat -> "es"
QuarterToneFlat -> "eh"
Natural -> ""
QuarterToneSharp -> "ih"
Sharp -> "is"
ThreeQuarterToneSharp -> "isih"
DoubleSharp -> "isis"
alteration_raise_quarter_tone :: Alteration_T -> Maybe Alteration_T
alteration_raise_quarter_tone a =
if a == maxBound then Nothing else Just (toEnum (fromEnum a + 1))
alteration_lower_quarter_tone :: Alteration_T -> Maybe Alteration_T
alteration_lower_quarter_tone a =
if a == minBound then Nothing else Just (toEnum (fromEnum a 1))
alteration_edit_quarter_tone :: (Fractional n,Eq n) =>
n -> Alteration_T -> Maybe Alteration_T
alteration_edit_quarter_tone n a =
case n of
0.5 -> alteration_lower_quarter_tone a
0 -> Just a
0.5 -> alteration_raise_quarter_tone a
_ -> Nothing
alteration_clear_quarter_tone :: Alteration_T -> Alteration_T
alteration_clear_quarter_tone x =
case x of
ThreeQuarterToneFlat -> Flat
QuarterToneFlat -> Flat
QuarterToneSharp -> Sharp
ThreeQuarterToneSharp -> Sharp
_ -> x
pitch_clear_quarter_tone :: Pitch -> Pitch
pitch_clear_quarter_tone p =
let Pitch n a o = p
in Pitch n (alteration_clear_quarter_tone a) o
pitch_to_octpc :: Integral i => Pitch -> Octave_PitchClass i
pitch_to_octpc = midi_to_octpc . pitch_to_midi
pitch_to_midi :: Integral i => Pitch -> i
pitch_to_midi (Pitch n a o) =
let a' = alteration_to_diff_err a
n' = note_to_pc n
o' = fromIntegral o
in 12 + o' * 12 + n' + a'
pitch_to_fmidi :: Pitch -> Double
pitch_to_fmidi (Pitch n a o) =
let a' = alteration_to_fdiff a
o' = fromInteger o
n' = fromInteger (note_to_pc n)
in 12 + o' * 12 + n' + a'
pitch_to_pc :: Pitch -> PitchClass
pitch_to_pc (Pitch n a _) = note_to_pc n + alteration_to_diff_err a
pitch_compare :: Pitch -> Pitch -> Ordering
pitch_compare = compare `on` pitch_to_fmidi
type Spelling n = n -> (Note_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)
octpc_nrm :: Integral i => Octave_PitchClass i -> Octave_PitchClass i
octpc_nrm (o,pc) =
if pc > 11
then octpc_nrm (o+1,pc12)
else if pc < 0
then octpc_nrm (o1,pc+12)
else (o,pc)
octpc_trs :: Integral i => i -> Octave_PitchClass i -> Octave_PitchClass i
octpc_trs n (o,pc) =
let pc' = fromIntegral pc
k = pc' + n
(i,j) = k `divMod` 12
in (fromIntegral o + fromIntegral i,fromIntegral j)
octpc_to_midi :: Integral i => Octave_PitchClass i -> i
octpc_to_midi (o,pc) = 60 + ((fromIntegral o 4) * 12) + pc
midi_to_octpc :: Integral i => i -> Octave_PitchClass i
midi_to_octpc n = (n 12) `divMod` 12
midi_to_pitch :: Integral i => Spelling i -> i -> Pitch
midi_to_pitch sp = octpc_to_pitch sp . midi_to_octpc
fmidi_to_pitch :: RealFrac n => Spelling Integer -> n -> Pitch
fmidi_to_pitch sp m =
let m' = round m
(Pitch n a o) = midi_to_pitch sp m'
Just a' = alteration_edit_quarter_tone (m fromIntegral m') a
in Pitch n a' 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
ThreeQuarterToneFlat -> pitch_note_lower (Pitch n QuarterToneSharp o)
ThreeQuarterToneSharp -> pitch_note_raise (Pitch n QuarterToneFlat o)
_ -> Pitch n a o
pitch_edit_octave :: (Integer -> Integer) -> Pitch -> Pitch
pitch_edit_octave f (Pitch n a o) = Pitch n a (f o)
note_t_transpose :: Note_T -> Int -> Note_T
note_t_transpose x n =
let x' = fromEnum x
n' = fromEnum (maxBound::Note_T) + 1
in toEnum ((x' + n) `mod` n')
midi_to_cps :: (Integral i,Floating f) => i -> f
midi_to_cps = fmidi_to_cps . fromIntegral
fmidi_to_cps :: Floating a => a -> a
fmidi_to_cps i = 440 * (2 ** ((i 69) * (1 / 12)))
cps_to_midi :: (Integral i,Floating f,RealFrac f) => f -> i
cps_to_midi = round . cps_to_fmidi
cps_to_fmidi :: Floating a => a -> a
cps_to_fmidi a = (logBase 2 (a * (1 / 440)) * 12) + 69
octpc_to_cps :: (Integral i,Floating n) => Octave_PitchClass i -> n
octpc_to_cps = midi_to_cps . octpc_to_midi