-- | Notation of a sequence of 'Rq' values as annotated 'Duration' values.
--
-- 1. Separate input sequence into measures, adding tie annotations as
-- required (see 'to_measures_ts').  Ensure all 'Rq_Tied' values can be
-- notated as /common music notation/ durations.
--
-- 2. Separate each measure into pulses (see 'm_divisions_ts').
-- Further subdivides pulses to ensure /cmn/ tuplet notation.  See
-- 'to_divisions_ts' for a composition of 'to_measures_ts' and
-- 'm_divisions_ts'.
--
-- 3. Simplify each measure (see 'm_simplify' and 'default_rule').
-- Coalesces tied durations where appropriate.
--
-- 4. Notate measures (see 'm_notate' or 'mm_notate').
--
-- 5. Ascribe values to notated durations, see 'ascribe'.
module Music.Theory.Duration.Sequence.Notate where

import Data.List {- base -}
import Data.List.Split {- split -}
import Data.Maybe {- base -}
import Data.Ratio {- base -}

import Music.Theory.Either {- hmt-base -}
import Music.Theory.Function {- hmt-base -}
import Music.Theory.List {- hmt-base -}

import Music.Theory.Duration {- hmt -}
import Music.Theory.Duration.Annotation {- hmt -}
import Music.Theory.Duration.Rq {- hmt -}
import Music.Theory.Duration.Rq.Tied {- hmt -}
import Music.Theory.Time_Signature {- hmt -}

-- * Lists

{- | Applies a /join/ function to the first two elements of the list.
     If the /join/ function succeeds the joined element is considered for further coalescing.

> coalesce (\p q -> Just (p + q)) [1..5] == [15]

> let jn p q = if even p then Just (p + q) else Nothing
> coalesce jn [1..5] == map sum [[1],[2,3],[4,5]]
-}
coalesce :: (a -> a -> Maybe a) -> [a] -> [a]
coalesce :: forall a. (a -> a -> Maybe a) -> [a] -> [a]
coalesce a -> a -> Maybe a
f [a]
x =
    case [a]
