module Music.Theory.Duration where
import Control.Monad
import Data.List
import Data.Maybe
import Data.Ratio
import qualified Music.Theory.List as T
import qualified Music.Theory.Ord as T
data Duration = Duration {division :: Integer
,dots :: Integer
,multiplier :: Rational
}
deriving (Eq,Show)
duration_meq :: Duration -> Duration -> Bool
duration_meq p q = multiplier p == multiplier q
duration_m1 :: Duration -> Bool
duration_m1 = (== 1) . multiplier
duration_compare_meq :: Duration -> Duration -> Maybe Ordering
duration_compare_meq y0 y1 =
let (Duration x0 n0 m0) = y0
(Duration x1 n1 m1) = y1
in if y0 == y1
then Just EQ
else if m0 /= m1
then Nothing
else Just (if x0 == x1
then compare n0 n1
else compare x1 x0)
duration_compare_meq_err :: Duration -> Duration -> Ordering
duration_compare_meq_err p =
let err = error "duration_compare_meq_err: non-equal multipliers"
in fromMaybe err . duration_compare_meq p
instance Ord Duration where
compare = duration_compare_meq_err
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)
| x0 == x1 * 4 &&
n0 == 0 &&
n1 == 2 = Just (Duration (x1 `div` 2) 0 1)
| x0 == x1 * 2 &&
n0 == 1 &&
n1 == 0 = Just (Duration x1 2 1)
| otherwise = Nothing
sum_dur :: Duration -> Duration -> Maybe Duration
sum_dur y0 y1 =
let f (x0,x1) = 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)
in join (fmap f (T.sort_pair_m duration_compare_meq (y0,y1)))
sum_dur_err :: Duration -> Duration -> Duration
sum_dur_err y0 y1 =
let y2 = sum_dur y0 y1
err = error ("sum_dur': " ++ show (y0,y1))
in fromMaybe err y2
divisions_set :: [Integer]
divisions_set = [0,1,2,4,8,16,32,64,128,256]
duration_set :: Integer -> [Duration]
duration_set k = [Duration dv dt 1 | dv <- divisions_set, dt <- [0..k]]
beam_count_tbl :: [(Integer,Integer)]
beam_count_tbl = zip (1 : divisions_set) [0,0,0,0,0,1,2,3,4,5,6]
whole_note_division_to_beam_count :: Integer -> Maybe Integer
whole_note_division_to_beam_count x = lookup x beam_count_tbl
duration_beam_count :: Duration -> Integer
duration_beam_count (Duration x _ _) =
let err = error "duration_beam_count"
bc = whole_note_division_to_beam_count x
in fromMaybe err bc
division_musicxml_tbl :: [(Integer,String)]
division_musicxml_tbl =
let nm = ["long","breve","whole","half","quarter","eighth"
,"16th","32nd","64th","128th","256th"]
in zip (1 : divisions_set) nm
whole_note_division_to_musicxml_type :: Integer -> String
whole_note_division_to_musicxml_type x =
T.lookup_err_msg "division_musicxml_tbl" x division_musicxml_tbl
duration_to_musicxml_type :: Duration -> String
duration_to_musicxml_type = whole_note_division_to_musicxml_type . division
division_unicode_tbl :: [(Integer,Char)]
division_unicode_tbl = zip [0,1,2,4,8,16,32,64,128,256] "𝅜𝅝𝅗𝅥𝅘𝅥𝅘𝅥𝅮𝅘𝅥𝅯𝅘𝅥𝅰𝅘𝅥𝅱𝅘𝅥𝅲"
whole_note_division_to_unicode_symbol :: Integer -> Char
whole_note_division_to_unicode_symbol x =
T.lookup_err_msg "division_unicode_tbl" x division_unicode_tbl
duration_to_unicode :: Duration -> String
duration_to_unicode (Duration dv d _) =
let dv' = whole_note_division_to_unicode_symbol dv
in dv' : replicate (fromIntegral d) '𝅭'
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) '.'
duration_recip_pp :: Duration -> String
duration_recip_pp (Duration x d m) =
let (mn,md) = (numerator m,denominator m)
r = (x % mn) * (md % 1)
in if denominator r == 1
then show (numerator r) ++ genericReplicate d '.'
else error (show ("duration_recip_pp",x,d,m,r))
whole_note_division_letter_pp :: Integer -> Maybe Char
whole_note_division_letter_pp x =
let t = [(16,'s'),(8,'e'),(4,'q'),(2,'h'),(1,'w')]
in lookup x t
duration_letter_pp :: Duration -> Maybe String
duration_letter_pp (Duration x d m) =
let d' = genericReplicate d '\''
m' = case (numerator m,denominator m) of
(1,1) -> ""
(1,i) -> '/' : show i
(i,j) -> '*' : show i ++ "/" ++ show j
in case whole_note_division_letter_pp x of
Just x' -> Just (x' : d' ++ m')
_ -> Nothing