{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}

module Fadno.Meter where

import Fadno.Notation
import Fadno.Note
import Control.Lens hiding (Empty,pre)
import Data.Foldable
import Test.HUnit
import Data.Ratio
import GHC.Real
import Data.Maybe
import Data.List (sort,sortBy,nub)
import Data.Function
import Control.Arrow
import qualified Data.Map.Strict as M
import Safe
import Fadno.Util

type HasRatioNotes t n p = (Traversable t, HasNote n p Rational)

--
-- REBAR
--

-- | use 'rebar' with multiple input "bars".
rebars :: (HasRatioNotes b n p, HasRatioNotes c m p,Monoid p,Eq p,
           Monoid (c m), Monoid (b n),HasTimeSignature (c m),
           Snoc (c m) (c m) m m,HasTie m,Show (c m)) =>
          TimeSignature -> [b n] -> [c m]
rebars :: TimeSignature -> [b n] -> [c m]
rebars TimeSignature
ts = TimeSignature -> b n -> [c m]
forall (b :: * -> *) n p (c :: * -> *) m.
(HasRatioNotes b n p, HasRatioNotes c m p, Monoid p, Eq p,
 Monoid (c m), HasTimeSignature (c m), Snoc (c m) (c m) m m,
 HasTie m, Show (c m)) =>
TimeSignature -> b n -> [c m]
rebar TimeSignature
ts (b n -> [c m]) -> ([b n] -> b n) -> [b n] -> [c m]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [b n] -> b n
forall a. Monoid a => [a] -> a
mconcat

-- | Given a time signature and a "bar" (Traversable "b" of HasNotes "n"),
-- make new "bars" (Traversable "c" of HasNotes "m"),
-- partitioning notes, applying ties as needed,
-- and decorating with the time signature.
rebar :: (HasRatioNotes b n p, HasRatioNotes c m p,Monoid p,Eq p,Monoid (c m),
          HasTimeSignature (c m),Snoc (c m) (c m) m m,HasTie m,Show (c m)) =>
         TimeSignature -> b n -> [c m]
rebar :: TimeSignature -> b n -> [c m]
rebar TimeSignature
ts = [c m] -> [c m]
forall a. [a] -> [a]
reverse ([c m] -> [c m]) -> (b n -> [c m]) -> b n -> [c m]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [c m] -> [c m]
forall (t :: * -> *) a p.
(Monoid (t a), HasTimeSignature (t a), Traversable t,
 HasNote a p Rational) =>
[t a] -> [t a]
fixup ([c m] -> [c m]) -> (b n -> [c m]) -> b n -> [c m]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([c m] -> m -> [c m]) -> [c m] -> b m -> [c m]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [c m] -> m -> [c m]
forall (t :: * -> *) a s p p p p.
(Snoc (t a) (t a) s s, Monoid (t a), HasNote s p Rational,
 HasNote a p Rational, Traversable t, HasNote s p Rational,
 Monoid p, Eq p, HasTie s, HasNote s p Rational, Monoid p, Eq p) =>
[t a] -> s -> [t a]
go [c m
forall a. Monoid a => a
mempty] (b m -> [c m]) -> (b n -> b m) -> b n -> [c m]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (n -> m) -> b n -> b m
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap n -> m
forall s p d n. (HasNote s p d, HasNote n p d) => n -> s
fromNote where
    tslen :: Rational
tslen = TimeSignature -> Rational
tsToRatio TimeSignature
ts
    go :: [t a] -> s -> [t a]
go bss :: [t a]
bss@[] s
_ = [t a]
bss -- error case but might as well be total
    go bss :: [t a]
bss@(t a
b:[t a]
bs) s
n | Rational
barlen Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
tslen = [t a] -> s -> [t a]
go (t a
forall a. Monoid a => a
memptyt a -> [t a] -> [t a]
forall a. a -> [a] -> [a]
:[t a]
bss) s
n
                    | Rational
newBarLen Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational
tslen = (t a
b t a -> s -> t a
forall s a. Snoc s s a a => s -> a -> s
|> s
n)t a -> [t a] -> [t a]
forall a. a -> [a] -> [a]
:[t a]
bs
                    | Bool