x of
      (a
p:a
q:[a]
x') ->
          case a -> a -> Maybe a
f a
p a
q of
            Maybe a
Nothing -> a
p forall a. a -> [a] -> [a]
: forall a. (a -> a -> Maybe a) -> [a] -> [a]
coalesce a -> a -> Maybe a
f (a
q forall a. a -> [a] -> [a]
: [a]
x')
            Just a
r -> forall a. (a -> a -> Maybe a) -> [a] -> [a]
coalesce a -> a -> Maybe a
f (a
r forall a. a -> [a] -> [a]
: [a]
x')
      [a]
_ -> [a]
x

-- | Variant of 'coalesce' with accumulation parameter.
--
-- > coalesce_accum (\_ p q -> Left (p + q)) 0 [1..5] == [(0,15)]
--
-- > let jn i p q = if even p then Left (p + q) else Right (p + i)
-- > coalesce_accum jn 0 [1..7] == [(0,1),(1,5),(6,9),(15,13)]
--
-- > let jn i p q = if even p then Left (p + q) else Right [p,q]
-- > coalesce_accum jn [] [1..5] == [([],1),([1,2],5),([5,4],9)]
coalesce_accum :: (b -> a -> a -> Either a b) -> b -> [a] -> [(b,a)]
coalesce_accum :: forall b a. (b -> a -> a -> Either a b) -> b -> [a] -> [(b, a)]
coalesce_accum b -> a -> a -> Either a b
f b
i [a]
x =
    case [a]
x of
      [] -> []
      [a
p] -> [(b
i,a
p)]
      (a
p:a
q:[a]
x') ->
          case b -> a -> a -> Either a b
f b
i a
p a
q of
            Right b
j -> (b
i,a
p) forall a. a -> [a] -> [a]
: forall b a. (b -> a -> a -> Either a b) -> b -> [a] -> [(b, a)]
coalesce_accum b -> a -> a -> Either a b
f b
j (a
q forall a. a -> [a] -> [a]
: [a]
x')
            Left a
r -> forall b a. (b -> a -> a -> Either a b) -> b -> [a] -> [(b, a)]
coalesce_accum b -> a -> a -> Either a b
f b
i (a
r forall a. a -> [a] -> [a]
: [a]
x')

-- | Variant of 'coalesce_accum' that accumulates running sum.
--
-- > let f i p q = if i == 1 then Just (p + q) else Nothing
-- > coalesce_sum (+) 0 f [1,1/2,1/4,1/4] == [1,1]
coalesce_sum :: (b -> a -> b) -> b -> (b -> a -> a -> Maybe a) -> [a] -> [a]
coalesce_sum :: forall b a.
(b -> a -> b) -> b -> (b -> a -> a -> Maybe a) -> [a] -> [a]
coalesce_sum b -> a -> b
add b
zero b -> a -> a -> Maybe a
f =
    let g :: b -> a -> a -> Either a b
g b
i a
p a
q = case b -> a -> a -> Maybe a
f b
i a
p a
q of
                    Just a
r -> forall a b. a -> Either a b
Left a
r
                    Maybe a
Nothing -> forall a b. b -> Either a b
Right (b
i b -> a -> b
`add` a
p)
    in forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. (b -> a -> a -> Either a b) -> b -> [a] -> [(b, a)]
coalesce_accum b -> a -> a -> Either a b
g b
zero

-- * Separate

-- | Take elements while the sum of the prefix is less than or equal
-- to the indicated value.  Returns also the difference between the
-- prefix sum and the requested sum.  Note that zero elements are kept
-- left.
--
-- > take_sum_by id 3 [2,1] == ([2,1],0,[])
-- > take_sum_by id 3 [2,2] == ([2],1,[2])
-- > take_sum_by id 3 [2,1,0,1] == ([2,1,0],0,[1])
-- > take_sum_by id 3 [4] == ([],3,[4])
-- > take_sum_by id 0 [1..5] == ([],0,[1..5])
take_sum_by :: (Ord n, Num n) => (a -> n) -> n -> [a] -> ([a], n, [a])
take_sum_by :: forall n a. (Ord n, Num n) => (a -> n) -> n -> [a] -> ([a], n, [a])
take_sum_by a -> n
f n
m =
    let go :: [a] -> n -> [a] -> ([a], n, [a])
go [a]
r n
n [a]
l =
            let z :: ([a], n, [a])
z = (forall a. [a] -> [a]
reverse [a]
r,n
mforall a. Num a => a -> a -> a
-n
n,[a]
l)
            in case [a]
l of
                 [] -> ([a], n, [a])
z
                 a
i:[a]
l' -> let n' :: n
n' = a -> n
f a
i forall a. Num a => a -> a -> a
+ n
n
                         in if n
n' forall a. Ord a => a -> a -> Bool
> n
m
                            then ([a], n, [a])
z
                            else [a] -> n -> [a] -> ([a], n, [a])
go (a
iforall a. a -> [a] -> [a]
:[a]
r) n
n' [a]
l'
    in [a] -> n -> [a] -> ([a], n, [a])
go [] n
0

-- | Variant of 'take_sum_by' with 'id' function.
take_sum :: (Ord a, Num a) => a -> [a] -> ([a],a,[a])
take_sum :: forall a. (Ord a, Num a) => a -> [a] -> ([a], a, [a])
take_sum = forall n a. (Ord n, Num n) => (a -> n) -> n -> [a] -> ([a], n, [a])
take_sum_by forall a. a -> a
id

-- | Variant of 'take_sum' that requires the prefix to sum to value.
--
-- > take_sum_by_eq id 3 [2,1,0,1] == Just ([2,1,0],[1])
-- > take_sum_by_eq id 3 [2,2] == Nothing
take_sum_by_eq :: (Ord n, Num n) => (a -> n) -> n -> [a] -> Maybe ([a], [a])
take_sum_by_eq :: forall n a.
(Ord n, Num n) =>
(a -> n) -> n -> [a] -> Maybe ([a], [a])
take_sum_by_eq a -> n
f n
m [a]
l =
    case forall n a. (Ord n, Num n) => (a -> n) -> n -> [a] -> ([a], n, [a])
take_sum_by a -> n
f n
m [a]
l of
      ([a]
p,n
0,[a]
q) -> forall a. a -> Maybe a
Just ([a]
p,[a]
q)
      ([a], n, [a])
_ -> forall a. Maybe a
Nothing

-- | Recursive variant of 'take_sum_by_eq'.
--
-- > split_sum_by_eq id [3,3] [2,1,0,3] == Just [[2,1,0],[3]]
-- > split_sum_by_eq id [3,3] [2,2,2] == Nothing
split_sum_by_eq :: (Ord n, Num n) => (a -> n) -> [n] -> [a] -> Maybe [[a]]
split_sum_by_eq :: forall n a. (Ord n, Num n) => (a -> n) -> [n] -> [a] -> Maybe [[a]]
split_sum_by_eq a -> n
f [n]
mm [a]
l =
    case ([n]
mm,[a]
l) of
      ([],[]) -> forall a. a -> Maybe a
Just []
      (n
m:[n]
mm',[a]
_) -> case forall n a.
(Ord n, Num n) =>
(a -> n) -> n -> [a] -> Maybe ([a], [a])
take_sum_by_eq a -> n
f n
m [a]
l of
                     Just ([a]
p,[a]
l') -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([a]
p forall a. a -> [a] -> [a]
:) (forall n a. (Ord n, Num n) => (a -> n) -> [n] -> [a] -> Maybe [[a]]
split_sum_by_eq a -> n
f [n]
mm' [a]
l')
                     Maybe ([a], [a])
Nothing -> forall a. Maybe a
Nothing
      ([n], [a])
_ -> forall a. Maybe a
Nothing

{- | Split sequence /l/ such that the prefix sums to precisely /m/.
     The third element of the result indicates if it was required to divide an element.
     Note that zero elements are kept left.
     If the required sum is non positive, or the input list does not sum to at least the required sum, gives nothing.

> split_sum 5 [2,3,1] == Just ([2,3],[1],Nothing)
> split_sum 5 [2,1,3] == Just ([2,1,2],[1],Just (2,1))
> split_sum 2 [3/2,3/2,3/2] == Just ([3/2,1/2],[1,3/2],Just (1/2,1))
> split_sum 6 [1..10] == Just ([1..3],[4..10],Nothing)
> fmap (\(a,_,c)->(a,c)) (split_sum 5 [1..]) == Just ([1,2,2],Just (2,1))
> split_sum 0 [1..] == Nothing
> split_sum 3 [1,1] == Nothing
> split_sum 3 [2,1,0] == Just ([2,1,0],[],Nothing)
> split_sum 3 [2,1,0,1] == Just ([2,1,0],[1],Nothing)
-}
split_sum :: (Ord a, Num a) => a -> [a] -> Maybe ([a],[a],Maybe (a,a))
split_sum :: forall a.
(Ord a, Num a) =>
a -> [a] -> Maybe ([a], [a], Maybe (a, a))
split_sum a
m [a]
l =
    let ([a]
p,a
n,[a]
q) = forall a. (Ord a, Num a) => a -> [a] -> ([a], a, [a])
take_sum a
m [a]
l
    in if a
n forall a. Eq a => a -> a -> Bool
== a
0
       then if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
p
            then forall a. Maybe a
Nothing
            else forall a. a -> Maybe a
Just ([a]
p,[a]
q,forall a. Maybe a
Nothing)
       else case [a]
q of
              [] -> forall a. Maybe a
Nothing
              a
z:[a]
q' -> forall a. a -> Maybe a
Just ([a]
pforall a. [a] -> [a] -> [a]
++[a
n],a
zforall a. Num a => a -> a -> a
-a
nforall a. a -> [a] -> [a]
:[a]
q',forall a. a -> Maybe a
Just (a
n,a
zforall a. Num a => a -> a -> a
-a
n))

{- | Variant of 'split_sum' that operates at 'Rq_Tied' sequences.

> t = True
> f = False

> r = Just ([(3,f),(2,t)],[(1,f)])
> rqt_split_sum 5 [(3,f),(2,t),(1,f)] == r

> r = Just ([(3,f),(1,t)],[(1,t),(1,f)])
> rqt_split_sum 4 [(3,f),(2,t),(1,f)] == r

> rqt_split_sum 4 [(5/2,False)] == Nothing
-}
rqt_split_sum :: Rq -> [Rq_Tied] -> Maybe ([Rq_Tied],[Rq_Tied])
rqt_split_sum :: Rq -> [Rq_Tied] -> Maybe ([Rq_Tied], [Rq_Tied])
rqt_split_sum Rq
d [Rq_Tied]
x =
    case forall a.
(Ord a, Num a) =>
a -> [a] -> Maybe ([a], [a], Maybe (a, a))
split_sum Rq
d (forall a b. (a -> b) -> [a] -> [b]
map Rq_Tied -> Rq
rqt_rq [Rq_Tied]
x) of
      Just ([Rq]
i,[Rq]
_,Maybe (Rq, Rq)
k) ->
          case Maybe (Rq, Rq)
k of
            Maybe (Rq, Rq)
Nothing -> forall a. a -> Maybe a
Just (forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Rq]
i) [Rq_Tied]
x)
            Just (Rq
p,Rq
q) -> let ([Rq_Tied]
s,(Rq
_,Bool
z):[Rq_Tied]
t) = forall a. Int -> [a] -> ([a], [a])
splitAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Rq]
i forall a. Num a => a -> a -> a
- Int
1) [Rq_Tied]
x
                          in forall a. a -> Maybe a
Just ([Rq_Tied]
s forall a. [a] -> [a] -> [a]
++ [(Rq
p,Bool
True)]
                                  ,(Rq
q,Bool
z) forall a. a -> [a] -> [a]
: [Rq_Tied]
t)
      Maybe ([Rq], [Rq], Maybe (Rq, Rq))
Nothing -> forall a. Maybe a
Nothing

{- | Separate 'Rq_Tied' values in sequences summing to 'Rq' values.
    This is a recursive variant of 'rqt_split_sum'.
    Note that is does not ensure /cmn/ notation of values.

> t = True
> f = False

> d = [(2,f),(2,f),(2,f)]
> r = [[(2,f),(1,t)],[(1,f),(2,f)]]
> rqt_separate [3,3] d == Right r

> d = [(5/8,f),(1,f),(3/8,f)]
> r = [[(5/8,f),(3/8,t)],[(5/8,f),(3/8,f)]]
> rqt_separate [1,1] d == Right r

> d = [(4/7,t),(1/7,f),(1,f),(6/7,f),(3/7,f)]
> r = [[(4/7,t),(1/7,f),(2/7,t)],[(5/7,f),(2/7,t)],[(4/7,f),(3/7,f)]]
> rqt_separate [1,1,1] d == Right r
-}
rqt_separate :: [Rq] -> [Rq_Tied] -> Either String [[Rq_Tied]]
rqt_separate :: [Rq] -> [Rq_Tied] -> Either String [[Rq_Tied]]
rqt_separate [Rq]
m [Rq_Tied]
x =
    case ([Rq]
m,[Rq_Tied]
x) of
      ([],[]) -> forall a b. b -> Either a b
Right []
      ([],[Rq_Tied]
_) -> forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show (String
"rqt_separate: lhs empty, rhs non-empty",[Rq_Tied]
x))
      (Rq
i:[Rq]
m',[Rq_Tied]
_) ->
          case Rq -> [Rq_Tied] -> Maybe ([Rq_Tied], [Rq_Tied])
rqt_split_sum Rq
i [Rq_Tied]
x of
            Just ([Rq_Tied]
r,[Rq_Tied]
x') -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Rq_Tied]
r forall a. a -> [a] -> [a]
:) ([Rq] -> [Rq_Tied] -> Either String [[Rq_Tied]]
rqt_separate [Rq]
m' [Rq_Tied]
x')
            Maybe ([Rq_Tied], [Rq_Tied])
Nothing -> forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show (String
"rqt_separate: rqt_split_sum failed",(Rq
i,[Rq_Tied]
x),[Rq]
m'))

-- | Maybe form ot 'rqt_separate'
rqt_separate_m :: [Rq] -> [Rq_Tied] -> Maybe [[Rq_Tied]]
rqt_separate_m :: [Rq] -> [Rq_Tied] -> Maybe [[Rq_Tied]]
rqt_separate_m [Rq]
m = forall a b. Either a b -> Maybe b
either_to_maybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Rq] -> [Rq_Tied] -> Either String [[Rq_Tied]]
rqt_separate [Rq]
m

-- | If the input 'Rq_Tied' sequence cannot be notated (see
-- 'rqt_can_notate') separate into equal parts, so long as each part
-- is not less than /i/.
--
-- > rqt_separate_tuplet undefined [(1/3,f),(1/6,f)]
-- > rqt_separate_tuplet undefined [(4/7,t),(1/7,f),(2/7,f)]
--
-- > let d = map rq_rqt [1/3,1/6,2/5,1/10]
-- > in rqt_separate_tuplet (1/8) d == Right [[(1/3,f),(1/6,f)]
-- >                                         ,[(2/5,f),(1/10,f)]]
--
-- > let d = [(1/5,True),(1/20,False),(1/2,False),(1/4,True)]
-- > in rqt_separate_tuplet (1/16) d
--
-- > let d = [(2/5,f),(1/5,f),(1/5,f),(1/5,t),(1/2,f),(1/2,f)]
-- > in rqt_separate_tuplet (1/2) d
--
-- > let d = [(4/10,True),(1/10,False),(1/2,True)]
-- > in rqt_separate_tuplet (1/2) d
rqt_separate_tuplet :: Rq -> [Rq_Tied] -> Either String [[Rq_Tied]]
rqt_separate_tuplet :: Rq -> [Rq_Tied] -> Either String [[Rq_Tied]]
rqt_separate_tuplet Rq
i [Rq_Tied]
x =
    if Int -> [Rq_Tied] -> Bool
rqt_can_notate Int
2 [Rq_Tied]
x
    then forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show (String
"rqt_separate_tuplet: separation not required",[Rq_Tied]
x))
    else let j :: Rq
j = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map Rq_Tied -> Rq
rqt_rq [Rq_Tied]
x) forall a. Fractional a => a -> a -> a
/ Rq
2
         in if Rq
j forall a. Ord a => a -> a -> Bool
< Rq
i
            then forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show (String
"rqt_separate_tuplet: j < i",Rq
j,Rq
i))
            else [Rq] -> [Rq_Tied] -> Either String [[Rq_Tied]]
