hmt-0.16: Music/Theory/Duration/Sequence/Notate.hs
-- | 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_T' 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 Control.Monad {- base -}
import Data.List {- base -}
import Data.List.Split {- split -}
import Data.Maybe {- base -}
import Data.Ratio {- base -}
import Music.Theory.Duration {- hmt -}
import Music.Theory.Duration.Annotation {- hmt -}
import Music.Theory.Function {- hmt -}
import Music.Theory.Duration.RQ {- hmt -}
import Music.Theory.Duration.RQ.Tied {- hmt -}
import Music.Theory.List {- hmt -}
import Music.Theory.Time_Signature {- hmt -}
-- * Lists
-- | Variant of 'catMaybes'. If all elements of the list are @Just
-- a@, then gives @Just [a]@ else gives 'Nothing'.
--
-- > all_just (map Just [1..3]) == Just [1..3]
-- > all_just [Just 1,Nothing,Just 3] == Nothing
all_just :: [Maybe a] -> Maybe [a]
all_just x =
case x of
[] -> Just []
Just i:x' -> fmap (i :) (all_just x')
Nothing:_ -> Nothing
-- | Variant of 'Data.Either.rights' that preserves first 'Left'.
--
-- > all_right (map Right [1..3]) == Right [1..3]
-- > all_right [Right 1,Left 'a',Left 'b'] == Left 'a'
all_right :: [Either a b] -> Either a [b]
all_right x =
case x of
[] -> Right []
Right i:x' -> fmap (i :) (all_right x')
Left i:_ -> Left i
-- | 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
-- > in coalesce jn [1..5] == map sum [[1],[2,3],[4,5]]
coalesce :: (a -> a -> Maybe a) -> [a] -> [a]
coalesce f x =
case x of
(p:q:x') ->
case f p q of
Nothing -> p : coalesce f (q : x')
Just r -> coalesce f (r : x')
_ -> x
-- | Variant of 'coalesce' with accumulation parameter.
--
-- > coalesce_accum (\i 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)
-- > in 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]
-- > in 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 f i x =
case x of
[] -> []
[p] -> [(i,p)]
(p:q:x') ->
case f i p q of
Right j -> (i,p) : coalesce_accum f j (q : x')
Left r -> coalesce_accum f i (r : x')
-- | Variant of 'coalesce_accum' that accumulates running sum.
--
-- > let f i p q = if i == 1 then Just (p + q) else Nothing
-- > in 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 add zero f =
let g i p q = case f i p q of
Just r -> Left r
Nothing -> Right (i `add` p)
in map snd . coalesce_accum g zero
-- * Either
-- | Lower 'Either' to 'Maybe' by discarding 'Left'.
either_to_maybe :: Either a b -> Maybe b
either_to_maybe = either (const Nothing) Just
-- * 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 f m =
let go r n l =
let z = (reverse r,m-n,l)
in case l of
[] -> z
i:l' -> let n' = f i + n
in if n' > m
then z
else go (i:r) n' l'
in go [] 0
-- | Variant of 'take_sum_by' with 'id' function.
take_sum :: (Ord a, Num a) => a -> [a] -> ([a],a,[a])
take_sum = take_sum_by 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 f m l =
case take_sum_by f m l of
(p,0,q) -> Just (p,q)
_ -> 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 f mm l =
case (mm,l) of
([],[]) -> Just []
(m:mm',_) -> case take_sum_by_eq f m l of
Just (p,l') -> fmap (p :) (split_sum_by_eq f mm' l')
Nothing -> Nothing
_ -> Nothing
-- | Split sequence 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 m l =
let (p,n,q) = take_sum m l
in if n == 0
then if null p
then Nothing
else Just (p,q,Nothing)
else case q of
[] -> Nothing
z:q' -> Just (p++[n],z-n:q',Just (n,z-n))
-- | Alias for 'True', used locally for documentation.
_t :: Bool
_t = True
-- | Alias for 'False', used locally for documentation.
_f :: Bool
_f = False
-- | Variant of 'split_sum' that operates at 'RQ_T' sequences.
--
-- > let r = Just ([(3,_f),(2,_t)],[(1,_f)])
-- > in rqt_split_sum 5 [(3,_f),(2,_t),(1,_f)] == r
--
-- > let r = Just ([(3,_f),(1,_t)],[(1,_t),(1,_f)])
-- > in rqt_split_sum 4 [(3,_f),(2,_t),(1,_f)] == r
--
-- > rqt_split_sum 4 [(5/2,False)] == Nothing
rqt_split_sum :: RQ -> [RQ_T] -> Maybe ([RQ_T],[RQ_T])
rqt_split_sum d x =
case split_sum d (map rqt_rq x) of
Just (i,_,k) ->
case k of
Nothing -> Just (splitAt (length i) x)
Just (p,q) -> let (s,(_,z):t) = splitAt (length i - 1) x
in Just (s ++ [(p,True)]
,(q,z) : t)
Nothing -> Nothing
-- | Separate 'RQ_T' 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.
--
-- > let d = [(2,_f),(2,_f),(2,_f)]
-- > in rqt_separate [3,3] d == Right [[(2,_f),(1,_t)]
-- > ,[(1,_f),(2,_f)]]
--
-- > let d = [(5/8,_f),(1,_f),(3/8,_f)]
-- > in rqt_separate [1,1] d == Right [[(5/8,_f),(3/8,_t)]
-- > ,[(5/8,_f),(3/8,_f)]]
--
-- > let d = [(4/7,_t),(1/7,_f),(1,_f),(6/7,_f),(3/7,_f)]
-- > in rqt_separate [1,1,1] d == Right [[(4/7,_t),(1/7,_f),(2/7,_t)]
-- > ,[(5/7,_f),(2/7,_t)]
-- > ,[(4/7,_f),(3/7,_f)]]
rqt_separate :: [RQ] -> [RQ_T] -> Either String [[RQ_T]]
rqt_separate m x =
case (m,x) of
([],[]) -> Right []
([],_) -> Left (show ("rqt_separate",x))
(i:m',_) ->
case rqt_split_sum i x of
Just (r,x') -> fmap (r :) (rqt_separate m' x')
Nothing -> Left (show ("rqt_separate",i,m',x))
rqt_separate_m :: [RQ] -> [RQ_T] -> Maybe [[RQ_T]]
rqt_separate_m m = either_to_maybe . rqt_separate m
-- | If the input 'RQ_T' 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_T] -> Either String [[RQ_T]]
rqt_separate_tuplet i x =
if rqt_can_notate x
then Left (show ("rqt_separate_tuplet: separation not required",x))
else let j = sum (map rqt_rq x) / 2
in if j < i
then Left (show ("rqt_separate_tuplet: j < i",j,i))
else rqt_separate [j,j] 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_T] -> [[RQ_T]]
rqt_tuplet_subdivide i x =
case rqt_separate_tuplet i x of
Left _ -> [x]
Right r -> concatMap (rqt_tuplet_subdivide i) 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_T]] -> [[RQ_T]]
rqt_tuplet_subdivide_seq i = concatMap (rqt_tuplet_subdivide 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_T] -> [RQ_T]
rqt_tuplet_sanity_ t =
let last_tied = rqt_tied (last t)
all_tied = all rqt_tied (dropRight 1 t)
in if all_tied
then [(sum (map rqt_rq t),last_tied)]
else t
rqt_tuplet_subdivide_seq_sanity_ :: RQ -> [[RQ_T]] -> [[RQ_T]]
rqt_tuplet_subdivide_seq_sanity_ i =
map rqt_tuplet_sanity_ .
rqt_tuplet_subdivide_seq 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_T]]
to_measures_rq m = rqt_separate m . map rq_rqt
-- | Variant of 'to_measures_rq' that ensures 'RQ_T' 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_T]]
to_measures_rq_cmn m = fmap (map rqt_set_to_cmn) . to_measures_rq m
-- | Variant of 'to_measures_rq' with measures given by
-- 'Time_Signature' values. Does not ensure 'RQ_T' 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_T]]
to_measures_ts m = to_measures_rq (map ts_rq 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 f m = split_sum_by_eq f (map ts_rq 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_T] -> Either String [[RQ_T]]
m_divisions_rq z =
fmap (rqt_tuplet_subdivide_seq_sanity_ (1/16) .
map rqt_set_to_cmn) .
rqt_separate 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_T] -> Either String [[RQ_T]]
m_divisions_ts ts = m_divisions_rq (ts_divisions 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_T]]]
to_divisions_rq m x =
let m' = map sum m
in case to_measures_rq m' x of
Right y -> all_right (zipWith m_divisions_rq m y)
Left e -> Left 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_T]]]
to_divisions_ts ts = to_divisions_rq (map ts_divisions 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_T] -> Maybe ((Integer,Integer),[RQ_T])
p_tuplet_rqt x =
let f t = (t,map (rqt_un_tuplet t) x)
in fmap f (rq_derive_tuplet (map rqt_rq 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_T] -> Either String [Duration_A]
p_notate z x =
let f = p_simplify . rqt_to_duration_a z
d = case p_tuplet_rqt x of
Just (t,x') -> da_tuplet t (f x')
Nothing -> f x
in if rq_can_notate (map rqt_rq x)
then Right d
else Left (show ("p_notate",z,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_T]] -> Either String [Duration_A]
m_notate z m =
let z' = z : map (is_tied_right . last) m
in fmap concat (all_right (zipWith p_notate z' 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_T]]] -> Either String [[Duration_A]]
mm_notate d =
let z = False : map (is_tied_right . last . last) d
in all_right (zipWith m_notate z 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 (tt,ss,pp) (t,s,p) = t `elem` tt && s `elem` ss && p `elem` pp
-- | Transform 'Simplify_M' to set of 'Simplify_T'.
meta_table_t :: Simplify_M -> [Simplify_T]
meta_table_t (tt,ss,pp) = [(t,s,p) | t <- tt, s <- ss,p <- pp]
-- | The default table of simplifiers.
--
-- > default_table ((3,4),1,(1,1)) == True
default_table :: Simplify_P
default_table x =
let t :: [Simplify_M]
t = [([(3,4)],[1],[(1,1)])]
p :: [Simplify_P]
p = map meta_table_p t
in or (p <*> pure 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 ((i,j),t,(p,q)) =
let r = p + q
in j == 8 &&
denominator t `elem` [1,2] &&
(r <= 2 || r == ts_rq (i,j) || rq_is_integral 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 ((_,j),t,(p,q)) =
let r = p + q
in j == 4 &&
denominator t == 1 &&
even (numerator t) &&
(r <= 2 || rq_is_integral 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 x r = r `elem` x ||
{-default_aligned_pulse_rule r ||-}
default_4_rule r ||
default_8_rule r ||
default_table r
-- | Measure simplifier. Apply given 'Simplify_P'.
m_simplify :: Simplify_P -> Time_Signature -> [Duration_A] -> [Duration_A]
m_simplify p ts =
let f st (d0,a0) (d1,a1) =
let t = Tie_Right `elem` a0 && Tie_Left `elem` a1
e = End_Tuplet `notElem` a0 && not (any begins_tuplet a1)
m = duration_meq d0 d1
d = sum_dur d0 d1
a = delete Tie_Right a0 ++ delete Tie_Left a1
r = p (ts,st,(duration_to_rq d0,duration_to_rq d1))
n_dots = 1
g i = if dots i <= n_dots && t && e && m && r
then Just (i,a)
else Nothing
in join (fmap g d)
z i (j,_) = i + duration_to_rq j
in coalesce_sum z 0 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 limit p ts d =
let d' = m_simplify p ts d
in if d == d' || limit == 1
then d'
else m_simplify_fix (limit - 1) p ts d'
-- | Pulse simplifier predicate, which is 'const' 'True'.
p_simplify_rule :: Simplify_P
p_simplify_rule = const 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 = m_simplify p_simplify_rule 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 limit r ts ts_p x = do
let ts_p' = fromMaybe (map ts_divisions ts) ts_p
mm <- to_divisions_rq ts_p' x
dd <- mm_notate mm
return (zipWith (m_simplify_fix limit r) ts 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 limit r ts x = notate_rqp limit r ts Nothing x
-- * 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 lhs_f =
let f st e =
case st of
r:s -> let st' = if lhs_f e then st else s
in (st',(e,r))
_ -> error (show ("zip_hold_lhs: rhs ends",st,e))
in flip (mapAccumL 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 lhs_f p q =
case zip_hold_lhs lhs_f p q of
([],r) -> r
e -> error (show ("zip_hold_lhs_err: lhs ends",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 lhs_f rhs_f =
let f r x t =
case (x,t) of
([],_) -> (t,reverse r)
(_,[]) -> error "zip_hold: rhs ends"
(x0:x',t0:t') -> let x'' = if rhs_f t0 then x else x'
t'' = if lhs_f x0 then t else t'
in f ((x0,t0) : r) x'' t''
in 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 = zip_hold_lhs da_tied_right
-- | 'snd' '.' 'm_ascribe'.
ascribe :: Show x => [Duration_A] -> [x] -> [(Duration_A, x)]
ascribe d = snd . m_ascribe d
-- | Variant of 'm_ascribe' for a set of measures.
mm_ascribe :: Show x => [[Duration_A]] -> [x] -> [[(Duration_A,x)]]
mm_ascribe mm x =
case mm of
[] -> []
m:mm' -> let (x',r) = m_ascribe m x
in r : mm_ascribe mm' 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 limit r ts rqp d p =
let n = notate_rqp limit (default_rule r) ts rqp d
f = flip mm_ascribe p
err str = show ("notate_ascribe",str,ts,d,p)
in either (Left . err) (Right . f) n
notate_mm_ascribe_err :: Show a => Int -> [Simplify_T] -> [Time_Signature] -> Maybe [[RQ]] -> [RQ] -> [a] ->
[[(Duration_A,a)]]
notate_mm_ascribe_err = either error id .::::: 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 f x =
case split (keepDelimsL (whenElt (not.f))) x of
[]:r -> r
_ -> error "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 chd_f d x =
let x' = group_chd chd_f x
jn (i,j) = zip (repeat i) j
in concatMap jn (ascribe d x')
-- | Variant of 'mm_ascribe' using 'group_chd'
mm_ascribe_chd :: Show x => (x -> Bool) -> [[Duration_A]] -> [x] -> [[(Duration_A,x)]]
mm_ascribe_chd chd_f d x =
let x' = group_chd chd_f x
jn (i,j) = zip (repeat i) j
in map (concatMap jn) (mm_ascribe d x')