otherwise = {- trace1' "otherwise" (remaining, ndur) $ -} [t a] -> s -> [t a]
go ((t a
b t a -> s -> t a
forall s a. Snoc s s a a => s -> a -> s
|> s
pre)t a -> [t a] -> [t a]
forall a. a -> [a] -> [a]
:[t a]
bs) s
post
        where barlen :: Rational
barlen = t a -> Rational
forall d a p (t :: * -> *).
(Num d, HasNote a p d, Traversable t) =>
t a -> d
sumDurs t a
b
              ndur :: Rational
ndur = Getting Rational s Rational -> s -> Rational
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Rational s Rational
forall s p d. HasNote s p d => Lens' s d
noteDur s
n
              newBarLen :: Rational
newBarLen = Rational
barlen Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ Rational
ndur
              remaining :: Rational
remaining = Rational
newBarLen Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
tslen
              post :: s
post = Tie -> s -> s
forall a s d.
(Eq a, Monoid a, HasNote s a d, HasTie s) =>
Tie -> s -> s
tieMay Tie
TStop (s -> s) -> (s -> s) -> s -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter s s Rational Rational -> Rational -> s -> s
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter s s Rational Rational
forall s p d. HasNote s p d => Lens' s d
noteDur Rational
remaining (s -> s) -> s -> s
forall a b. (a -> b) -> a -> b
$ s
n
              pre :: s
pre = Tie -> s -> s
forall a s d.
(Eq a, Monoid a, HasNote s a d, HasTie s) =>
Tie -> s -> s
tieMay Tie
TStart (s -> s) -> (s -> s) -> s -> s
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter s s Rational Rational -> Rational -> s -> s
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter s s Rational Rational
forall s p d. HasNote s p d => Lens' s d
noteDur (Rational
ndur Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
remaining) (s -> s) -> s -> s
forall a b. (a -> b) -> a -> b
$ s
n
    -- fixup: set head and tail timesigs
    fixup :: [t a] -> [t a]
fixup [] = []
    fixup [t a]
bs = ASetter [t a] [t a] (t a) (t a) -> (t a -> t a) -> [t a] -> [t a]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter [t a] [t a] (t a) (t a)
forall s a. Cons s s a a => Traversal' s a
_head t a -> t a
forall (t :: * -> *) a p.
(HasTimeSignature (t a), HasNote a p Rational, Traversable t) =>
t a -> t a
fixLast ([t a] -> [t a]) -> ([t a] -> [t a]) -> [t a] -> [t a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [t a] -> [t a]
forall a p (t :: * -> *).
(HasNote a p Rational, Traversable t, Monoid (t a)) =>
[t a] -> [t a]
joinLast ([t a] -> [t a]) -> ([t a] -> [t a]) -> [t a] -> [t a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter [t a] [t a] (t a) (t a) -> (t a -> t a) -> [t a] -> [t a]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter [t a] [t a] (t a) (t a)
forall s a. Snoc s s a a => Traversal' s a
_last ((Maybe TimeSignature -> Identity (Maybe TimeSignature))
-> t a -> Identity (t a)
forall a. HasTimeSignature a => Lens' a (Maybe TimeSignature)
timeSignature ((Maybe TimeSignature -> Identity (Maybe TimeSignature))
 -> t a -> Identity (t a))
-> TimeSignature -> t a -> t a
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ TimeSignature
ts) ([t a] -> [t a]) -> [t a] -> [t a]
forall a b. (a -> b) -> a -> b
$ [t a]
bs
    fixLast :: t a -> t a
fixLast t a
b | Rational
barlen Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
tslen = t a
b
              | Bool
otherwise = case TimeSignature -> Rational -> Maybe TimeSignature
tsFromRatio' TimeSignature
ts Rational
barlen of
                              Just TimeSignature
t -> t a
b t a -> (t a -> t a) -> t a
forall a b. a -> (a -> b) -> b
& (Maybe TimeSignature -> Identity (Maybe TimeSignature))
-> t a -> Identity (t a)
forall a. HasTimeSignature a => Lens' a (Maybe TimeSignature)
timeSignature ((Maybe TimeSignature -> Identity (Maybe TimeSignature))
 -> t a -> Identity (t a))
-> TimeSignature -> t a -> t a
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ TimeSignature
t
                              Maybe TimeSignature
Nothing -> t a
b
              where barlen :: Rational
barlen = t a -> Rational
forall d a p (t :: * -> *).
(Num d, HasNote a p d, Traversable t) =>
t a -> d
sumDurs t a
b
    -- joinLast: apply heuristic that an additional bar less than 1/2 the ts length
    -- should be merged with the prior bar.
    joinLast :: [t a] -> [t a]
joinLast aas :: [t a]
aas@(t a
a:t a
b:[t a]
as) | t a -> Rational
forall d a p (t :: * -> *).
(Num d, HasNote a p d, Traversable t) =>
t a -> d
sumDurs t a
a Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
+ t a -> Rational
forall d a p (t :: * -> *).
(Num d, HasNote a p d, Traversable t) =>
t a -> d
sumDurs t a
b Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
tslen Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (Integer
3Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
2) =
                              (t a
b t a -> t a -> t a
forall a. Monoid a => a -> a -> a
`mappend` t a
a)t a -> [t a] -> [t a]
forall a. a -> [a] -> [a]
:[t a]
as -- leave notes tied. why not.
                          | Bool
otherwise = [t a]
aas
    joinLast [t a]
a = [t a]
a



-- | 'rebar' using 'Bar' and 'Note\'' for output.
rebar' :: (HasRatioNotes b n p,Monoid p,Eq p,Show p) =>
          TimeSignature -> b n -> [Bar (Note' p Rational)]
rebar' :: TimeSignature -> b n -> [Bar (Note' p Rational)]
rebar' = TimeSignature -> b n -> [Bar (Note' p Rational)]
forall (b :: * -> *) n p (c :: * -> *) m.
(HasRatioNotes b n p, HasRatioNotes c m p, Monoid p, Eq p,
 Monoid (c m), HasTimeSignature (c m), Snoc (c m) (c m) m m,
 HasTie m, Show (c m)) =>
TimeSignature -> b n -> [c m]
rebar

-- | 'rebars' using 'Bar' and 'Note\'' for output.
rebars' :: (HasRatioNotes b n p,Monoid (b n),Monoid p,Eq p,Show p) =>
           TimeSignature -> [b n] -> [Bar (Note' p Rational)]
rebars' :: TimeSignature -> [b n] -> [Bar (Note' p Rational)]
rebars' = TimeSignature -> [b n] -> [Bar (Note' p Rational)]
forall (b :: * -> *) n p (c :: * -> *) m.
(HasRatioNotes b n p, HasRatioNotes c m p, Monoid p, Eq p,
 Monoid (c m), Monoid (b n), HasTimeSignature (c m),
 Snoc (c m) (c m) m m, HasTie m, Show (c m)) =>
TimeSignature -> [b n] -> [c m]
rebars

-- | Set tie if not a rest
tieMay :: (Eq a, Monoid a, HasNote s a d, HasTie s) => Tie -> s -> s
tieMay :: Tie -> s -> s
tieMay Tie
end s
v | s -> Bool
forall p n d. (Monoid p, Eq p, HasNote n p d) => n -> Bool
isRest s
v = s
v
             | Bool
