module Music.Theory.Pitch.Note where
import Data.Char
import Data.Maybe
import qualified Music.Theory.List as T
data Note_T = C | D | E | F | G | A | B
deriving (Eq,Enum,Bounded,Ord,Read,Show)
note_seq :: [Note_T]
note_seq = [C .. B]
note_pp :: Note_T -> Char
note_pp = head . show
note_pc_tbl :: Num i => [(Note_T,i)]
note_pc_tbl = zip [C .. B] [0,2,4,5,7,9,11]
note_to_pc :: Num i => Note_T -> i
note_to_pc n = fromMaybe (error "note_to_pc") (lookup n note_pc_tbl)
pc_to_note :: (Eq i,Num i) => i -> Maybe Note_T
pc_to_note i = T.reverse_lookup i note_pc_tbl
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')
parse_note_t :: Bool -> Char -> Maybe Note_T
parse_note_t ci c =
let tbl = zip "CDEFGAB" [C,D,E,F,G,A,B]
in lookup (if ci then toUpper c else c) tbl
note_span :: Note_T -> Note_T -> [Note_T]
note_span n1 n2 =
let fn x = toEnum (x `mod` 7)
n1' = fromEnum n1
n2' = fromEnum n2
n2'' = if n1' > n2' then n2' + 7 else n2'
in map fn [n1' .. n2'']
data Alteration_T =
DoubleFlat
| ThreeQuarterToneFlat | Flat | QuarterToneFlat
| Natural
| QuarterToneSharp | Sharp | ThreeQuarterToneSharp
| DoubleSharp
deriving (Eq,Enum,Bounded,Ord,Show)
generic_alteration_to_diff :: Integral i => Alteration_T -> Maybe i
generic_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 :: Alteration_T -> Maybe Int
alteration_to_diff = generic_alteration_to_diff
alteration_is_12et :: Alteration_T -> Bool
alteration_is_12et = isJust . alteration_to_diff
alteration_to_diff_err :: Integral i => Alteration_T -> i
alteration_to_diff_err =
let err = error "alteration_to_diff: quarter tone"
in fromMaybe err . generic_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_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
alteration_symbol_tbl :: [(Alteration_T,Char)]
alteration_symbol_tbl =
[(DoubleFlat,'𝄫')
,(ThreeQuarterToneFlat,'𝄭')
,(Flat,'♭')
,(QuarterToneFlat,'𝄳')
,(Natural,'♮')
,(QuarterToneSharp,'𝄲')
,(Sharp,'♯')
,(ThreeQuarterToneSharp,'𝄰')
,(DoubleSharp,'𝄪')]
alteration_symbol :: Alteration_T -> Char
alteration_symbol a = fromMaybe (error "alteration_symbol") (lookup a alteration_symbol_tbl)
symbol_to_alteration :: Char -> Maybe Alteration_T
symbol_to_alteration c = T.reverse_lookup c alteration_symbol_tbl
symbol_to_alteration_iso :: Char -> Maybe Alteration_T
symbol_to_alteration_iso c =
case c of
'b' -> Just Flat
'#' -> Just Sharp
'x' -> Just DoubleSharp
_ -> symbol_to_alteration c
alteration_iso_tbl :: [(Alteration_T,String)]
alteration_iso_tbl =
[(DoubleFlat,"bb")
,(Flat,"b")
,(Natural,"")
,(Sharp,"#")
,(DoubleSharp,"x")]
alteration_iso_m :: Alteration_T -> Maybe String
alteration_iso_m a = lookup a alteration_iso_tbl
alteration_iso :: Alteration_T -> String
alteration_iso =
let qt = error "alteration_iso: quarter tone"
in fromMaybe qt . alteration_iso_m
alteration_tonh :: Alteration_T -> String
alteration_tonh a =
case a of
DoubleFlat -> "eses"
ThreeQuarterToneFlat -> "eseh"
Flat -> "es"
QuarterToneFlat -> "eh"
Natural -> ""
QuarterToneSharp -> "ih"
Sharp -> "is"
ThreeQuarterToneSharp -> "isih"
DoubleSharp -> "isis"
note_alteration_to_pc :: (Note_T,Alteration_T) -> Maybe Int
note_alteration_to_pc (n,a) =
let n_pc = note_to_pc n
in fmap ((`mod` 12) . (+ n_pc)) (alteration_to_diff a)
note_alteration_to_pc_err :: (Note_T, Alteration_T) -> Int
note_alteration_to_pc_err = fromMaybe (error "note_alteration_to_pc") . note_alteration_to_pc
note_alteration_ks :: [(Note_T, Alteration_T)]
note_alteration_ks =
[(C,Natural),(C,Sharp),(D,Natural),(E,Flat),(E,Natural),(F,Natural)
,(F,Sharp),(G,Natural),(A,Flat),(A,Natural),(B,Flat),(B,Natural)]
pc_note_alteration_ks_tbl :: Integral i => [((Note_T,Alteration_T),i)]
pc_note_alteration_ks_tbl = zip note_alteration_ks [0..11]
pc_to_note_alteration_ks :: Integral i => i -> Maybe (Note_T,Alteration_T)
pc_to_note_alteration_ks i = T.reverse_lookup i pc_note_alteration_ks_tbl
type Alteration_R = (Rational,String)
alteration_r :: Alteration_T -> Alteration_R
alteration_r a = (alteration_to_fdiff a,[alteration_symbol a])