rqt_separate [Rq
j,Rq
j] [Rq_Tied]
x

-- | Recursive variant of 'rqt_separate_tuplet'.
--
-- > let d = map rq_rqt [1,1/3,1/6,2/5,1/10]
-- > in rqt_tuplet_subdivide (1/8) d == [[(1/1,f)]
-- >                                    ,[(1/3,f),(1/6,f)]
-- >                                    ,[(2/5,f),(1/10,f)]]
rqt_tuplet_subdivide :: Rq -> [Rq_Tied] -> [[Rq_Tied]]
rqt_tuplet_subdivide :: Rq -> [Rq_Tied] -> [[Rq_Tied]]
rqt_tuplet_subdivide Rq
i [Rq_Tied]
x =
    case Rq -> [Rq_Tied] -> Either String [[Rq_Tied]]
rqt_separate_tuplet Rq
i [Rq_Tied]
x of
      Left String
_ -> [[Rq_Tied]
x]
      Right [[Rq_Tied]]
r -> forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Rq -> [Rq_Tied] -> [[Rq_Tied]]
rqt_tuplet_subdivide Rq
i) [[Rq_Tied]]
r

-- | Sequence variant of 'rqt_tuplet_subdivide'.
--
-- > let d = [(1/5,True),(1/20,False),(1/2,False),(1/4,True)]
-- > in rqt_tuplet_subdivide_seq (1/2) [d]
rqt_tuplet_subdivide_seq :: Rq -> [[Rq_Tied]] -> [[Rq_Tied]]
rqt_tuplet_subdivide_seq :: Rq -> [[Rq_Tied]] -> [[Rq_Tied]]
rqt_tuplet_subdivide_seq Rq
i = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Rq -> [Rq_Tied] -> [[Rq_Tied]]
rqt_tuplet_subdivide Rq
i)

-- | If a tuplet is all tied, it ought to be a plain value?!
--
-- > rqt_tuplet_sanity_ [(4/10,t),(1/10,f)] == [(1/2,f)]
rqt_tuplet_sanity_ :: [Rq_Tied] -> [Rq_Tied]
rqt_tuplet_sanity_ :: [Rq_Tied] -> [Rq_Tied]
rqt_tuplet_sanity_ [Rq_Tied]
t =
    let last_tied :: Bool
last_tied = Rq_Tied -> Bool
rqt_tied (forall a. [a] -> a
last [Rq_Tied]
t)
        all_tied :: Bool
all_tied = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Rq_Tied -> Bool
rqt_tied (forall a. Int -> [a] -> [a]
dropRight Int
1 [Rq_Tied]
t)
    in if Bool
all_tied
       then [(forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (forall a b. (a -> b) -> [a] -> [b]
map Rq_Tied -> Rq
rqt_rq [Rq_Tied]
t),Bool
last_tied)]
       else [Rq_Tied]
t

rqt_tuplet_subdivide_seq_sanity_ :: Rq -> [[Rq_Tied]] -> [[Rq_Tied]]
rqt_tuplet_subdivide_seq_sanity_ :: Rq -> [[Rq_Tied]] -> [[Rq_Tied]]
rqt_tuplet_subdivide_seq_sanity_ Rq
i =
    forall a b. (a -> b) -> [a] -> [b]
map [Rq_Tied] -> [Rq_Tied]
rqt_tuplet_sanity_ forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    Rq -> [[Rq_Tied]] -> [[Rq_Tied]]
rqt_tuplet_subdivide_seq Rq
i

-- * Divisions

-- | Separate 'Rq' sequence into measures given by 'Rq' length.
--
-- > to_measures_rq [3,3] [2,2,2] == Right [[(2,f),(1,t)],[(1,f),(2,f)]]
-- > to_measures_rq [3,3] [6] == Right [[(3,t)],[(3,f)]]
-- > to_measures_rq [1,1,1] [3] == Right [[(1,t)],[(1,t)],[(1,f)]]
-- > to_measures_rq [3,3] [2,2,1]
-- > to_measures_rq [3,2] [2,2,2]
--
-- > let d = [4/7,33/28,9/20,4/5]
-- > in to_measures_rq [3] d == Right [[(4/7,f),(33/28,f),(9/20,f),(4/5,f)]]
to_measures_rq :: [Rq] -> [Rq] -> Either String [[Rq_Tied]]
to_measures_rq :: [Rq] -> [Rq] -> Either String [[Rq_Tied]]
to_measures_rq [Rq]
m = [Rq] -> [Rq_Tied] -> Either String [[Rq_Tied]]
rqt_separate [Rq]
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Rq -> Rq_Tied
rq_rqt

-- | Variant that is applicable only at sequence that do not require splitting and ties, else error.
to_measures_rq_untied_err :: [Rq] -> [Rq] -> [[Rq]]
to_measures_rq_untied_err :: [Rq] -> [Rq] -> [[Rq]]
to_measures_rq_untied_err [Rq]
m = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => String -> a
error String
"to_measures_rq_untied") (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> [a] -> [b]
map Rq_Tied -> Rq
rqt_to_rq_err)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Rq] -> [Rq] -> Either String [[Rq_Tied]]
to_measures_rq [Rq]
m

-- | Variant of 'to_measures_rq' that ensures 'Rq_Tied' are /cmn/
-- durations.  This is not a good composition.
--
-- > to_measures_rq_cmn [6,6] [5,5,2] == Right [[(4,t),(1,f),(1,t)]
-- >                                           ,[(4,f),(2,f)]]
--
-- > let r = [[(4/7,t),(1/7,f),(1,f),(6/7,f),(3/7,f)]]
-- > in to_measures_rq_cmn [3] [5/7,1,6/7,3/7] == Right r
--
-- > to_measures_rq_cmn [1,1,1] [5/7,1,6/7,3/7] == Right [[(4/7,t),(1/7,f),(2/7,t)]
-- >                                                     ,[(4/7,t),(1/7,f),(2/7,t)]
-- >                                                     ,[(4/7,f),(3/7,f)]]
to_measures_rq_cmn :: [Rq] -> [Rq] -> Either String [[Rq_Tied]]
to_measures_rq_cmn :: [Rq] -> [Rq] -> Either String [[Rq_Tied]]
to_measures_rq_cmn [Rq]
m = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map [Rq_Tied] -> [Rq_Tied]
rqt_set_to_cmn) forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Rq] -> [Rq] -> Either String [[Rq_Tied]]
to_measures_rq [Rq]
m