otherwise = ASetter s s (Maybe Tie) (Maybe Tie)
-> (Maybe Tie -> Maybe Tie) -> s -> s
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter s s (Maybe Tie) (Maybe Tie)
forall a. HasTie a => Lens' a (Maybe Tie)
tie Maybe Tie -> Maybe Tie
setTie s
v
             where setTie :: Maybe Tie -> Maybe Tie
setTie o :: Maybe Tie
o@(Just Tie
old) | Tie
old Tie -> Tie -> Bool
forall a. Eq a => a -> a -> Bool
== Tie
end = Maybe Tie
o
                                       | Bool
otherwise = Tie -> Maybe Tie
forall a. a -> Maybe a
Just Tie
TBoth
                   setTie Maybe Tie
Nothing = Tie -> Maybe Tie
forall a. a -> Maybe a
Just Tie
end



--
-- TIE RULES
--

-- | Representable duration denominators.
--
-- For standard base-2 durs, 2 and 4 are spurious as they reduce to 1,
-- thus 1 plus the "dot values" 3,7.
--
-- For non-standard (quintuples etc), we admit 2 and 4 as well, for e.g. 2%5,
-- a "half-note" under a quarter-quintuple. Anything greater
-- exceeding the understanding limit: 8%17 can certainly be represented as
-- a half-note, but it makes little sense to the reader.
validDenoms :: [Integer]
validDenoms :: [Integer]
validDenoms = [Integer
1,Integer
2,Integer
3,Integer
4,Integer
7]

-- | Max representable duration.
maxDur :: Rational
maxDur :: Rational
maxDur = Rational
2

-- | Test for representational duration per 'validDenoms' and 'maxDur'.
validDur :: Rational -> Bool
validDur :: Rational -> Bool
validDur Rational
r = Rational
r Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
maxDur Bool -> Bool -> Bool
||
             (Rational
r Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
maxDur Bool -> Bool -> Bool
&& Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r Integer -> [Integer] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Integer]
validDenoms)

-- | Tie rules that work across any denominators, such that
-- 5%8 -> [1%2,1%8], 9%16 -> [1%2,1%16],  11%16 -> [1%2,3%16],
-- 13%16 -> [3%2,1%16], 9%4 -> [2,1%4].
splitDur :: Rational -> [Rational]
splitDur :: Rational -> [Rational]
splitDur Rational
r | Rational
r Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
0 = [Char] -> [Rational]
forall a. HasCallStack => [Char] -> a
error [Char]
"splitDur: negative duration"
           | Rational
r Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
0 = []
           | Rational -> Bool
validDur Rational
r = [Rational
r]
           -- NB: subtraction doesn't preserve denom (17:%20 - 3%5 -> 1%4, not 5%20)
           | Bool
otherwise = Rational
splitRational -> [Rational] -> [Rational]
forall a. a -> [a] -> [a]
:Rational -> [Rational]
splitDur (Rational
r Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
split)
           where split :: Rational
split = Rational -> Rational
findSplit Rational
r

-- | Find split by 1) finding largest power-of-2 fraction under value or
-- 2) finding longest power-of-two denominator split, up to 8.
findSplit :: Rational -> Rational
findSplit :: Rational -> Rational
findSplit Rational
r = case (Rational -> Bool) -> [Rational] -> [Rational]
forall a. (a -> Bool) -> [a] -> [a]
filter Rational -> Bool
validDur [Rational]
candidates of
                [] -> Rational
splitOnValid
                (Rational
v:[Rational]
_) -> Rational
v
    where
      n :: Integer
n = Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r
      d :: Integer
d = Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r
      pow2s :: [Integer]
pow2s = [Integer
x | Integer
p <- [(Integer
1 :: Integer)..], Integer
x<-[Integer
2Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^Integer
p]]
      denomPow2s :: [Integer]
denomPow2s = [Integer] -> [Integer]
forall a. [a] -> [a]
reverse ([Integer] -> [Integer]) -> [Integer] -> [Integer]
forall a b. (a -> b) -> a -> b
$ (Integer -> Bool) -> [Integer] -> [Integer]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\Integer
v -> Integer
v Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
d Bool -> Bool -> Bool
&& Integer
d Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`rem` Integer
v Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0) [Integer]
pow2s
      candidates :: [Rational]
candidates = (Rational -> Bool) -> [Rational] -> [Rational]
forall a. (a -> Bool) -> [a] -> [a]
filter (Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<Rational
r) ([Rational] -> [Rational]) -> [Rational] -> [Rational]
forall a b. (a -> b) -> a -> b
$ (Integer -> Rational) -> [Integer] -> [Rational]
forall a b. (a -> b) -> [a] -> [b]
map (\Integer
cd -> (Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
cd Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
d) Integer -> Integer -> Rational
forall a. a -> a -> Ratio a
:% (Integer
d Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
cd)) [Integer]
denomPow2s
      splitOnValid :: Rational
splitOnValid = case (Rational -> Bool) -> [Rational] -> [Rational]
forall a. (a -> Bool) -> [a] -> [a]
filter (Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
min Rational
r Rational
maxDur) ([Rational] -> [Rational]) -> [Rational] -> [Rational]
forall a b. (a -> b) -> a -> b
$ (Integer -> Rational) -> [Integer] -> [Rational]
forall a b. (a -> b) -> [a] -> [b]
map (Integer -> Integer -> Rational
forall a. a -> a -> Ratio a
:%Integer
d) ([Integer] -> [Rational]) -> [Integer] -> [Rational]
forall a b. (a -> b) -> a -> b
$ [Integer] -> [Integer]
forall a. [a] -> [a]
reverse ([Integer] -> [Integer]) -> [Integer] -> [Integer]
forall a b. (a -> b) -> a -> b
$
                     (Integer -> Bool) -> [Integer] -> [Integer]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min Integer
