module Music.Theory.Duration where
import Data.Function
import Data.List
import Data.Ratio
data Duration = Duration { division :: Integer
, dots :: Integer
, multiplier :: Rational }
deriving (Eq, Show)
instance Ord Duration where
compare = duration_compare
data D_Annotation = Tie_Right | Tie_Left
| Begin_Tuplet (Integer,Integer,Duration) | End_Tuplet
deriving (Eq,Show)
breve,whole_note,half_note,quarter_note,eighth_note,sixteenth_note,thirtysecond_note :: Duration
breve = Duration 0 0 1
whole_note = Duration 1 0 1
half_note = Duration 2 0 1
quarter_note = Duration 4 0 1
eighth_note = Duration 8 0 1
sixteenth_note = Duration 16 0 1
thirtysecond_note = Duration 32 0 1
dotted_breve,dotted_whole_note,dotted_half_note,dotted_quarter_note,dotted_eighth_note,dotted_sixteenth_note,dotted_thirtysecond_note :: Duration
dotted_breve = Duration 0 1 1
dotted_whole_note = Duration 1 1 1
dotted_half_note = Duration 2 1 1
dotted_quarter_note = Duration 4 1 1
dotted_eighth_note = Duration 8 1 1
dotted_sixteenth_note = Duration 16 1 1
dotted_thirtysecond_note = Duration 32 1 1
double_dotted_breve,double_dotted_whole_note,double_dotted_half_note,double_dotted_quarter_note,double_dotted_eighth_note,double_dotted_sixteenth_note,double_dotted_thirtysecond_note :: Duration
double_dotted_breve = Duration 0 2 1
double_dotted_whole_note = Duration 2 2 1
double_dotted_half_note = Duration 2 2 1
double_dotted_quarter_note = Duration 4 2 1
double_dotted_eighth_note = Duration 8 2 1
double_dotted_sixteenth_note = Duration 16 2 1
double_dotted_thirtysecond_note = Duration 32 2 1
duration_compare :: Duration -> Duration -> Ordering
duration_compare = compare `on` duration_to_rq
duration_compare_meq :: Duration -> Duration -> Ordering
duration_compare_meq y0 y1 =
if y0 == y1
then EQ
else let (Duration x0 n0 m0) = y0
(Duration x1 n1 m1) = y1
in if m0 /= m1
then error "duration_compare_meq: non-equal multipliers"
else if x0 == x1
then compare n0 n1
else compare x1 x0
sort_pair :: (t -> t -> Ordering) -> (t, t) -> (t, t)
sort_pair fn (x,y) =
case fn x y of
LT -> (x,y)
EQ -> (x,y)
GT -> (y,x)
no_dots :: (Duration, Duration) -> Bool
no_dots (x0,x1) = dots x0 == 0 && dots x1 == 0
sum_dur_undotted :: (Integer, Integer) -> Maybe Duration
sum_dur_undotted (x0, x1)
| x0 == x1 = Just (Duration (x0 `div` 2) 0 1)
| x0 == x1 * 2 = Just (Duration x1 1 1)
| otherwise = Nothing
sum_dur_dotted :: (Integer,Integer,Integer,Integer) -> Maybe Duration
sum_dur_dotted (x0, n0, x1, n1)
| x0 == x1 &&
n0 == 1 &&
n1 == 1 = Just (Duration (x1 `div` 2) 1 1)
| x0 == x1 * 2 &&
n0 == 0 &&
n1 == 1 = Just (Duration (x1 `div` 2) 0 1)
| otherwise = Nothing
sum_dur :: Duration -> Duration -> Maybe Duration
sum_dur y0 y1 =
let (x0,x1) = sort_pair duration_compare_meq (y0,y1)
in if no_dots (x0,x1)
then sum_dur_undotted (division x0, division x1)
else sum_dur_dotted (division x0, dots x0
,division x1, dots x1)
sum_dur' :: Duration -> Duration -> Duration
sum_dur' y0 y1 =
let y2 = sum_dur y0 y1
err = error ("sum_dur': " ++ show (y0,y1))
in maybe err id y2
rq_to_duration :: Rational -> Maybe Duration
rq_to_duration x =
case (numerator x,denominator x) of
(1,8) -> Just thirtysecond_note
(3,16) -> Just dotted_thirtysecond_note
(1,4) -> Just sixteenth_note
(3,8) -> Just dotted_sixteenth_note
(1,2) -> Just eighth_note
(3,4) -> Just dotted_eighth_note
(1,1) -> Just quarter_note
(3,2) -> Just dotted_quarter_note
(2,1) -> Just half_note
(3,1) -> Just dotted_half_note
(7,2) -> Just double_dotted_half_note
(4,1) -> Just whole_note
(6,1) -> Just dotted_whole_note
(8,1) -> Just breve
(12,1) -> Just dotted_breve
_ -> Nothing
whole_note_division_to_rq :: Integer -> Rational
whole_note_division_to_rq x =
let f = (* 4) . recip . (%1)
in case x of
0 -> 8
1 -> 16
_ -> f x
rq_apply_dots :: Rational -> Integer -> Rational
rq_apply_dots n d =
let m = iterate (\x -> x / 2) n
in sum (genericTake (d + 1) m)
duration_to_rq :: Duration -> Rational
duration_to_rq (Duration n d m) =
let x = whole_note_division_to_rq n
in rq_apply_dots x d * m
whole_note_division_to_musicxml_type :: Integer -> String
whole_note_division_to_musicxml_type x =
case x of
256 -> "256th"
128 -> "128th"
64 -> "64th"
32 -> "32nd"
16 -> "16th"
8 -> "eighth"
4 -> "quarter"
2 -> "half"
1 -> "whole"
0 -> "breve"
1 -> "long"
_ -> error ("whole_note_division_to_musicxml_type: " ++ show x)
duration_to_musicxml_type :: Duration -> String
duration_to_musicxml_type = whole_note_division_to_musicxml_type . division
duration_to_lilypond_type :: Duration -> String
duration_to_lilypond_type (Duration dv d _) =
let dv' = if dv == 0 then "\\breve" else show dv
in dv' ++ replicate (fromIntegral d) '.'
whole_note_division_to_beam_count :: Integer -> Maybe Integer
whole_note_division_to_beam_count x =
let t = [(256,6),(128,5),(64,4),(32,3),(16,2),(8,1)
,(4,0),(2,0),(1,0),(0,0),(1,0)]
in lookup x t
duration_beam_count :: Duration -> Integer
duration_beam_count (Duration x _ _) =
case whole_note_division_to_beam_count x of
Nothing -> error "duration_beam_count"
Just x' -> x'