-- | Variant of 'to_measures_rq' with measures given by
-- 'Time_Signature' values.  Does not ensure 'Rq_Tied' are /cmn/
-- durations.
--
-- > to_measures_ts [(1,4)] [5/8,3/8] /= Right [[(1/2,t),(1/8,f),(3/8,f)]]
-- > to_measures_ts [(1,4)] [5/7,2/7] /= Right [[(4/7,t),(1/7,f),(2/7,f)]]
--
-- > let {m = replicate 18 (1,4)
-- >     ;x = [3/4,2,5/4,9/4,1/4,3/2,1/2,7/4,1,5/2,11/4,3/2]}
-- > in to_measures_ts m x == Right [[(3/4,f),(1/4,t)],[(1/1,t)]
-- >                                ,[(3/4,f),(1/4,t)],[(1/1,f)]
-- >                                ,[(1/1,t)],[(1/1,t)]
-- >                                ,[(1/4,f),(1/4,f),(1/2,t)],[(1/1,f)]
-- >                                ,[(1/2,f),(1/2,t)],[(1/1,t)]
-- >                                ,[(1/4,f),(3/4,t)],[(1/4,f),(3/4,t)]
-- >                                ,[(1/1,t)],[(3/4,f),(1/4,t)]
-- >                                ,[(1/1,t)],[(1/1,t)]
-- >                                ,[(1/2,f),(1/2,t)],[(1/1,f)]]
--
-- > to_measures_ts [(3,4)] [4/7,33/28,9/20,4/5]
-- > to_measures_ts (replicate 3 (1,4)) [4/7,33/28,9/20,4/5]
to_measures_ts :: [Time_Signature] -> [Rq] -> Either String [[Rq_Tied]]
to_measures_ts :: [Time_Signature] -> [Rq] -> Either String [[Rq_Tied]]
to_measures_ts [Time_Signature]
m = [Rq] -> [Rq] -> Either String [[Rq_Tied]]
to_measures_rq (forall a b. (a -> b) -> [a] -> [b]
map Time_Signature -> Rq
ts_rq [Time_Signature]
m)

-- | Variant of 'to_measures_ts' that allows for duration field
-- operation but requires that measures be well formed.  This is
-- useful for re-grouping measures after notation and ascription.
to_measures_ts_by_eq :: (a -> Rq) -> [Time_Signature] -> [a] -> Maybe [[a]]
to_measures_ts_by_eq :: forall a. (a -> Rq) -> [Time_Signature] -> [a] -> Maybe [[a]]
to_measures_ts_by_eq a -> Rq
f [Time_Signature]
m = forall n a. (Ord n, Num n) => (a -> n) -> [n] -> [a] -> Maybe [[a]]
split_sum_by_eq a -> Rq
f (forall a b. (a -> b) -> [a] -> [b]
map Time_Signature -> Rq
ts_rq [Time_Signature]
m)

-- | Divide measure into pulses of indicated 'Rq' durations.  Measure
-- must be of correct length but need not contain only /cmn/
-- durations.  Pulses are further subdivided if required to notate
-- tuplets correctly, see 'rqt_tuplet_subdivide_seq'.
--
-- > let d = [(1/4,f),(1/4,f),(2/3,t),(1/6,f),(16/15,f),(1/5,f)
-- >         ,(1/5,f),(2/5,t),(1/20,f),(1/2,f),(1/4,t)]
-- > in m_divisions_rq [1,1,1,1] d
--
-- > m_divisions_rq [1,1,1] [(4/7,f),(33/28,f),(9/20,f),(4/5,f)]
m_divisions_rq :: [Rq] -> [Rq_Tied] -> Either String [[Rq_Tied]]
m_divisions_rq :: [Rq] -> [Rq_Tied] -> Either String [[Rq_Tied]]
m_divisions_rq [Rq]
z =
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Rq -> [[Rq_Tied]] -> [[Rq_Tied]]
rqt_tuplet_subdivide_seq_sanity_ (Rq
1forall a. Fractional a => a -> a -> a
/Rq
16) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          forall a b. (a -> b) -> [a] -> [b]
map [Rq_Tied] -> [Rq_Tied]
rqt_set_to_cmn) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    [Rq] -> [Rq_Tied] -> Either String [[Rq_Tied]]
rqt_separate [Rq]
z

-- | Variant of 'm_divisions_rq' that determines pulse divisions from
-- 'Time_Signature'.
--
-- > let d = [(4/7,t),(1/7,f),(2/7,f)]
-- > in m_divisions_ts (1,4) d == Just [d]
--
-- > let d = map rq_rqt [1/3,1/6,2/5,1/10]
-- > in m_divisions_ts (1,4) d == Just [[(1/3,f),(1/6,f)]
-- >                                   ,[(2/5,f),(1/10,f)]]
--
-- > let d = map rq_rqt [4/7,33/28,9/20,4/5]
-- > in m_divisions_ts (3,4) d == Just [[(4/7,f),(3/7,t)]
-- >                                   ,[(3/4,f),(1/4,t)]
-- >                                   ,[(1/5,f),(4/5,f)]]
m_divisions_ts :: Time_Signature -> [Rq_Tied] -> Either String [[Rq_Tied]]
m_divisions_ts :: Time_Signature -> [Rq_Tied] -> Either String [[Rq_Tied]]
m_divisions_ts Time_Signature
ts = [Rq] -> [Rq_Tied] -> Either String [[Rq_Tied]]
m_divisions_rq (Time_Signature -> [Rq]
ts_divisions Time_Signature
ts)

{-| Composition of 'to_measures_rq' and 'm_divisions_rq', where
measures are initially given as sets of divisions.

> let m = [[1,1,1],[1,1,1]]
> in to_divisions_rq m [2,2,2] == Right [[[(1,t)],[(1,f)],[(1,t)]]
>                                      ,[[(1,f)],[(1,t)],[(1,f)]]]

> let d = [2/7,1/7,4/7,5/7,8/7,1,1/7]
> in to_divisions_rq [[1,1,1,1]] d == Right [[[(2/7,f),(1/7,f),(4/7,f)]
>                                           ,[(4/7,t),(1/7,f),(2/7,t)]
>                                           ,[(6/7,f),(1/7,t)]
>                                           ,[(6/7,f),(1/7,f)]]]

> let d = [5/7,1,6/7,3/7]
> in to_divisions_rq [[1,1,1]] d == Right [[[(4/7,t),(1/7,f),(2/7,t)]
>                                         ,[(4/7,t),(1/7,f),(2/7,t)]
>                                         ,[(4/7,f),(3/7,f)]]]

> let d = [2/7,1/7,4/7,5/7,1,6/7,3/7]
> in to_divisions_rq [[1,1,1,1]] d == Right [[[(2/7,f),(1/7,f),(4/7,f)]
>                                           ,[(4/7,t),(1/7,f),(2/7,t)]
>                                           ,[(4/7,t),(1/7,f),(2/7,t)]
>                                           ,[(4/7,f),(3/7,f)]]]

> let d = [4/7,33/28,9/20,4/5]
> in to_divisions_rq [[1,1,1]] d == Right [[[(4/7,f),(3/7,t)]
>                                          ,[(3/4,f),(1/4,t)]
>                                          ,[(1/5,f),(4/5,f)]]]

> let {p = [[1/2,1,1/2],[1/2,1]]
>     ;d = map (/6) [1,1,1,1,1,1,4,1,2,1,1,2,1,3]}
> in to_divisions_rq p d == Right [[[(1/6,f),(1/6,f),(1/6,f)]
>                                  ,[(1/6,f),(1/6,f),(1/6,f),(1/2,True)]
>                                  ,[(1/6,f),(1/6,f),(1/6,True)]]
>                                 ,[[(1/6,f),(1/6,f),(1/6,f)]
>                                  ,[(1/3,f),(1/6,f),(1/2,f)]]]

-}
to_divisions_rq :: [[Rq]] -> [Rq] -> Either String [[[Rq_Tied]]]
to_divisions_rq :: [[Rq]] -> [Rq] -> Either String [[[Rq_Tied]]]
to_divisions_rq [[Rq]]
m [Rq]
x =
    let m' :: [Rq]
m' = forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [[Rq]]
m
    in case [Rq] -> [Rq] -> Either String [[Rq_Tied]]
to_measures_rq [Rq]
m' [Rq]
x of
         Right [[Rq_Tied]]
y -> forall a b. [Either a b] -> Either a [b]
all_right (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [Rq] -> [Rq_Tied] -> Either String [[Rq_Tied]]
m_divisions_rq [[Rq]]
m [[Rq_Tied]]
y)
         Left String
e -> forall a b. a -> Either a b
Left String
e