n Integer
8) [Integer]
pow2s of
                       [] -> Rational
r
                       (Rational
v:[Rational]
_) -> Rational
v

-- | Apply rules in 'splitDur' and tie affected notes.
tieRules :: (HasRatioNotes b n p, HasTie n, Monoid p, Eq p, Show n,
             HasRatioNotes c m p, HasTie m, Monoid (c m),
             Snoc (c m) (c m) m m) => b n -> c m
tieRules :: b n -> c m
tieRules = (c m -> n -> c m) -> c m -> b n -> c m
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' c m -> n -> c m
forall p a s c.
(Monoid p, Eq p, Show s, Snoc c c a a, HasNote a p Rational,
 HasNote s p Rational, HasTie s, HasTie a) =>
c -> s -> c
apply c m
forall a. Monoid a => a
mempty where
    apply :: c -> s -> c
apply c
r s
n = case Rational -> [Rational]
splitDur (Getting Rational s Rational -> s -> Rational
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Rational s Rational
forall s p d. HasNote s p d => Lens' s d
noteDur s
n) of
                       [] -> [Char] -> c
forall a. HasCallStack => [Char] -> a
error ([Char] -> c) -> [Char] -> c
forall a b. (a -> b) -> a -> b
$ [Char]
"tieRules: empty result from splitDur for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ s -> [Char]
forall a. Show a => a -> [Char]
show s
n
                       [Rational
_] -> c
r c -> a -> c
forall s a. Snoc s s a a => s -> a -> s
|> ASetter a a (Maybe Tie) (Maybe Tie) -> Maybe Tie -> a -> a
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter a a (Maybe Tie) (Maybe Tie)
forall a. HasTie a => Lens' a (Maybe Tie)
tie (Getting (Maybe Tie) s (Maybe Tie) -> s -> Maybe Tie
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Tie) s (Maybe Tie)
forall a. HasTie a => Lens' a (Maybe Tie)
tie s
n) (s -> a
forall s p d n. (HasNote s p d, HasNote n p d) => n -> s
fromNote s
n)
                       [Rational]
ds -> (c -> a -> c) -> c -> [a] -> c
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl c -> a -> c
forall s a. Snoc s s a a => s -> a -> s
(|>) c
r ([a] -> c) -> ([Rational] -> [a]) -> [Rational] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
fixLast ([a] -> [a]) -> ([Rational] -> [a]) -> [Rational] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> [a]
fixFirst ([a] -> [a]) -> ([Rational] -> [a]) -> [Rational] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational -> a) -> [Rational] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map Rational -> a
forall s p d.
(HasTie s, Eq p, Monoid p, HasNote s p d, HasNote s p d) =>
d -> s
mkTied ([Rational] -> c) -> [Rational] -> c
forall a b. (a -> b) -> a -> b
$ [Rational]
ds
                           where mkTied :: d -> s
mkTied d
d = Tie -> s -> s
forall a s d.
(Eq a, Monoid a, HasNote s a d, HasTie s) =>
Tie -> s -> s
tieMay Tie
TBoth (ASetter s s d d -> d -> s -> s
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter s s d d
forall s p d. HasNote s p d => Lens' s d
noteDur d
d (s -> s
forall s p d n. (HasNote s p d, HasNote n p d) => n -> s
fromNote s
n))
                                 forOrgTie :: Tie -> Tie
forOrgTie Tie
t = case Getting (Maybe Tie) s (Maybe Tie) -> s -> Maybe Tie
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (Maybe Tie) s (Maybe Tie)
forall a. HasTie a => Lens' a (Maybe Tie)
tie s
n of
                                                 Maybe Tie
Nothing -> Tie
t
                                                 (Just Tie
a) | Tie
a Tie -> Tie -> Bool
forall a. Eq a => a -> a -> Bool
== Tie
t -> Tie
t
                                                          | Bool
otherwise -> Tie
TBoth
                                 fixFirst :: [a] -> [a]
fixFirst = ASetter [a] [a] (Maybe Tie) (Maybe Tie)
-> (Maybe Tie -> Maybe Tie) -> [a] -> [a]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((a -> Identity a) -> [a] -> Identity [a]
forall s a. Cons s s a a => Traversal' s a
_head((a -> Identity a) -> [a] -> Identity [a])
-> ASetter a a (Maybe Tie) (Maybe Tie)
-> ASetter [a] [a] (Maybe Tie) (Maybe Tie)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ASetter a a (Maybe Tie) (Maybe Tie)
forall a. HasTie a => Lens' a (Maybe Tie)
tie) ((Tie -> Tie) -> Maybe Tie -> Maybe Tie
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tie -> Tie -> Tie
forall a b. a -> b -> a
const (Tie -> Tie
forOrgTie Tie
TStart)))
                                 fixLast :: [a] -> [a]
fixLast = ASetter [a] [a] (Maybe Tie) (Maybe Tie)
-> (Maybe Tie -> Maybe Tie) -> [a] -> [a]
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((a -> Identity a) -> [a] -> Identity [a]
forall s a. Snoc s s a a => Traversal' s a
_last((a -> Identity a) -> [a] -> Identity [a])
-> ASetter a a (Maybe Tie) (Maybe Tie)
-> ASetter [a] [a] (Maybe Tie) (Maybe Tie)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.ASetter a a (Maybe Tie) (Maybe Tie)
forall a. HasTie a => Lens' a (Maybe Tie)
tie) ((Tie -> Tie) -> Maybe Tie -> Maybe Tie
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Tie -> Tie -> Tie
forall a b. a -> b -> a
const (Tie -> Tie
forOrgTie Tie
TStop)))



