module Music.Theory.Interval where
import qualified Data.List as L
import Data.Maybe
import Music.Theory.Pitch
data Interval_T = Unison | Second | Third | Fourth
| Fifth | Sixth | Seventh
deriving (Eq,Enum,Bounded,Ord,Show)
data Interval_Q = Diminished | Minor
| Perfect
| Major | Augmented
deriving (Eq,Enum,Bounded,Ord,Show)
data Interval = Interval {interval_type :: Interval_T
,interval_quality :: Interval_Q
,interval_direction :: Ordering
,interval_octave :: Octave}
deriving (Eq,Show)
interval_ty :: Note_T -> Note_T -> Interval_T
interval_ty n1 n2 = toEnum ((fromEnum n2 fromEnum n1) `mod` 7)
interval_q_tbl :: Integral n => [(Interval_T, [(n,Interval_Q)])]
interval_q_tbl =
[(Unison,[(11,Diminished)
,(0,Perfect)
,(1,Augmented)])
,(Second,[(0,Diminished)
,(1,Minor)
,(2,Major)
,(3,Augmented)])
,(Third,[(2,Diminished)
,(3,Minor)
,(4,Major)
,(5,Augmented)])
,(Fourth,[(4,Diminished)
,(5,Perfect)
,(6,Augmented)])
,(Fifth,[(6,Diminished)
,(7,Perfect)
,(8,Augmented)])
,(Sixth,[(7,Diminished)
,(8,Minor)
,(9,Major)
,(10,Augmented)])
,(Seventh,[(9,Diminished)
,(10,Minor)
,(11,Major)
,(12,Augmented)])]
interval_q :: Interval_T -> Int -> Maybe Interval_Q
interval_q i n = lookup i interval_q_tbl >>= lookup n
interval_q_reverse :: Interval_T -> Interval_Q -> Maybe Integer
interval_q_reverse ty qu =
case lookup ty interval_q_tbl of
Nothing -> Nothing
Just tbl -> fmap fst (L.find ((== qu) . snd) tbl)
interval_semitones :: Interval -> Integer
interval_semitones (Interval ty qu dir oct) =
case interval_q_reverse ty qu of
Just n -> let o = 12 * oct
in if dir == GT then negate n o else n + o
Nothing -> error "interval_semitones"
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'']
invert_ordering :: Ordering -> Ordering
invert_ordering x =
case x of
GT -> LT
LT -> GT
EQ -> EQ
interval :: Pitch -> Pitch -> Interval
interval p1 p2 =
let c = compare p1 p2
(Pitch n1 _ o1) = p1
(Pitch n2 _ o2) = p2
p1' = pitch_to_pc p1
p2' = pitch_to_pc p2
st = (p2' p1') `mod` 12
ty = interval_ty n1 n2
(Just qu) = interval_q ty (fromIntegral st)
o_a = if n1 > n2 then 1 else 0
in case c of
GT -> (interval p2 p1) { interval_direction = GT }
_ -> Interval ty qu c (o2 o1 + o_a)
invert_interval :: Interval -> Interval
invert_interval (Interval t qu d o) =
let d' = invert_ordering d
in Interval t qu d' o
quality_difference_m :: Interval_Q -> Interval_Q -> Maybe Int
quality_difference_m a b =
let rule (x,y) =
if x == y
then Just 0
else case (x,y) of
(Diminished,Minor) -> Just 1
(Diminished,Major) -> Just 2
(Diminished,Augmented) -> Just 3
(Minor,Major) -> Just 1
(Minor,Augmented) -> Just 2
(Major,Augmented) -> Just 1
(Diminished,Perfect) -> Just 1
(Perfect,Augmented) -> Just 1
_ -> Nothing
fwd = rule (a,b)
rvs = rule (b,a)
in case fwd of
Just n -> Just n
Nothing -> case rvs of
Just n -> Just (negate n)
Nothing -> Nothing
quality_difference :: Interval_Q -> Interval_Q -> Int
quality_difference a b =
let err = error ("quality_difference: " ++ show (a,b))
in fromMaybe err (quality_difference_m a b)
transpose :: Interval -> Pitch -> Pitch
transpose i ip =
let (Pitch p_n p_a p_o) = ip
(Interval i_t i_q i_d i_o) = i
i_d' = if i_d == GT
then 1
else 1
p_n' = toEnum ((fromEnum p_n + (fromEnum i_t * i_d')) `mod` 7)
oa = if p_n' > p_n && i_d == GT
then 1
else if p_n' < p_n && i_d == LT
then 1
else 0
ip' = Pitch p_n' p_a (p_o + i_o + oa)
st = if i_d == GT
then (pitch_to_pc ip pitch_to_pc ip') `mod` 12
else (pitch_to_pc ip' pitch_to_pc ip) `mod` 12
ty = if i_d == GT
then interval_ty p_n' p_n
else interval_ty p_n p_n'
qu = let err = error ("qu: " ++ show (ty,st))
in fromMaybe err (interval_q ty (fromIntegral st))
qd = quality_difference qu i_q * i_d'
p_a' = toEnum (fromEnum p_a + (qd * 2))
in ip' { alteration = p_a' }
circle_of_fifths :: Pitch -> ([Pitch], [Pitch])
circle_of_fifths x =
let p4 = Interval Fourth Perfect LT 0
p5 = Interval Fifth Perfect LT 0
mk y = take 12 (iterate (transpose y) x)
in (mk p4,mk p5)