-- | Variant of 'to_divisions_rq' with measures given as set of
-- 'Time_Signature'.
--
-- > let d = [3/5,2/5,1/3,1/6,7/10,17/15,1/2,1/6]
-- > in to_divisions_ts [(4,4)] d == Just [[[(3/5,f),(2/5,f)]
-- >                                       ,[(1/3,f),(1/6,f),(1/2,t)]
-- >                                       ,[(1/5,f),(4/5,t)]
-- >                                       ,[(1/3,f),(1/2,f),(1/6,f)]]]
--
-- > let d = [3/5,2/5,1/3,1/6,7/10,29/30,1/2,1/3]
-- > in to_divisions_ts [(4,4)] d == Just [[[(3/5,f),(2/5,f)]
-- >                                       ,[(1/3,f),(1/6,f),(1/2,t)]
-- >                                       ,[(1/5,f),(4/5,t)]
-- >                                       ,[(1/6,f),(1/2,f),(1/3,f)]]]
--
-- > let d = [3/5,2/5,1/3,1/6,7/10,4/5,1/2,1/2]
-- > in to_divisions_ts [(4,4)] d == Just [[[(3/5,f),(2/5,f)]
-- >                                       ,[(1/3,f),(1/6,f),(1/2,t)]
-- >                                       ,[(1/5,f),(4/5,f)]
-- >                                       ,[(1/2,f),(1/2,f)]]]
--
-- > let d = [4/7,33/28,9/20,4/5]
-- > in to_divisions_ts [(3,4)] d == Just [[[(4/7,f),(3/7,t)]
-- >                                       ,[(3/4,f),(1/4,t)]
-- >                                       ,[(1/5,f),(4/5,f)]]]
to_divisions_ts :: [Time_Signature] -> [Rq] -> Either String [[[Rq_Tied]]]
to_divisions_ts :: [Time_Signature] -> [Rq] -> Either String [[[Rq_Tied]]]
to_divisions_ts [Time_Signature]
ts = [[Rq]] -> [Rq] -> Either String [[[Rq_Tied]]]
to_divisions_rq (forall a b. (a -> b) -> [a] -> [b]
map Time_Signature -> [Rq]
ts_divisions [Time_Signature]
ts)

-- * Durations

-- | Pulse tuplet derivation.
--
-- > p_tuplet_rqt [(2/3,f),(1/3,t)] == Just ((3,2),[(1,f),(1/2,t)])
-- > p_tuplet_rqt (map rq_rqt [1/3,1/6]) == Just ((3,2),[(1/2,f),(1/4,f)])
-- > p_tuplet_rqt (map rq_rqt [2/5,1/10]) == Just ((5,4),[(1/2,f),(1/8,f)])
-- > p_tuplet_rqt (map rq_rqt [1/3,1/6,2/5,1/10])
p_tuplet_rqt :: [Rq_Tied] -> Maybe ((Integer,Integer),[Rq_Tied])
p_tuplet_rqt :: [Rq_Tied] -> Maybe (Time_Signature, [Rq_Tied])
p_tuplet_rqt [Rq_Tied]
x =
    let f :: Time_Signature -> (Time_Signature, [Rq_Tied])
f Time_Signature
t = (Time_Signature
t,forall a b. (a -> b) -> [a] -> [b]
map (Time_Signature -> Rq_Tied -> Rq_Tied
rqt_un_tuplet Time_Signature
t) [Rq_Tied]
x)
    in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Time_Signature -> (Time_Signature, [Rq_Tied])
f ([Rq] -> Maybe Time_Signature
rq_derive_tuplet (forall a b. (a -> b) -> [a] -> [b]
map Rq_Tied -> Rq
rqt_rq [Rq_Tied]
x))

-- | Notate pulse, ie. derive tuplet if neccesary. The flag indicates
-- if the initial value is tied left.
--
-- > p_notate False [(2/3,f),(1/3,t)]
-- > p_notate False [(2/5,f),(1/10,t)]
-- > p_notate False [(1/4,t),(1/8,f),(1/8,f)]
-- > p_notate False (map rq_rqt [1/3,1/6])
-- > p_notate False (map rq_rqt [2/5,1/10])
-- > p_notate False (map rq_rqt [1/3,1/6,2/5,1/10]) == Nothing
p_notate :: Bool -> [Rq_Tied] -> Either String [Duration_A]
p_notate :: Bool -> [Rq_Tied] -> Either String [Duration_A]
p_notate Bool
z [Rq_Tied]
x =
    let f :: [Rq_Tied] -> [Duration_A]
f = [Duration_A] -> [Duration_A]
p_simplify forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> [Rq_Tied] -> [Duration_A]
rqt_to_duration_a Bool
z
        d :: [Duration_A]
d = case [Rq_Tied] -> Maybe (Time_Signature, [Rq_Tied])
p_tuplet_rqt [Rq_Tied]
x of
              Just (Time_Signature
t,[Rq_Tied]
x') -> Time_Signature -> [Duration_A] -> [Duration_A]
da_tuplet Time_Signature
t ([Rq_Tied] -> [Duration_A]
f [Rq_Tied]
x')
              Maybe (Time_Signature, [Rq_Tied])
Nothing -> [Rq_Tied] -> [Duration_A]
f [Rq_Tied]
x
    in if Int -> [Rq] -> Bool
rq_can_notate Int
2 (forall a b. (a -> b) -> [a] -> [b]
map Rq_Tied -> Rq
rqt_rq [Rq_Tied]
x)
       then forall a b. b -> Either a b
Right [Duration_A]
d
       else forall a b. a -> Either a b
Left (forall a. Show a => a -> String
show (String
"p_notate",Bool
z,[Rq_Tied]
x))

-- | Notate measure.
--
-- > m_notate True [[(2/3,f),(1/3,t)],[(1,t)],[(1,f)]]
--
-- > let f = m_notate False . concat
--
-- > fmap f (to_divisions_ts [(4,4)] [3/5,2/5,1/3,1/6,7/10,17/15,1/2,1/6])
-- > fmap f (to_divisions_ts [(4,4)] [3/5,2/5,1/3,1/6,7/10,29/30,1/2,1/3])
m_notate :: Bool -> [[Rq_Tied]] -> Either String [Duration_A]
m_notate :: Bool -> [[Rq_Tied]] -> Either String [Duration_A]
m_notate Bool
z [[Rq_Tied]]
m =
    let z' :: [Bool]
z' = Bool
z forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Rq_Tied -> Bool
is_tied_right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
last) [[Rq_Tied]]
m
    in forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a b. [Either a b] -> Either a [b]
all_right (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> [Rq_Tied] -> Either String [Duration_A]
p_notate [Bool]
z' [[Rq_Tied]]
m))

{-| Multiple measure notation.

> let d = [2/7,1/7,4/7,5/7,8/7,1,1/7]
> in fmap mm_notate (to_divisions_ts [(4,4)] d)

> let d = [2/7,1/7,4/7,5/7,1,6/7,3/7]
> in fmap mm_notate (to_divisions_ts [(4,4)] d)

> let d = [3/5,2/5,1/3,1/6,7/10,4/5,1/2,1/2]
> in fmap mm_notate (to_divisions_ts [(4,4)] d)

> let {p = [[1/2,1,1/2],[1/2,1]]
>     ;d = map (/6) [1,1,1,1,1,1,4,1,2,1,1,2,1,3]}
> in fmap mm_notate (to_divisions_rq p d)

-}
mm_notate :: [[[Rq_Tied]]] -> Either String [[Duration_A]]
mm_notate :: [[[Rq_Tied]]] -> Either String [[Duration_A]]
mm_notate [[[Rq_Tied]]]
d =
    let z :: [Bool]
z = Bool
False forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Rq_Tied -> Bool
is_tied_right forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
last forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
last) [[[Rq_Tied]]]
d
    in forall a b. [Either a b] -> Either a [b]
all_right (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> [[Rq_Tied]] -> Either String [Duration_A]
m_notate [Bool]
z [[[Rq_Tied]]]
d)

-- * Simplifications

-- | Structure given to 'Simplify_P' to decide simplification.  The
-- structure is /(ts,start-rq,(left-rq,right-rq))/.
type Simplify_T = (Time_Signature,Rq,(Rq,Rq))

-- | Predicate function at 'Simplify_T'.
type Simplify_P = Simplify_T -> Bool

-- | Variant of 'Simplify_T' allowing multiple rules.
type Simplify_M = ([Time_Signature],[Rq],[(Rq,Rq)])

-- | Transform 'Simplify_M' to 'Simplify_P'.
meta_table_p :: Simplify_M -> Simplify_P
meta_table_p :: Simplify_M -> Simplify_P
meta_table_p ([Time_Signature]
tt,[Rq]
ss,[(Rq, Rq)]
pp) (Time_Signature
t,Rq
s,(Rq, Rq)
p) = Time_Signature
t forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Time_Signature]
tt Bool -> Bool -> Bool
&& Rq
s forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Rq]
ss Bool -> Bool -> Bool
&& (Rq, Rq)
p forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(Rq, Rq)]
pp