-- | Monomorphic-result 'tieRules
tieRules' :: (HasRatioNotes b n p, HasTie n, Monoid p, Eq p, Show n) =>
             b n -> Bar (Note' p Rational)
tieRules' :: b n -> Bar (Note' p Rational)
tieRules' = b n -> Bar (Note' p Rational)
forall (b :: * -> *) n p (c :: * -> *) m.
(HasRatioNotes b n p, HasTie n, Monoid p, Eq p, Show n,
 HasRatioNotes c m p, HasTie m, Monoid (c m),
 Snoc (c m) (c m) m m) =>
b n -> c m
tieRules


--
-- SELECT TIMESIG
--

-- | Weights and pulse values for pre-configured TSs.
data TsConfig = TsConfig {
      TsConfig -> TimeSignature
_tSig :: TimeSignature
    , TsConfig -> Rational
_tWeight :: Rational
    , TsConfig -> Rational
_tPulse :: Rational
    } deriving (TsConfig -> TsConfig -> Bool
(TsConfig -> TsConfig -> Bool)
-> (TsConfig -> TsConfig -> Bool) -> Eq TsConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TsConfig -> TsConfig -> Bool
$c/= :: TsConfig -> TsConfig -> Bool
== :: TsConfig -> TsConfig -> Bool
$c== :: TsConfig -> TsConfig -> Bool
Eq,Int -> TsConfig -> [Char] -> [Char]
[TsConfig] -> [Char] -> [Char]
TsConfig -> [Char]
(Int -> TsConfig -> [Char] -> [Char])
-> (TsConfig -> [Char])
-> ([TsConfig] -> [Char] -> [Char])
-> Show TsConfig
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [TsConfig] -> [Char] -> [Char]
$cshowList :: [TsConfig] -> [Char] -> [Char]
show :: TsConfig -> [Char]
$cshow :: TsConfig -> [Char]
showsPrec :: Int -> TsConfig -> [Char] -> [Char]
$cshowsPrec :: Int -> TsConfig -> [Char] -> [Char]
Show)
makeLenses ''TsConfig

selectTimeSig :: HasRatioNotes t n p => [t n] -> Maybe TimeSignature
selectTimeSig :: [t n] -> Maybe TimeSignature
selectTimeSig [t n]
phrases = ((TimeSignature, Rational) -> TimeSignature)
-> Maybe (TimeSignature, Rational) -> Maybe TimeSignature
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (TimeSignature, Rational) -> TimeSignature
forall a b. (a, b) -> a
fst (Maybe (TimeSignature, Rational) -> Maybe TimeSignature)
-> Maybe (TimeSignature, Rational) -> Maybe TimeSignature
forall a b. (a -> b) -> a -> b
$ [(TimeSignature, Rational)] -> Maybe (TimeSignature, Rational)
forall a. [a] -> Maybe a
headMay ([(TimeSignature, Rational)] -> Maybe (TimeSignature, Rational))
-> [(TimeSignature, Rational)] -> Maybe (TimeSignature, Rational)
forall a b. (a -> b) -> a -> b
$ [t n] -> [(TimeSignature, Rational)]
forall (t :: * -> *) n p.
HasRatioNotes t n p =>
[t n] -> [(TimeSignature, Rational)]
selectTimeSigs [t n]
phrases

-- | Combine scores from phrases.
selectTimeSigs :: HasRatioNotes t n p => [t n] -> [(TimeSignature,Rational)]
selectTimeSigs :: [t n] -> [(TimeSignature, Rational)]
selectTimeSigs = [[TsConfig]] -> [(TimeSignature, Rational)]
mergeScores ([[TsConfig]] -> [(TimeSignature, Rational)])
-> ([t n] -> [[TsConfig]]) -> [t n] -> [(TimeSignature, Rational)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[TsConfig]] -> [[TsConfig]]
preferDivisableHeads ([[TsConfig]] -> [[TsConfig]])
-> ([t n] -> [[TsConfig]]) -> [t n] -> [[TsConfig]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t n -> [TsConfig]) -> [t n] -> [[TsConfig]]
forall a b. (a -> b) -> [a] -> [b]
map t n -> [TsConfig]
forall (t :: * -> *) n p. HasRatioNotes t n p => t n -> [TsConfig]
selectTsConfigs where
    mergeScores :: [[TsConfig]] -> [(TimeSignature, Rational)]
mergeScores = ((TimeSignature, Rational)
 -> (TimeSignature, Rational) -> Ordering)
