-- | Duration annotations.
module Music.Theory.Duration.Annotation where

import Data.Maybe {- base -}
import Data.Ratio {- base -}
import Data.Tree {- containers -}

import qualified Music.Theory.List as L {- hmt-base -}

import Music.Theory.Duration
import Music.Theory.Duration.Rq

-- | Standard music notation durational model annotations
data D_Annotation = Tie_Right
                  | Tie_Left
                  | Begin_Tuplet (Integer,Integer,Duration)
                  | End_Tuplet
                    deriving (D_Annotation -> D_Annotation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: D_Annotation -> D_Annotation -> Bool
$c/= :: D_Annotation -> D_Annotation -> Bool
== :: D_Annotation -> D_Annotation -> Bool
$c== :: D_Annotation -> D_Annotation -> Bool
Eq,Int -> D_Annotation -> ShowS
[D_Annotation] -> ShowS
D_Annotation -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [D_Annotation] -> ShowS
$cshowList :: [D_Annotation] -> ShowS
show :: D_Annotation -> String
$cshow :: D_Annotation -> String
showsPrec :: Int -> D_Annotation -> ShowS
$cshowsPrec :: Int -> D_Annotation -> ShowS
Show)

-- | Annotated 'Duration'.
type Duration_A = (Duration,[D_Annotation])

begin_tuplet :: D_Annotation -> Maybe (Integer,Integer,Duration)
begin_tuplet :: D_Annotation -> Maybe (Integer, Integer, Duration)
begin_tuplet D_Annotation
a =
    case D_Annotation
a of
      Begin_Tuplet (Integer, Integer, Duration)
t -> forall a. a -> Maybe a
Just (Integer, Integer, Duration)
t
      D_Annotation
_ -> forall a. Maybe a
Nothing

da_begin_tuplet :: Duration_A -> Maybe (Integer,Integer,Duration)
da_begin_tuplet :: Duration_A -> Maybe (Integer, Integer, Duration)
da_begin_tuplet (Duration
_,[D_Annotation]
a) =
    case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe D_Annotation -> Maybe (Integer, Integer, Duration)
begin_tuplet [D_Annotation]
a of
      [(Integer, Integer, Duration)
t] -> forall a. a -> Maybe a
Just (Integer, Integer, Duration)
t
      [(Integer, Integer, Duration)]
_ -> forall a. Maybe a
Nothing

begins_tuplet :: D_Annotation -> Bool
begins_tuplet :: D_Annotation -> Bool
begins_tuplet D_Annotation
a =
    case D_Annotation
a of
      Begin_Tuplet (Integer, Integer, Duration)
_ -> Bool
True
      D_Annotation
_ -> Bool
False

-- | Does 'Duration_A' begin a tuplet?
da_begins_tuplet :: Duration_A -> Bool
da_begins_tuplet :: Duration_A -> Bool
da_begins_tuplet (Duration
_,[D_Annotation]
a) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any D_Annotation -> Bool
begins_tuplet [D_Annotation]
a

-- | Does 'Duration_A' end a tuplet?
da_ends_tuplet :: Duration_A -> Bool
da_ends_tuplet :: Duration_A -> Bool
da_ends_tuplet (Duration
_,[D_Annotation]
a) = D_Annotation
End_Tuplet forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [D_Annotation]
a

-- | Is 'Duration_A' tied to the the right?
da_tied_right :: Duration_A -> Bool
da_tied_right :: Duration_A -> Bool
da_tied_right = forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem D_Annotation
Tie_Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd

-- | Annotate a sequence of 'Duration_A' as a tuplet.
--
-- > import Music.Theory.Duration.Name
-- > da_tuplet (3,2) [(quarter_note,[Tie_Left]),(eighth_note,[Tie_Right])]
da_tuplet :: (Integer,Integer) -> [Duration_A] -> [Duration_A]
da_tuplet :: (Integer, Integer) -> [Duration_A] -> [Duration_A]
da_tuplet (Integer
d,Integer
n) [Duration_A]
x =
    let fn :: (Duration, b) -> (Duration, b)
fn (Duration
p,b
q) = (Duration
p {multiplier :: Rational
multiplier = Integer
nforall a. Integral a => a -> a -> Ratio a
%Integer
d},b
q)
        k :: Rational
k = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map (Duration -> Rational
duration_to_rq forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [Duration_A]
x) forall a. Fractional a => a -> a -> a
/ (Integer
dforall a. Integral a => a -> a -> Ratio a
%Integer
1)
        ty :: Duration
