```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

-- | Duration annotations
data D_Annotation = Tie_Right | Tie_Left
| Begin_Tuplet (Integer,Integer,Duration) | End_Tuplet
deriving (Eq,Show)

-- * Constants

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

-- * Operations

duration_compare :: Duration -> Duration -> Ordering
duration_compare = compare `on` duration_to_rq

-- | Compare durations with equal multipliers.
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

{-
zipWith duration_compare_meq [e,e,e,e'] [e,s,q,e]
-}

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)

-- | True if neither duration is dotted.
no_dots :: (Duration, Duration) -> Bool
no_dots (x0,x1) = dots x0 == 0 && dots x1 == 0

-- | Sum undotted divisions, input is required to be sorted.
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 dotted divisions, input is required to be sorted.
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 durations.  Not all durations can be summed, and the present
--   algorithm is not exhaustive.
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

{-
zipWith sum_dur [e,q,q'] [e,e,e]
-}

-- * RQ (Rational Quarter Note Count)

-- | Rational number of quarter notes to duration value.
--   It is a mistake to hope this could handle tuplets
--   directly, ie. a 3:2 dotted note will be of the same
--   duration as a plain undotted note.
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

-- | Convert a whole note division integer to a RQ.
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

-- | Apply `d' dots to the duration `n'.
rq_apply_dots :: Rational -> Integer -> Rational
rq_apply_dots n d =
let m = iterate (\x -> x / 2) n
in sum (genericTake (d + 1) m)

-- | Convert duration to RQ value, see rq_to_duration for partial
--   inverse.
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

-- Note the duration multiplier is *not* written.
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'
```