-> [(TimeSignature, Rational)] -> [(TimeSignature, Rational)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Rational -> Rational -> Ordering)
-> Rational -> Rational -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Rational -> Rational -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Rational -> Rational -> Ordering)
-> ((TimeSignature, Rational) -> Rational)
-> (TimeSignature, Rational)
-> (TimeSignature, Rational)
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (TimeSignature, Rational) -> Rational
forall a b. (a, b) -> b
snd) ([(TimeSignature, Rational)] -> [(TimeSignature, Rational)])
-> ([[TsConfig]] -> [(TimeSignature, Rational)])
-> [[TsConfig]]
-> [(TimeSignature, Rational)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                  Map TimeSignature Rational -> [(TimeSignature, Rational)]
forall k a. Map k a -> [(k, a)]
M.toList (Map TimeSignature Rational -> [(TimeSignature, Rational)])
-> ([[TsConfig]] -> Map TimeSignature Rational)
-> [[TsConfig]]
-> [(TimeSignature, Rational)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map TimeSignature Rational
 -> Map TimeSignature Rational -> Map TimeSignature Rational)
-> [Map TimeSignature Rational] -> Map TimeSignature Rational
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 ((Rational -> Rational -> Rational)
-> Map TimeSignature Rational
-> Map TimeSignature Rational
-> Map TimeSignature Rational
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
M.unionWith Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
(+)) ([Map TimeSignature Rational] -> Map TimeSignature Rational)
-> ([[TsConfig]] -> [Map TimeSignature Rational])
-> [[TsConfig]]
-> Map TimeSignature Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                  ([TsConfig] -> Map TimeSignature Rational)
-> [[TsConfig]] -> [Map TimeSignature Rational]
forall a b. (a -> b) -> [a] -> [b]
map ((Rational -> Rational -> Rational)
-> [(TimeSignature, Rational)] -> Map TimeSignature Rational
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
max ([(TimeSignature, Rational)] -> Map TimeSignature Rational)
-> ([TsConfig] -> [(TimeSignature, Rational)])
-> [TsConfig]
-> Map TimeSignature Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TsConfig -> (TimeSignature, Rational))
-> [TsConfig] -> [(TimeSignature, Rational)]
forall a b. (a -> b) -> [a] -> [b]
map (TsConfig -> TimeSignature
_tSig (TsConfig -> TimeSignature)
-> (TsConfig -> Rational) -> TsConfig -> (TimeSignature, Rational)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& TsConfig -> Rational
_tWeight))


-- | nutty heuristic that overweights a TS for a uniform duration divisor
preferDivisableHeads :: [[TsConfig]] -> [[TsConfig]]
preferDivisableHeads :: [[TsConfig]] -> [[TsConfig]]
preferDivisableHeads [] = []
preferDivisableHeads [[TsConfig]
a] = [[TsConfig]
a]
preferDivisableHeads [[TsConfig]]
phraseTss =
    case [Maybe TsConfig] -> Maybe [TsConfig]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (([TsConfig] -> Maybe TsConfig) -> [[TsConfig]] -> [Maybe TsConfig]
forall a b. (a -> b) -> [a] -> [b]
map [TsConfig] -> Maybe TsConfig
forall a. [a] -> Maybe a
headMay [[TsConfig]]
phraseTss) of
      Maybe [TsConfig]
Nothing -> [[TsConfig]]
phraseTss
      Just [TsConfig]
heads | [TsConfig] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([TsConfig] -> [TsConfig]
forall a. Eq a => [a] -> [a]
nub [TsConfig]
heads) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 -> [[TsConfig]]
phraseTss
                 | Bool
otherwise -> case [Rational] -> [Rational]
forall a. Eq a => [a] -> [a]
nub ([Rational] -> [Rational]) -> [Rational] -> [Rational]
forall a b. (a -> b) -> a -> b
$ ((Rational -> Rational -> Rational)
-> [Rational] -> [Rational] -> [Rational]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Rational -> Rational -> Rational
commonDivHeur ([Rational] -> [Rational] -> [Rational])
-> ([Rational] -> [Rational]) -> [Rational] -> [Rational]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Rational] -> [Rational]
forall a. [a] -> [a]
tail) ((TsConfig -> Rational) -> [TsConfig] -> [Rational]
forall a b. (a -> b) -> [a] -> [b]
map TsConfig -> Rational
tsConfigToDur [TsConfig]
heads) of
                      [] -> [[TsConfig]]
phraseTss
                      [Rational
a] -> [[TsConfig]]
-> (TsConfig -> [[TsConfig]]) -> Maybe TsConfig -> [[TsConfig]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [[TsConfig]]
phraseTss (([TsConfig] -> [[TsConfig]] -> [[TsConfig]]
forall a. a -> [a] -> [a]
:[[TsConfig]]
phraseTss)([TsConfig] -> [[TsConfig]])
-> (TsConfig -> [TsConfig]) -> TsConfig -> [[TsConfig]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.TsConfig -> [TsConfig]
forall (m :: * -> *) a. Monad m => a -> m a
return) (Maybe TsConfig -> [[TsConfig]]) -> Maybe TsConfig -> [[TsConfig]]
forall a b. (a -> b) -> a -> b
$ Rational -> Rational -> Maybe TsConfig
tsConfigFromDur Rational
100 Rational
a
                      [Rational]
_ -> [[TsConfig]]
phraseTss

-- | main heuristic is finding the common divisible duration,
-- with requirement that it must be greater than 1/4 the difference between the durations.
-- Hopefully avoids crappy tiny TSs like 2/8.
commonDivHeur :: Rational -> Rational -> Rational
commonDivHeur :: Rational -> Rational -> Rational
commonDivHeur Rational
d1 Rational
d2 | Rational
d1 Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
d2 = Rational
d1
                | Rational
c Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ (Rational -> Rational
forall a. Num a => a -> a
abs (Rational
d1 Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- Rational
d2)) Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
> (Integer
1Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
4) = Rational -> Rational -> Rational
forall a. Ord a => a -> a -> a
min Rational
d1 Rational
d2
                | Bool
otherwise = Rational
c
                where c :: Rational
c = Rational
d1 Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/ Integer -> Rational
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Rational -> Integer
forall a. Ratio a -> a
numerator (Rational
d1Rational -> Rational -> Rational
forall a. Fractional a => a -> a -> a
/Rational
d2))


tsConfigToDur :: TsConfig -> Rational
tsConfigToDur :: TsConfig -> Rational
tsConfigToDur = TimeSignature -> Rational
tsToRatio (TimeSignature -> Rational)
-> (TsConfig -> TimeSignature) -> TsConfig -> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TsConfig -> TimeSignature
_tSig



-- | Attempt to construct a TS config from duration
tsConfigFromDur :: Rational -> Rational -> Maybe TsConfig
tsConfigFromDur :: Rational -> Rational -> Maybe TsConfig
tsConfigFromDur Rational
weight = (TimeSignature -> TsConfig)
-> Maybe TimeSignature -> Maybe TsConfig
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\TimeSignature
t -> TimeSignature -> Rational -> Rational -> TsConfig
TsConfig TimeSignature
t Rational
weight (Quanta -> Rational
minMedianDur (TimeSignature -> Quanta
_tsUnit TimeSignature
t))) (Maybe TimeSignature -> Maybe TsConfig)
-> (Rational -> Maybe TimeSignature) -> Rational -> Maybe TsConfig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Maybe TimeSignature
tsFromRatio