ty = forall a. Show a => a -> Int -> Rational -> Duration
rq_to_duration_err (forall a. Show a => a -> String
show (String
"da_tuplet",Integer
d,Integer
n,[Duration_A]
x,Rational
k)) Int
2 Rational
k
        t0 :: [D_Annotation]
t0 = [(Integer, Integer, Duration) -> D_Annotation
Begin_Tuplet (Integer
d,Integer
n,Duration
ty)]
        ts :: [[D_Annotation]]
ts = [[D_Annotation]
t0] forall a. [a] -> [a] -> [a]
++ forall a. Int -> a -> [a]
replicate (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Duration_A]
x forall a. Num a => a -> a -> a
- Int
2) [] forall a. [a] -> [a] -> [a]
++ [[D_Annotation
End_Tuplet]]
        jn :: (a, [a]) -> [a] -> (a, [a])
jn (a
p,[a]
q) [a]
z = (a
p,[a]
qforall a. [a] -> [a] -> [a]
++[a]
z)
    in forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a} {a}. (a, [a]) -> [a] -> (a, [a])
jn (forall a b. (a -> b) -> [a] -> [b]
map forall {b}. (Duration, b) -> (Duration, b)
fn [Duration_A]
x) [[D_Annotation]]
ts

-- | Group tuplets into a 'Tree'.  Branch nodes have label 'Nothing',
-- leaf nodes label 'Just' 'Duration_A'.
--
-- > import Music.Theory.Duration.Name.Abbreviation
--
-- > let d = [(q,[])
-- >         ,(e,[Begin_Tuplet (3,2,e)])
-- >         ,(s,[Begin_Tuplet (3,2,s)]),(s,[]),(s,[End_Tuplet])
-- >         ,(e,[End_Tuplet])
-- >         ,(q,[])]
-- > in catMaybes (flatten (da_group_tuplets d)) == d
da_group_tuplets :: [Duration_A] -> Tree (Maybe Duration_A)
da_group_tuplets :: [Duration_A] -> Tree (Maybe Duration_A)
da_group_tuplets = forall a. (a -> Bool, a -> Bool) -> [a] -> Tree (Maybe a)
L.group_tree (Duration_A -> Bool
da_begins_tuplet,Duration_A -> Bool
da_ends_tuplet)

-- | Variant of 'break' that places separator at left.
--
-- > break_left (== 3) [1..6] == ([1..3],[4..6])
-- > break_left (== 3) [1..3] == ([1..3],[])
break_left :: (a -> Bool) -> [a] -> ([a], [a])
break_left :: forall a. (a -> Bool) -> [a] -> ([a], [a])
break_left a -> Bool
f [a]
x =
    let ([a]
p,[a]
q) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break a -> Bool
f [a]
x
    in case [a]
q of
         [] -> ([a]
p,[a]
q)
         a
i:[a]
j -> ([a]
pforall a. [a] -> [a] -> [a]
++[a
i],[a]
j)

-- | Variant of 'break_left' that balances begin & end predicates.
--
-- > break_left (== ')') "test (sep) _) balanced"
-- > sep_balanced True (== '(') (== ')') "test (sep) _) balanced"
-- > sep_balanced False (== '(') (== ')') "(test (sep) _) balanced"
sep_balanced :: Bool -> (a -> Bool) -> (a -> Bool) -> [a] -> ([a], [a])
sep_balanced :: forall a. Bool -> (a -> Bool) -> (a -> Bool) -> [a] -> ([a], [a])
sep_balanced Bool
u a -> Bool
f a -> Bool
g =
    let go :: a -> [a] -> ([a], [a])
go a
n [a]
x =
            case [a]
x of
              [] -> ([],[])
              a
p:[a]
q -> let n' :: a
n' = if a -> Bool
f a
p then a
n forall a. Num a => a -> a -> a
+ a
1 else a
n
                         r :: Bool
r = a -> Bool
g a
p
                         n'' :: a
n'' = if Bool
r then a
n' forall a. Num a => a -> a -> a
- a
1 else a
n'
                     in if Bool
r Bool -> Bool -> Bool
&& a
n'' forall a. Eq a => a -> a -> Bool
== a
0
                        then ([a
p],[a]
q)
                        else let ([a]
i,[a]
j) = a -> [a] -> ([a], [a])
go a
n'' [a]
q in (a
pforall a. a -> [a] -> [a]
:[a]
i,[a]
j)
    in forall {a}. (Eq a, Num a) => a -> [a] -> ([a], [a])
go (forall a. Enum a => a -> Int
fromEnum Bool
u)