-- | Transform 'Simplify_M' to set of 'Simplify_T'.
meta_table_t :: Simplify_M -> [Simplify_T]
meta_table_t :: Simplify_M -> [Simplify_T]
meta_table_t ([Time_Signature]
tt,[Rq]
ss,[(Rq, Rq)]
pp) = [(Time_Signature
t,Rq
s,(Rq, Rq)
p) | Time_Signature
t <- [Time_Signature]
tt, Rq
s <- [Rq]
ss,(Rq, Rq)
p <- [(Rq, Rq)]
pp]

-- | The default table of simplifiers.
--
-- > default_table ((3,4),1,(1,1)) == True
default_table :: Simplify_P
default_table :: Simplify_P
default_table Simplify_T
x =
    let t :: [Simplify_M]
        t :: [Simplify_M]
t = [([(Integer
3,Integer
4)],[Rq
1],[(Rq
1,Rq
1)])]
        p :: [Simplify_P]
        p :: [Simplify_P]
p = forall a b. (a -> b) -> [a] -> [b]
map Simplify_M -> Simplify_P
meta_table_p [Simplify_M]
t
    in forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Simplify_P]
p forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Simplify_T
x)

-- | The default eighth-note pulse simplifier rule.
--
-- > default_8_rule ((3,8),0,(1/2,1/2)) == True
-- > default_8_rule ((3,8),1/2,(1/2,1/2)) == True
-- > default_8_rule ((3,8),1,(1/2,1/2)) == True
-- > default_8_rule ((2,8),0,(1/2,1/2)) == True
-- > default_8_rule ((5,8),0,(1,1/2)) == True
-- > default_8_rule ((5,8),0,(2,1/2)) == True
default_8_rule :: Simplify_P
default_8_rule :: Simplify_P
default_8_rule ((Integer
i,Integer
j),Rq
t,(Rq
p,Rq
q)) =
    let r :: Rq
r = Rq
p forall a. Num a => a -> a -> a
+ Rq
q
    in Integer
j forall a. Eq a => a -> a -> Bool
== Integer
8 Bool -> Bool -> Bool
&&
       forall a. Ratio a -> a
denominator Rq
t forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Integer
1,Integer
2] Bool -> Bool -> Bool
&&
       (Rq
r forall a. Ord a => a -> a -> Bool
<= Rq
2 Bool -> Bool -> Bool
|| Rq
r forall a. Eq a => a -> a -> Bool
== Time_Signature -> Rq
ts_rq (Integer
i,Integer
j) Bool -> Bool -> Bool
|| Rq -> Bool
rq_is_integral Rq
r)

-- | The default quarter note pulse simplifier rule.
--
-- > default_4_rule ((3,4),0,(1,1/2)) == True
-- > default_4_rule ((3,4),0,(1,3/4)) == True
-- > default_4_rule ((4,4),1,(1,1)) == False
-- > default_4_rule ((4,4),2,(1,1)) == True
-- > default_4_rule ((4,4),2,(1,2)) == True
-- > default_4_rule ((4,4),0,(2,1)) == True
-- > default_4_rule ((3,4),1,(1,1)) == False
default_4_rule :: Simplify_P
default_4_rule :: Simplify_P
default_4_rule ((Integer
_,Integer
j),Rq
t,(Rq
p,Rq
q)) =
    let r :: Rq
r = Rq
p forall a. Num a => a -> a -> a
+ Rq
q
    in Integer
j forall a. Eq a => a -> a -> Bool
== Integer
4 Bool -> Bool -> Bool
&&
       forall a. Ratio a -> a
denominator Rq
t forall a. Eq a => a -> a -> Bool
== Integer
1 Bool -> Bool -> Bool
&&
       forall a. Integral a => a -> Bool
even (forall a. Ratio a -> a
numerator Rq
t) Bool -> Bool -> Bool
&&
       (Rq
r forall a. Ord a => a -> a -> Bool
<= Rq
2 Bool -> Bool -> Bool
|| Rq -> Bool
rq_is_integral Rq
r)

{-
-- | Any pulse-division aligned pair that sums to a division of the
-- pulse and does not cross a pulse boundary can be simplified.
--
-- > default_aligned_pulse_rule ((4,2),0,(2,1)) == True
-- > default_aligned_pulse_rule ((4,2),1,(1,1)) == False
-- > default_aligned_pulse_rule ((4,2),7,(4/10,1/10)) == True
default_aligned_pulse_rule :: Simplify_P
default_aligned_pulse_rule ((_,j),t,(p,q)) =
    let r = p + q
        w = whole_note_division_to_rq j
        tw = t `rq_mod` w
    in w `rq_mod` r == 0 &&
       t `rq_mod` (w `min` 1) == 0 &&
       (tw == 0 || tw + r <= w)
-}

-- | The default simplifier rule.  To extend provide a list of
-- 'Simplify_T'.
default_rule :: [Simplify_T] -> Simplify_P
default_rule :: [Simplify_T] -> Simplify_P
default_rule [Simplify_T]
x Simplify_T
r = Simplify_T
r forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Simplify_T]
x Bool -> Bool -> Bool
||
                   {-default_aligned_pulse_rule r ||-}
                   Simplify_P
default_4_rule Simplify_T
r Bool -> Bool -> Bool
||
                   Simplify_P
default_8_rule Simplify_T
r Bool -> Bool -> Bool
||
                   Simplify_P
default_table Simplify_T
r

-- | Measure simplifier.  Apply given 'Simplify_P'.
m_simplify :: Simplify_P -> Time_Signature -> [Duration_A] -> [Duration_A]
m_simplify :: Simplify_P -> Time_Signature -> [Duration_A] -> [Duration_A]
m_simplify Simplify_P
p Time_Signature
ts =
    let f :: Rq -> Duration_A -> Duration_A -> Maybe Duration_A
f Rq
st (Duration
d0,[D_Annotation]
a0) (Duration
d1,[D_Annotation]
a1) =
            let t :: Bool
t = D_Annotation
Tie_Right forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [D_Annotation]
a0 Bool -> Bool -> Bool
&& D_Annotation
Tie_Left forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [D_Annotation]
a1
                e :: Bool
e = D_Annotation
End_Tuplet forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [D_Annotation]
a0 Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any D_Annotation -> Bool
begins_tuplet [D_Annotation]
a1)
                m :: Bool
m = Duration -> Duration -> Bool
duration_meq Duration
d0 Duration
d1
                d :: Maybe Duration
d = Duration -> Duration -> Maybe Duration
sum_dur Duration
d0 Duration
d1
                a :: [D_Annotation]
a = forall a. Eq a => a -> [a] -> [a]
delete D_Annotation
Tie_Right [D_Annotation]
a0 forall a. [a] -> [a] -> [a]
++ forall a. Eq a => a -> [a] -> [a]
delete D_Annotation
Tie_Left [D_Annotation]
a1
                r :: Bool
r = Simplify_P
p (Time_Signature
ts,Rq
st,(Duration -> Rq
duration_to_rq Duration
d0,Duration -> Rq
duration_to_rq Duration
d1))
                n_dots :: Int
n_dots = Int
1
                g :: Duration -> Maybe Duration_A
g Duration
i = if Duration -> Int
dots Duration
i forall a. Ord a => a -> a -> Bool
<= Int
n_dots Bool -> Bool -> Bool
&& Bool
t Bool -> Bool -> Bool
&& Bool
e Bool -> Bool -> Bool
&& Bool
m Bool -> Bool -> Bool
&& Bool
r
                      then forall a. a -> Maybe a
Just (Duration
i,[D_Annotation]
a)
                      else forall a. Maybe a
Nothing
            in Duration -> Maybe Duration_A
g forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe Duration
d
        z :: Rq -> (Duration, b) -> Rq
z Rq
i (Duration
j,b
_) = Rq
i forall a. Num a => a -> a -> a
+ Duration -> Rq
duration_to_rq Duration
j
    in forall b a.
(b -> a -> b) -> b -> (b -> a -> a -> Maybe a) -> [a] -> [a]
coalesce_sum forall {b}. Rq -> (Duration, b) -> Rq
z Rq
0 Rq -> Duration_A -> Duration_A -> Maybe Duration_A
f

-- | Run simplifier until it reaches a fix-point, or for at most 'limit' passes.
m_simplify_fix :: Int -> Simplify_P -> Time_Signature -> [Duration_A] -> [Duration_A]
m_simplify_fix :: Int -> Simplify_P -> Time_Signature -> [Duration_A] -> [Duration_A]
m_simplify_fix Int
limit Simplify_P
p Time_Signature
ts [Duration_A]
d =
    let d' :: [Duration_A]
d' = Simplify_P -> Time_Signature -> [Duration_A] -> [Duration_A]
m_simplify Simplify_P
p Time_Signature
ts [Duration_A]
d
    in if [Duration_A]