-- | Pre-configured timesigs.
tsConfigs :: [TsConfig]
tsConfigs :: [TsConfig]
tsConfigs = [TimeSignature -> Rational -> Rational -> TsConfig
TsConfig (Int
4Int -> Quanta -> TimeSignature
/:Quanta
Q4) Rational
9 (Integer
1Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
4)
            ,TimeSignature -> Rational -> Rational -> TsConfig
TsConfig (Int
3Int -> Quanta -> TimeSignature
/:Quanta
Q4) Rational
8 (Integer
1Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
4)
            ,TimeSignature -> Rational -> Rational -> TsConfig
TsConfig (Int
6Int -> Quanta -> TimeSignature
/:Quanta
Q8) Rational
8 (Integer
3Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
8)
            ,TimeSignature -> Rational -> Rational -> TsConfig
TsConfig (Int
12Int -> Quanta -> TimeSignature
/:Quanta
Q8) Rational
7 (Integer
3Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
8)
            ,TimeSignature -> Rational -> Rational -> TsConfig
TsConfig (Int
2Int -> Quanta -> TimeSignature
/:Quanta
Q4) Rational
6 (Integer
1Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
4)
             ,TimeSignature -> Rational -> Rational -> TsConfig
TsConfig (Int
5Int -> Quanta -> TimeSignature
/:Quanta
Q4) Rational
5 (Integer
5Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
4)
             ,TimeSignature -> Rational -> Rational -> TsConfig
TsConfig (Int
5Int -> Quanta -> TimeSignature
/:Quanta
Q8) Rational
5 (Integer
5Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
8)
             ,TimeSignature -> Rational -> Rational -> TsConfig
TsConfig (Int
7Int -> Quanta -> TimeSignature
/:Quanta
Q4) Rational
5 (Integer
7Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
4)
            ,TimeSignature -> Rational -> Rational -> TsConfig
TsConfig (Int
7Int -> Quanta -> TimeSignature
/:Quanta
Q8) Rational
5 (Integer
7Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
8)
             ,TimeSignature -> Rational -> Rational -> TsConfig
TsConfig (Int
9Int -> Quanta -> TimeSignature
/:Quanta
Q8) Rational
5 (Integer
3Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
8)
            ]


-- | Given a median note duration, minima for acceptable quanta.
minMedianDur :: Quanta -> Rational
minMedianDur :: Quanta -> Rational
minMedianDur Quanta
q = Rational -> Maybe Rational -> Rational
forall a. a -> Maybe a -> a
fromMaybe (Integer
1Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
32) (Maybe Rational -> Rational)
-> ([(Quanta, Rational)] -> Maybe Rational)
-> [(Quanta, Rational)]
-> Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Quanta -> [(Quanta, Rational)] -> Maybe Rational
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Quanta
q ([(Quanta, Rational)] -> Rational)
-> [(Quanta, Rational)] -> Rational
forall a b. (a -> b) -> a -> b
$
                                   [(Quanta
Q8,Integer
1Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
32),(Quanta
Q4,Integer
1Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
16),(Quanta
Q2,Integer
1Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
4)]

-- | Given a phrase, select configs
selectTsConfigs :: HasRatioNotes t n p => t n -> [TsConfig]
selectTsConfigs :: t n -> [TsConfig]
selectTsConfigs t n
phrase | t n -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t n
phrase = []
                       | Bool
