module Music.Theory.Duration.Annotation where
import Data.Maybe
import Data.Ratio
import qualified Data.Traversable as T
import Data.Tree
import Music.Theory.Duration
import Music.Theory.Duration.RQ
data D_Annotation = Tie_Right
| Tie_Left
| Begin_Tuplet (Integer,Integer,Duration)
| End_Tuplet
deriving (Eq,Show)
type Duration_A = (Duration,[D_Annotation])
begin_tuplet :: D_Annotation -> Maybe (Integer,Integer,Duration)
begin_tuplet a =
case a of
Begin_Tuplet t -> Just t
_ -> Nothing
da_begin_tuplet :: Duration_A -> Maybe (Integer,Integer,Duration)
da_begin_tuplet (_,a) =
case mapMaybe begin_tuplet a of
[t] -> Just t
_ -> Nothing
begins_tuplet :: D_Annotation -> Bool
begins_tuplet a =
case a of
Begin_Tuplet _ -> True
_ -> False
da_begins_tuplet :: Duration_A -> Bool
da_begins_tuplet (_,a) = any begins_tuplet a
da_ends_tuplet :: Duration_A -> Bool
da_ends_tuplet (_,a) = End_Tuplet `elem` a
da_tied_right :: Duration_A -> Bool
da_tied_right = elem Tie_Right . snd
da_tuplet :: (Integer,Integer) -> [Duration_A] -> [Duration_A]
da_tuplet (d,n) x =
let fn (p,q) = (p {multiplier = n%d},q)
k = sum (map (duration_to_rq . fst) x) / (d%1)
ty = rq_to_duration_err (show ("da_tuplet",d,n,x,k)) k
t0 = [Begin_Tuplet (d,n,ty)]
ts = [t0] ++ replicate (length x 2) [] ++ [[End_Tuplet]]
jn (p,q) z = (p,q++z)
in zipWith jn (map fn x) ts
begin_end_cmp :: (t -> Bool) -> (t -> Bool) -> t -> Ordering
begin_end_cmp f g x = if f x then LT else if g x then GT else EQ
begin_end_cmp_eq :: Eq t => t -> t -> t -> Ordering
begin_end_cmp_eq p q = begin_end_cmp (== p) (== q)
group_tree :: (a -> Ordering) -> [a] -> Tree (Maybe a)
group_tree f =
let unit e = Node (Just e) []
nil = Node Nothing []
insert_e (Node t l) e = Node t (e:l)
reverse_n (Node t l) = Node t (reverse l)
push (r,z) e = case z of
h:z' -> (r,insert_e h (unit e) : z')
[] -> (unit e : r,[])
open (r,z) = (r,nil:z)
close (r,z) = case z of
h0:h1:z' -> (r,insert_e h1 (reverse_n h0) : z')
h:z' -> (reverse_n h : r,z')
[] -> (r,z)
go st x =
case x of
[] -> Node Nothing (reverse (fst st))
e:x' -> case f e of
LT -> go (push (open st) e) x'
EQ -> go (push st e) x'
GT -> go (close (push st e)) x'
in go ([],[])
da_group_tuplets :: [Duration_A] -> Tree (Maybe Duration_A)
da_group_tuplets =
let f = begin_end_cmp da_begins_tuplet da_ends_tuplet
in group_tree f
break_left :: (a -> Bool) -> [a] -> ([a], [a])
break_left f x =
let (p,q) = break f x
in case q of
[] -> (p,q)
i:j -> (p++[i],j)
sep_balanced :: Bool -> (a -> Bool) -> (a -> Bool) -> [a] -> ([a], [a])
sep_balanced u f g =
let go n x =
case x of
[] -> ([],[])
p:q -> let n' = if f p then n + 1 else n
r = g p
n'' = if r then n' 1 else n'
in if r && n'' == 0
then ([p],q)
else let (i,j) = go n'' q in (p:i,j)
in go (fromEnum u)
da_group_tuplets_nn :: [Duration_A] -> [Either Duration_A [Duration_A]]
da_group_tuplets_nn x =
case x of
[] -> []
d:x' -> if da_begins_tuplet d
then let f = sep_balanced True da_begins_tuplet da_ends_tuplet
(t,x'') = f x'
in Right (d : t) : da_group_tuplets_nn x''
else Left d : da_group_tuplets_nn x'
zip_with_kr :: (a -> b -> c) -> [a] -> [b] -> ([c],[b])
zip_with_kr f =
let go r p q =
case (p,q) of
(i:p',j:q') -> go (f i j : r) p' q'
_ -> (reverse r,q)
in go []
zip_kr :: [a] -> [b] -> ([(a,b)],[b])
zip_kr = zip_with_kr (,)
nn_reshape :: (a -> b -> c) -> [Either a [a]] -> [b] -> [Either c [c]]
nn_reshape f p q =
case (p,q) of
(e:p',i:q') -> case e of
Left j -> Left (f j i) : nn_reshape f p' q'
Right j -> let (j',q'') = zip_with_kr f j q
in Right j' : nn_reshape f p' q''
_ -> []
adopt_shape :: T.Traversable t => (a -> b -> c) -> [b] -> t a -> t c
adopt_shape jn l =
let f (i:j) k = (j,jn k i)
f [] _ = error "adopt_shape: rhs ends"
in snd . T.mapAccumL f l
adopt_shape_m :: T.Traversable t => (a -> b-> c) -> [b] -> t (Maybe a) -> t (Maybe c)
adopt_shape_m jn l =
let f (i:j) k = case k of
Nothing -> (i:j,Nothing)
Just k' -> (j,Just (jn k' i))
f [] _ = error "adopt_shape_m: rhs ends"
in snd . T.mapAccumL f l
d_annotated_tied_lr :: [D_Annotation] -> (Bool,Bool)
d_annotated_tied_lr a = (Tie_Left `elem` a,Tie_Right `elem` a)
duration_a_tied_lr :: Duration_A -> (Bool,Bool)
duration_a_tied_lr (_,a) = d_annotated_tied_lr a