module Music.Theory.Duration.Sequence.Notate
(Duration_A
,notate
,ascribe
,group_boundary) where
import Data.List
import Data.Ratio
import Music.Theory.Duration
debug :: (Show a) => a -> x -> x
debug _ x = x
type R = Rational
type D = (R,R,Bool,Bool)
type Duration_A = (Duration,[D_Annotation])
d_duration :: D -> R
d_duration (_,x,_,_) = x
da_tied_right :: Duration_A -> Bool
da_tied_right = elem Tie_Right . snd
integrate :: (Num a) => [a] -> [a]
integrate [] = []
integrate (x:xs) =
let fn i c = (i + c, i + c)
in x : snd (mapAccumL fn x xs)
step_dur :: (Ord a, Num a) => [a] -> a -> ([a], [a])
step_dur [] _ = error "step_dur: no boundaries"
step_dur _ 0 = error "step_dur: zero duration"
step_dur (x:xs) d =
let jn a (a',b) = (a:a',b)
in case compare d x of
EQ -> ([d],xs)
LT -> ([d],(xd):xs)
GT -> jn x (step_dur xs (d x))
boundaries :: (Num a, Ord a) => [a] -> [a] -> [[a]]
boundaries =
let go [] _ = []
go _ [] = []
go xs (d:ds) =
let (d',xs') = step_dur xs d
in d' : go xs' ds
in go
with_start_times :: (Num a) => a -> [a] -> [(a,a)]
with_start_times i xs =
let is = map (+i) (0 : integrate xs)
in zip is xs
with_start_times' :: (Num a) => [[a]] -> [[(a, a)]]
with_start_times' xs =
let is = 0 : integrate (map sum xs)
in zipWith with_start_times is xs
start_middle_end :: [x] -> (x,[x],x)
start_middle_end xs =
case xs of
(_:_:_) -> let n = length xs
x0 = xs !! 0
xn = xs !! (n 1)
in (x0,take (n 2) (drop 1 xs),xn)
_ -> error "start_middle_end: list must have at least two elements"
tied_r_to_d :: [(R,R)] -> [D]
tied_r_to_d xs =
case xs of
[] -> []
[(s,d)] -> [(s,d,False,False)]
_ -> let ((s0,d0),xs',(sn,dn)) = start_middle_end xs
f (s,d) = (s,d,True,True)
in (s0,d0,False,True) : map f xs' ++ [(sn,dn,True,False)]
boundaries_d :: [R] -> [R] -> [D]
boundaries_d xs ds =
let bs = boundaries xs ds
in concatMap tied_r_to_d (with_start_times' bs)
r_mod :: R -> R -> R
r_mod i j
| i == j = 0
| i < 0 = r_mod (i + j) j
| i > j = r_mod (i j) j
| otherwise = i
sep_unrep :: R -> R -> Maybe (R,R)
sep_unrep i x =
let i' = denominator i == 1
j = case numerator x of
5 -> Just (1,4)
7 -> Just (3,4)
_ -> Nothing
f (n,m) = (n % denominator x,m % denominator x)
swap (a,b) = (b,a)
in case j of
Nothing -> Nothing
Just j' -> Just (f (if i' then swap j' else j'))
sep_unrep_d :: D -> [D]
sep_unrep_d d =
let (i,x,l,r) = d
in case sep_unrep i x of
Nothing -> [d]
Just (x0,x1) -> [(i,x0,l,True),(i+x0,x1,True,r)]
separate :: [R] -> [R] -> [D]
separate ns = concatMap sep_unrep_d . boundaries_d ns
group_boundary :: (a -> R) -> [R] -> [a] -> [[a]]
group_boundary dur_f =
let go _ [] [] _ = []
go _ _ [] _ = error "group_boundary: no boundaries?"
go _ js _ [] = [reverse js]
go _ js _ [x] = [reverse (x:js)]
go c js (n:ns) (x:xs) =
let c' = c + dur_f x
in case compare c' n of
EQ -> reverse (x:js) : go 0 [] ns xs
LT -> go c' (x:js) (n:ns) xs
GT -> let c'' = c' n
in if c'' `divisible_by` n
then reverse (x:js) : go 0 [] ns xs
else go c'' (x:js) ns xs
in go 0 []
group_boundary_d :: [R] -> [D] -> [[D]]
group_boundary_d = group_boundary d_duration
derive_tuplet :: [D] -> Maybe (Integer,Integer)
derive_tuplet xs =
let xs' = map d_duration xs
i = maximum (map denominator xs')
smpl n = if even n then smpl (n `div` 2) else n
i' = smpl i
j = case i' of
3 -> (3,2)
5 -> (5,4)
7 -> (7,4)
9 -> (9,8)
_ -> error ("derive_tuplet: " ++ show (i,i'))
in if i' == 1
then Nothing
else Just j
un_tuplet :: (Integer,Integer) -> R -> R
un_tuplet (i,j) x = x * (i%j)
d_join_aligned :: D -> D -> Maybe D
d_join_aligned (s1,x1,l1,r1) (_,x2,_,r2)
| (x1 == (1%4) && r1 && x2 `elem` [1%4,1%2,3%4]) ||
(x1 == (1%2) && r1 && x2 `elem` [1%4,1%2,1,3%2]) ||
(x1 == 1 && r1 && x2 `elem` [1%2,1,2]) ||
(x1 == (3%2) && r1 && x2 `elem` [1%2,3%2]) ||
(x1 == 2 && r1 && x2 `elem` [1,2]) = debug ("aligned-join",s1,x1,x2) (Just (s1,x1+x2,l1,r2))
| otherwise = debug ("aligned-no-join",s1,x1,r1,x2) Nothing
divisible_by :: R -> R -> Bool
divisible_by i j = denominator (i / j) == 1
d_join :: R -> D -> D -> Maybe D
d_join a (s1,x1,l1,r1) (s2,x2,l2,r2)
| s1 `divisible_by` a = d_join_aligned (s1,x1,l1,r1) (s2,x2,l2,r2)
| denominator (s1 `r_mod` 1) == 4 &&
x1 == 1%4 &&
r1 &&
x2 == 1%4 &&
not (s2 `divisible_by` a) =
debug ("non-aligned-join",a,s1,x1) (Just (s1,x1+x2,l1,r2))
| s1 `r_mod` 1 == 2%3 &&
x1 == 1%3 &&
r1 &&
x2 == 1%3 =
debug ("non-aligned-join",a,s1,x1) (Just (s1,x1+x2,l1,r2))
| otherwise = debug ("non-aligned-no-join",a,s1,x1) Nothing
coalesce :: (a -> a -> Maybe a) -> [a] -> [a]
coalesce f xs =
case xs of
(x1:x2:xs') -> case f x1 x2 of
Nothing -> x1 : coalesce f (x2:xs')
Just x' -> coalesce f (x':xs')
_ -> xs
simplify :: R -> [R] -> [D] -> [D]
simplify a ns xs =
let xs' = group_boundary_d ns xs
pass :: [[D]] -> [[D]]
pass = map (coalesce (d_join a))
in concat ((pass . pass) xs')
to_duration :: Show a => a -> R -> Duration
to_duration msg n =
let err = error ("to_duration:" ++ show (msg,n))
in maybe err id (rq_to_duration n)
tuplet :: (Integer,Integer) -> [Duration] -> [Duration_A]
tuplet (d,n) xs =
let fn x = x { multiplier = n%d }
xn = length xs
(Just ty) = rq_to_duration (sum (map duration_to_rq xs) / (d%1))
t0 = [Begin_Tuplet (d,n,ty)]
ts = [t0] ++ replicate (xn 2) [] ++ [[End_Tuplet]]
in zip (map fn xs) ts
notate_sec :: [D] -> [Duration_A]
notate_sec xs =
let ds = map d_duration xs
add_ties_from (_,_,l,r) (d,fs) =
let l' = if l then [Tie_Left] else []
r' = if r then [Tie_Right] else []
in (d,l' ++ r' ++ fs)
xs' = case derive_tuplet xs of
Nothing -> let f = to_duration ("no-tuplet",ds)
in map (\d -> (f d,[])) ds
Just t -> let f = to_duration ("tuplet",t,ds)
(d0:dN) = ds
in if denominator d0 == 2
then (f d0,[]) : tuplet t (map (f . un_tuplet t) dN)
else tuplet t (map (f . un_tuplet t) ds)
in zipWith add_ties_from xs xs'
notate :: [R] -> [R] -> [R] -> [Duration_A]
notate is ns xs =
let xs' = simplify (head is) ns (separate is xs)
in concatMap notate_sec (group_boundary_d is xs')
ascribe_fn :: (x -> Bool) -> [x] -> [a] -> [(x,a)]
ascribe_fn fn =
let go [] _ = []
go _ [] = error "ascribe_fn"
go (x:xs) (i:is) = let is' = if fn x then (i:is) else is
in (x,i) : go xs is'
in go
ascribe :: [Duration_A] -> [x] -> [(Duration_A,x)]
ascribe = ascribe_fn da_tied_right