otherwise = (TsConfig -> TsConfig -> Ordering) -> [TsConfig] -> [TsConfig]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy ((Rational -> Rational -> Ordering)
-> Rational -> Rational -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip Rational -> Rational -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Rational -> Rational -> Ordering)
-> (TsConfig -> Rational) -> TsConfig -> TsConfig -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` TsConfig -> Rational
_tWeight) ([TsConfig] -> [TsConfig]) -> [TsConfig] -> [TsConfig]
forall a b. (a -> b) -> a -> b
$
                                     (TsConfig -> Maybe TsConfig) -> [TsConfig] -> [TsConfig]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (t n -> TsConfig -> Maybe TsConfig
forall (t :: * -> *) n p.
HasRatioNotes t n p =>
t n -> TsConfig -> Maybe TsConfig
evalTsConfig t n
phrase)
                                     -- append custom-length TS as lowest-weight choice
                                     ([TsConfig]
-> (TsConfig -> [TsConfig]) -> Maybe TsConfig -> [TsConfig]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [TsConfig]
tsConfigs (TsConfig -> [TsConfig] -> [TsConfig]
forall a. a -> [a] -> [a]
:[TsConfig]
tsConfigs) (Rational -> Rational -> Maybe TsConfig
tsConfigFromDur Rational
4 (t n -> Rational
forall d a p (t :: * -> *).
(Num d, HasNote a p d, Traversable t) =>
t a -> d
sumDurs t n
phrase)))

-- | Filter and score time signatures per heuristics.
evalTsConfig :: HasRatioNotes t n p => t n -> TsConfig -> Maybe TsConfig
evalTsConfig :: t n -> TsConfig -> Maybe TsConfig
evalTsConfig t n
phrase c :: TsConfig
c@(TsConfig ts :: TimeSignature
ts@(TimeSignature Int
_n Quanta
q) Rational
_ Rational
pulse)
    | Rational
medianDur Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Quanta -> Rational
minMedianDur Quanta
q = Maybe TsConfig
forall a. Maybe a
Nothing -- density filter
    | Rational
phraseDur Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
tsDur = Maybe TsConfig
forall a. Maybe a
Nothing -- min duration filter
    | Rational
tsDur Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
2 = Maybe TsConfig
forall a. Maybe a
Nothing -- too long TS
    | Rational
phraseDur Rational -> Rational -> Bool
forall a. Eq a => a -> a -> Bool
== Rational
tsDur = TsConfig -> Maybe TsConfig
forall a. a -> Maybe a
Just (TsConfig -> Maybe TsConfig) -> TsConfig -> Maybe TsConfig
forall a b. (a -> b) -> a -> b
$ ASetter TsConfig TsConfig Rational Rational
-> (Rational -> Rational) -> TsConfig -> TsConfig
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter TsConfig TsConfig Rational Rational
Lens' TsConfig Rational
tWeight (Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* (Integer
9Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
%Integer
4)) TsConfig
c -- exact length match bonus,
    | Bool
otherwise = TsConfig -> Maybe TsConfig
forall a. a -> Maybe a
Just (TsConfig -> Maybe TsConfig) -> TsConfig -> Maybe TsConfig
forall a b. (a -> b) -> a -> b
$ ASetter TsConfig TsConfig Rational Rational
-> (Rational -> Rational) -> TsConfig -> TsConfig
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter TsConfig TsConfig Rational Rational
Lens' TsConfig Rational
tWeight Rational -> Rational
computeWeight TsConfig
c
        where medianDur :: Rational
medianDur = [Rational] -> [Rational]
forall a. Ord a => [a] -> [a]
sort (Getting (Endo [Rational]) (t n) Rational -> t n -> [Rational]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf ((n -> Const (Endo [Rational]) n)
-> t n -> Const (Endo [Rational]) (t n)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse((n -> Const (Endo [Rational]) n)
 -> t n -> Const (Endo [Rational]) (t n))
-> ((Rational -> Const (Endo [Rational]) Rational)
    -> n -> Const (Endo [Rational]) n)
-> Getting (Endo [Rational]) (t n) Rational
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Rational -> Const (Endo [Rational]) Rational)
-> n -> Const (Endo [Rational]) n
forall s p d. HasNote s p d => Lens' s d
noteDur) t n
phrase) [Rational] -> Int -> Rational
forall a. [a] -> Int -> a
!! (Int
phraseLength Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
              phraseLength :: Int
phraseLength = t n -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t n
phrase
              phraseDur :: Rational
phraseDur = t n -> Rational
forall d a p (t :: * -> *).
(Num d, HasNote a p d, Traversable t) =>
t a -> d
sumDurs t n
phrase
              tsDur :: Rational
tsDur = TimeSignature -> Rational
tsToRatio TimeSignature
ts
              -- scale by pulse coverage, subtract by divisibility by ts duration
              computeWeight :: Rational -> Rational
computeWeight Rational
w = (Rational
w Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
* Rational -> t n -> Rational
forall (t :: * -> *) n p.
HasRatioNotes t n p =>
Rational -> t n -> Rational
pulseCoverage Rational
pulse t n
phrase) Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
- (Rational
phraseDur Rational -> Rational -> Rational
forall a. RealFrac a => a -> a -> a
`frem` Rational
tsDur)

-- | 'rem' for 'RealFrac'
frem :: RealFrac a => a -> a -> a
frem :: a -> a -> a
frem a
a a
b = let (Int
_ :: Int,a
f) = a -> (Int, a)
forall a b. (RealFrac a, Integral b) => a -> (b, a)
properFraction (a
aa -> a -> a
forall a. Fractional a => a -> a -> a
/a
b) in a
f

isDivBy :: RealFrac a => a -> a -> Bool
isDivBy :: a -> a -> Bool
isDivBy a
a a
b = a
0 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a -> a -> a
forall a. RealFrac a => a -> a -> a
frem a
a a
b

-- | Compute percentage of notes falling on pulse values.
pulseCoverage :: HasRatioNotes t n p => Rational -> t n -> Rational
pulseCoverage :: Rational -> t n -> Rational
pulseCoverage Rational
pulse t n
phrase = Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
pulseNoteCount Integer -> Integer -> Rational
forall a. Integral a => a -> a -> Ratio a
% Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (t n -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t n
phrase)
    where
      pulseNoteCount :: Int
pulseNoteCount = [(Rational, n)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([(Rational, n)] -> Int) -> (t n -> [(Rational, n)]) -> t n -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Rational, n) -> Bool) -> [(Rational, n)] -> [(Rational, n)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Rational -> Rational -> Bool
forall a. RealFrac a => a -> a -> Bool
`isDivBy` Rational
pulse) (Rational -> Bool)
-> ((Rational, n) -> Rational) -> (Rational, n) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Rational, n) -> Rational
forall a b. (a, b) -> a
fst) ([(Rational, n)] -> [(Rational, n)])
-> (t n -> [(Rational, n)]) -> t n -> [(Rational, n)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t n -> [(Rational, n)]
forall d a p (t :: * -> *).
(Num d, Ord d, HasNote a p d, Traversable t) =>
t a -> [(d, a)]
mapTime (t n -> Int) -> t n -> Int
forall a b. (a -> b) -> a -> b
$ t n
phrase