-- | Group non-nested tuplets, ie. groups nested tuplets at one level.
da_group_tuplets_nn :: [Duration_A] -> [Either Duration_A [Duration_A]]
da_group_tuplets_nn :: [Duration_A] -> [Either Duration_A [Duration_A]]
da_group_tuplets_nn [Duration_A]
x =
    case [Duration_A]
x of
      [] -> []
      Duration_A
d:[Duration_A]
x' -> if Duration_A -> Bool
da_begins_tuplet Duration_A
d
              then let f :: [Duration_A] -> ([Duration_A], [Duration_A])
f = forall a. Bool -> (a -> Bool) -> (a -> Bool) -> [a] -> ([a], [a])
sep_balanced Bool
True Duration_A -> Bool
da_begins_tuplet Duration_A -> Bool
da_ends_tuplet
                       ([Duration_A]
t,[Duration_A]
x'') = [Duration_A] -> ([Duration_A], [Duration_A])
f [Duration_A]
x'
                   in forall a b. b -> Either a b
Right (Duration_A
d forall a. a -> [a] -> [a]
: [Duration_A]
t) forall a. a -> [a] -> [a]
: [Duration_A] -> [Either Duration_A [Duration_A]]
da_group_tuplets_nn [Duration_A]
x''
              else forall a b. a -> Either a b
Left Duration_A
d forall a. a -> [a] -> [a]
: [Duration_A] -> [Either Duration_A [Duration_A]]
da_group_tuplets_nn [Duration_A]
x'

-- | Keep right variant of 'zip', unused rhs values are returned.
--
-- > zip_kr [1..4] ['a'..'f'] == ([(1,'a'),(2,'b'),(3,'c'),(4,'d')],"ef")
zip_kr :: [a] -> [b] -> ([(a,b)],[b])
zip_kr :: forall a b. [a] -> [b] -> ([(a, b)], [b])
zip_kr = forall a b c. (a -> b -> c) -> [a] -> [b] -> ([c], [b])
L.zip_with_kr (,)

-- | 'zipWith' variant that adopts the shape of the lhs.
--
-- > let {p = [Left 1,Right [2,3],Left 4]
-- >     ;q = "abcd"}
-- > in nn_reshape (,) p q == [Left (1,'a'),Right [(2,'b'),(3,'c')],Left (4,'d')]
nn_reshape :: (a -> b -> c) -> [Either a [a]] -> [b] -> [Either c [c]]
nn_reshape :: forall a b c.
(a -> b -> c) -> [Either a [a]] -> [b] -> [Either c [c]]
nn_reshape a -> b -> c
f [Either a [a]]
p [b]
q =
    case ([Either a [a]]
p,[b]
q) of
      (Either a [a]
e:[Either a [a]]
p',b
i:[b]
q') -> case Either a [a]
e of
                       Left a
j -> forall a b. a -> Either a b
Left (a -> b -> c
f a
j b
i) forall a. a -> [a] -> [a]
: forall a b c.
(a -> b -> c) -> [Either a [a]] -> [b] -> [Either c [c]]
nn_reshape a -> b -> c
f [Either a [a]]
p' [b]
q'
                       Right [a]
j -> let ([c]
j',[b]
q'') = forall a b c. (a -> b -> c) -> [a] -> [b] -> ([c], [b])
L.zip_with_kr a -> b -> c
f [a]
j [b]
q
                                  in forall a b. b -> Either a b
Right [c]
j' forall a. a -> [a] -> [a]
: forall a b c.
(a -> b -> c) -> [Either a [a]] -> [b] -> [Either c [c]]
nn_reshape a -> b -> c
f [Either a [a]]
p' [b]
q''
      ([Either a [a]], [b])
_ -> []

-- | Does /a/ have 'Tie_Left' and 'Tie_Right'?
d_annotated_tied_lr :: [D_Annotation] -> (Bool,Bool)
d_annotated_tied_lr :: [D_Annotation] -> (Bool, Bool)
d_annotated_tied_lr [D_Annotation]
a = (D_Annotation
Tie_Left forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [D_Annotation]
a,D_Annotation
Tie_Right forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [D_Annotation]
a)

-- | Does /d/ have 'Tie_Left' and 'Tie_Right'?
duration_a_tied_lr :: Duration_A -> (Bool,Bool)
duration_a_tied_lr :: Duration_A -> (Bool, Bool)
duration_a_tied_lr (Duration
_,[D_Annotation]
a) = [D_Annotation] -> (Bool, Bool)
d_annotated_tied_lr [D_Annotation]
a