d forall a. Eq a => a -> a -> Bool
== [Duration_A]
d' Bool -> Bool -> Bool
|| Int
limit forall a. Eq a => a -> a -> Bool
== Int
1
       then [Duration_A]
d'
       else Int -> Simplify_P -> Time_Signature -> [Duration_A] -> [Duration_A]
m_simplify_fix (Int
limit forall a. Num a => a -> a -> a
- Int
1) Simplify_P
p Time_Signature
ts [Duration_A]
d'

-- | Pulse simplifier predicate, which is 'const' 'True'.
p_simplify_rule :: Simplify_P
p_simplify_rule :: Simplify_P
p_simplify_rule = forall a b. a -> b -> a
const Bool
True

-- | Pulse simplifier.
--
-- > import Music.Theory.Duration.Name.Abbreviation
-- > p_simplify [(q,[Tie_Right]),(e,[Tie_Left])] == [(q',[])]
-- > p_simplify [(e,[Tie_Right]),(q,[Tie_Left])] == [(q',[])]
-- > p_simplify [(q,[Tie_Right]),(e',[Tie_Left])] == [(q'',[])]
-- > p_simplify [(q'',[Tie_Right]),(s,[Tie_Left])] == [(h,[])]
-- > p_simplify [(e,[Tie_Right]),(s,[Tie_Left]),(e',[])] == [(e',[]),(e',[])]
--
-- > let f = rqt_to_duration_a False
-- > in p_simplify (f [(1/8,t),(1/4,t),(1/8,f)]) == f [(1/2,f)]
p_simplify :: [Duration_A] -> [Duration_A]
p_simplify :: [Duration_A] -> [Duration_A]
p_simplify = Simplify_P -> Time_Signature -> [Duration_A] -> [Duration_A]
m_simplify Simplify_P
p_simplify_rule forall a. HasCallStack => a
undefined

-- * Notate

{-| Notate Rq duration sequence.  Derive pulse divisions from
'Time_Signature' if not given directly.  Composition of
'to_divisions_ts', 'mm_notate' 'm_simplify'.

>  let ts = [(4,8),(3,8)]
>      ts_p = [[1/2,1,1/2],[1/2,1]]
>      rq = map (/6) [1,1,1,1,1,1,4,1,2,1,1,2,1,3]
>      sr x = T.default_rule [] x
>  in T.notate_rqp 4 sr ts (Just ts_p) rq

-}
notate_rqp :: Int -> Simplify_P -> [Time_Signature] -> Maybe [[Rq]] -> [Rq] ->
              Either String [[Duration_A]]
notate_rqp :: Int
-> Simplify_P
-> [Time_Signature]
-> Maybe [[Rq]]
-> [Rq]
-> Either String [[Duration_A]]
notate_rqp Int
limit Simplify_P
r [Time_Signature]
ts Maybe [[Rq]]
ts_p [Rq]
x = do
  let ts_p' :: [[Rq]]
ts_p' = forall a. a -> Maybe a -> a
fromMaybe (forall a b. (a -> b) -> [a] -> [b]
map Time_Signature -> [Rq]
ts_divisions [Time_Signature]
ts) Maybe [[Rq]]
ts_p
  [[[Rq_Tied]]]
mm <- [[Rq]] -> [Rq] -> Either String [[[Rq_Tied]]]
to_divisions_rq [[Rq]]
ts_p' [Rq]
x
  [[Duration_A]]
dd <- [[[Rq_Tied]]] -> Either String [[Duration_A]]
mm_notate [[[Rq_Tied]]]
mm
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Int -> Simplify_P -> Time_Signature -> [Duration_A] -> [Duration_A]
m_simplify_fix Int
limit Simplify_P
r) [Time_Signature]
ts [[Duration_A]]
dd)

-- | Variant of 'notate_rqp' without pulse divisions (derive).
--
-- > notate 4 (default_rule [((3,2),0,(2,2)),((3,2),0,(4,2))]) [(3,2)] [6]
notate :: Int -> Simplify_P -> [Time_Signature] -> [Rq] -> Either String [[Duration_A]]
notate :: Int
-> Simplify_P
-> [Time_Signature]
-> [Rq]
-> Either String [[Duration_A]]
notate Int
limit Simplify_P
r [Time_Signature]
ts = Int
-> Simplify_P
-> [Time_Signature]
-> Maybe [[Rq]]
-> [Rq]
-> Either String [[Duration_A]]
notate_rqp Int
limit Simplify_P
r [Time_Signature]
ts forall a. Maybe a
Nothing

-- * Ascribe

-- | Variant of 'zip' that retains elements of the right hand (rhs)
-- list where elements of the left hand (lhs) list meet the given lhs
-- predicate.  If the right hand side is longer the remaining elements
-- to be processed are given.  It is an error for the right hand side
-- to be short.
--
-- > zip_hold_lhs even [1..5] "abc" == ([],zip [1..6] "abbcc")
-- > zip_hold_lhs odd [1..6] "abc" == ([],zip [1..6] "aabbcc")
-- > zip_hold_lhs even [1] "ab" == ("b",[(1,'a')])
-- > zip_hold_lhs even [1,2] "a" == undefined
zip_hold_lhs :: (Show t,Show x) => (x -> Bool) -> [x] -> [t] -> ([t],[(x,t)])
zip_hold_lhs :: forall t x.
(Show t, Show x) =>
(x -> Bool) -> [x] -> [t] -> ([t], [(x, t)])
zip_hold_lhs x -> Bool
lhs_f =
    let f :: [b] -> x -> ([b], (x, b))
f [b]
st x
e =
            case [b]
st of
              b
r:[b]
s -> let st' :: [b]
st' = if x -> Bool
lhs_f x
e then [b]
st else [b]
s
                     in ([b]
st',(x
e,b
r))
              [b]
_ -> forall a. HasCallStack => String -> a
error (forall a. Show a => a -> String
show (String
"zip_hold_lhs: rhs ends",[b]
st,x
e))
    in forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall (t :: * -> *) s a b.
Traversable t =>
(s -> a -> (s, b)) -> s -> t a -> (s, t b)
mapAccumL forall {b}. Show b => [b] -> x -> ([b], (x, b))
f)

-- | Variant of 'zip_hold' that requires the right hand side to be
-- precisely the required length.
--
-- > zip_hold_lhs_err even [1..5] "abc" == zip [1..6] "abbcc"
-- > zip_hold_lhs_err odd [1..6] "abc" == zip [1..6] "aabbcc"
-- > zip_hold_lhs_err id [False,False] "a" == undefined
-- > zip_hold_lhs_err id [False] "ab" == undefined
zip_hold_lhs_err :: (Show t,Show x) => (x -> Bool) -> [x] -> [t] -> [(x,t)]
zip_hold_lhs_err :: forall t x.
(Show t, Show x) =>
(x -> Bool) -> [x] -> [t] -> [(x, t)]
zip_hold_lhs_err x -> Bool
lhs_f [x]
p [t]
q =
    case forall t x.
(Show t, Show x) =>
(x -> Bool) -> [x] -> [t] -> ([t], [(x, t)])
zip_hold_lhs x -> Bool
lhs_f [x]
p [t]
q of
      ([],[(x, t)]
r) -> [(x, t)]
r
      ([t], [(x, t)])
e -> forall a. HasCallStack => String -> a
error (forall a. Show a => a -> String
show (String
"zip_hold_lhs_err: lhs ends",([t], [(x, t)])
e))

-- | Variant of 'zip' that retains elements of the right hand (rhs)
-- list where elements of the left hand (lhs) list meet the given lhs
-- predicate, and elements of the lhs list where elements of the rhs
-- meet the rhs predicate.  If the right hand side is longer the
-- remaining elements to be processed are given.  It is an error for
-- the right hand side to be short.
--
-- > zip_hold even (const False) [1..5] "abc" == ([],zip [1..6] "abbcc")
-- > zip_hold odd (const False) [1..6] "abc" == ([],zip [1..6] "aabbcc")
-- > zip_hold even (const False) [1] "ab" == ("b",[(1,'a')])
-- > zip_hold even (const False) [1,2] "a" == undefined
--
-- > zip_hold odd even [1,2,6] [1..5] == ([4,5],[(1,1),(2,1),(6,2),(6,3)])
zip_hold :: (Show t,Show x) => (x -> Bool) -> (t -> Bool) -> [x] -> [t] -> ([t],[(x,t)])
zip_hold :: forall t x.
(Show t, Show x) =>
(x -> Bool) -> (t -> Bool) -> [x] -> [t] -> ([t], [(x, t)])
zip_hold x -> Bool
lhs_f t -> Bool
rhs_f =
    let f :: [(x, t)] -> [x] -> [t] -> ([t], [(x, t)])
f [(x, t)]
r [x]
x [t]
t =
            case ([x]
x,[t]
t) of
              ([],[t]
_) -> ([t]
t,forall a. [a] -> [a]
reverse [(x, t)]
r)
              ([x]
_,[]) -> forall a. HasCallStack => String -> a
error String
"zip_hold: rhs ends"
              (x
x0:[x]
x',t
t0:[t]
t') -> let x'' :: [x]
x'' = if t -> Bool
rhs_f t
t0 then [x]
x else [x]
x'
                                   t'' :: [t]
t'' = if x -> Bool
lhs_f x
x0 then [t]
t else [t]
t'
                               in [(x, t)] -> [x] -> [t] -> ([t], [(x, t)])
f ((x
x0,t
t0) forall a. a -> [a] -> [a]
: [(x, t)]
r) [x]
x'' [t]
t''
    in [(x, t)] -> [x] -> [t] -> ([t], [(x, t)])
f []

-- | Zip a list of 'Duration_A' elements duplicating elements of the
-- right hand sequence for tied durations.
--
-- > let {Just d = to_divisions_ts [(4,4),(4,4)] [3,3,2]
-- >     ;f = map snd . snd . flip m_ascribe "xyz"}
-- > in fmap f (notate d) == Just "xxxyyyzz"
m_ascribe :: Show x => [Duration_A] -> [x] -> ([x],[(Duration_A,x)])
m_ascribe :: forall x. Show x => [Duration_A] -> [x] -> ([x], [(Duration_A, x)])
m_ascribe = forall t x.
(Show t, Show x) =>
(x -> Bool) -> [x] -> [t] -> ([t], [(x, t)])
zip_hold_lhs Duration_A -> Bool
da_tied_right

-- | 'snd' '.' 'm_ascribe'.
ascribe :: Show x => [Duration_A] -> [x] -> [(Duration_A, x)]
ascribe :: forall x. Show x => [Duration_A] -> [x] -> [(Duration_A, x)]
ascribe [Duration_A]
d = forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall x. Show x => [Duration_A] -> [x] -> ([x], [(Duration_A, x)])
m_ascribe [Duration_A]
d

-- | Variant of 'm_ascribe' for a set of measures.
mm_ascribe :: Show x => [[Duration_A]] -> [x] -> [[(Duration_A,x)]]
mm_ascribe :: forall x. Show x => [[Duration_A]] -> [x] -> [[(Duration_A, x)]]
mm_ascribe [[Duration_A]]
mm [x]
x =
    case [[Duration_A]]
mm of
      [] -> []
      [Duration_A]
m:[[Duration_A]]
mm' -> let ([x]
x',[(Duration_A, x)]
r) = forall x. Show x => [Duration_A] -> [x] -> ([x], [(Duration_A, x)])
m_ascribe [Duration_A]
m [x]
x
               in [(Duration_A, x)]
r forall a. a -> [a] -> [a]
: forall x. Show x => [[Duration_A]] -> [x] -> [[(Duration_A, x)]]
mm_ascribe [[Duration_A]]
mm' [x]
x'

-- | 'mm_ascribe of 'notate'.
notate_mm_ascribe :: Show a => Int -> [Simplify_T] -> [Time_Signature] -> Maybe [[Rq]] -> [Rq] -> [a] ->
                     Either String [[(Duration_A,a)]]
notate_mm_ascribe :: forall a.
Show a =>
Int
-> [Simplify_T]
-> [Time_Signature]
-> Maybe [[Rq]]
-> [Rq]
-> [a]
-> Either String [[(Duration_A, a)]]
notate_mm_ascribe Int
limit [Simplify_T]
r [Time_Signature]
ts Maybe [[Rq]]
rqp [Rq]
d [a]
p =
    let n :: Either String [[Duration_A]]
n = Int
-> Simplify_P
-> [Time_Signature]
-> Maybe [[Rq]]
-> [Rq]
-> Either String [[Duration_A]]
notate_rqp Int
limit ([Simplify_T] -> Simplify_P
default_rule [Simplify_T]
r) [Time_Signature]
ts Maybe [[Rq]]
rqp [Rq]
d
        f :: [[Duration_A]] -> [[(Duration_A, a)]]
f = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall x. Show x => [[Duration_A]] -> [x] -> [[(Duration_A, x)]]
mm_ascribe [a]
p
        err :: b -> String
err b
str = forall a. Show a => a -> String
show (String
"notate_mm_ascribe",b
str,[Time_Signature]
ts,[Rq]
d,[a]
p)
    in forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
err) (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Duration_A]] -> [[(Duration_A, a)]]
f) Either String [[Duration_A]]
n

notate_mm_ascribe_err :: Show a => Int -> [Simplify_T] -> [Time_Signature] -> Maybe [[Rq]] -> [Rq] -> [a] ->
                         [[(Duration_A,a)]]
notate_mm_ascribe_err :: forall a.
Show a =>
Int
-> [Simplify_T]
-> [Time_Signature]
-> Maybe [[Rq]]
-> [Rq]
-> [a]
-> [[(Duration_A, a)]]
notate_mm_ascribe_err = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => String -> a
error forall a. a -> a
id forall (f :: * -> *) (g :: * -> *) (h :: * -> *) (i :: * -> *)
       (j :: * -> *) (k :: * -> *) a b.
(Functor f, Functor g, Functor h, Functor i, Functor j,
 Functor k) =>
(a -> b) -> f (g (h (i (j (k a))))) -> f (g (h (i (j (k b)))))
.::::: forall a.
Show a =>
Int
-> [Simplify_T]
-> [Time_Signature]
-> Maybe [[Rq]]
-> [Rq]
-> [a]
-> Either String [[(Duration_A, a)]]
notate_mm_ascribe

-- | Group elements as /chords/ where a chord element is indicated by
-- the given predicate.
--
-- > group_chd even [1,2,3,4,4,5,7,8] == [[1,2],[3,4,4],[5],[7,8]]
group_chd :: (x -> Bool) -> [x] -> [[x]]
group_chd :: forall x. (x -> Bool) -> [x] -> [[x]]
group_chd x -> Bool
f [x]
x =
    case forall a. Splitter a -> [a] -> [[a]]
split (forall a. Splitter a -> Splitter a
keepDelimsL (forall a. (a -> Bool) -> Splitter a
whenElt (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.x -> Bool
f))) [x]
x of
      []:[[x]]
r -> [[x]]
r
      [[x]]
_ -> forall a. HasCallStack => String -> a
error String
"group_chd: first element chd?"

-- | Variant of 'ascribe' that groups the /rhs/ elements using
-- 'group_chd' and with the indicated /chord/ function, then rejoins
-- the resulting sequence.
ascribe_chd :: Show x => (x -> Bool) -> [Duration_A] -> [x] -> [(Duration_A, x)]
ascribe_chd :: forall x.
Show x =>
(x -> Bool) -> [Duration_A] -> [x] -> [(Duration_A, x)]
ascribe_chd x -> Bool
chd_f [Duration_A]
d [x]
x =
    let x' :: [[x]]
x' = forall x. (x -> Bool) -> [x] -> [[x]]
group_chd x -> Bool
chd_f [x]
x
        jn :: (a, [b]) -> [(a, b)]
jn (a
i,[b]
j) = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. a -> [a]
repeat a
i) [b]
j
    in forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a} {b}. (a, [b]) -> [(a, b)]
jn (forall x. Show x => [Duration_A] -> [x] -> [(Duration_A, x)]
ascribe [Duration_A]
d [[x]]
x')

-- | Variant of 'mm_ascribe' using 'group_chd'
mm_ascribe_chd :: Show x => (x -> Bool) -> [[Duration_A]] -> [x] -> [[(Duration_A,x)]]
mm_ascribe_chd :: forall x.
Show x =>
(x -> Bool) -> [[Duration_A]] -> [x] -> [[(Duration_A, x)]]
mm_ascribe_chd x -> Bool
chd_f [[Duration_A]]
d [x]
x =
    let x' :: [[x]]
x' = forall x. (x -> Bool) -> [x] -> [[x]]
group_chd x -> Bool
chd_f [x]
x
        jn :: (a, [b]) -> [(a, b)]
jn (a
i,[b]
j) = forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. a -> [a]
repeat a
i) [b]
j
    in forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {a} {b}. (a, [b]) -> [(a, b)]
jn) (forall x. Show x => [[Duration_A]] -> [x] -> [[(Duration_A, x)]]
mm_ascribe [[Duration_A]]
d [[x]]
x')