{-# 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 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

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 :: 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 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 :: 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 = [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), HasNote a p Rational, HasTimeSignature (t a),
 Traversable t) =>
[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 b a. (b -> a -> b) -> b -> b a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [c m] -> m -> [c m]
forall {s} {t :: * -> *} {a} {p} {p}.
(HasTie s, Snoc (t a) (t a) s s, Traversable t, Eq p, Monoid p,
 Monoid (t a), HasNote a p Rational, HasNote s p Rational) =>
[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 a b. (a -> b) -> b a -> b b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap n -> m
forall n. HasNote n p Rational => 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
Lens' s Rational
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
Lens' s Rational
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
Lens' s Rational
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
Traversal' [t a] (t 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 {t :: * -> *} {a} {p}.
(Traversable t, HasNote a p Rational, 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
Traversal' [t a] (t a)
_last ((Maybe TimeSignature -> Identity (Maybe TimeSignature))
-> t a -> Identity (t a)
forall a. HasTimeSignature a => Lens' a (Maybe TimeSignature)
Lens' (t 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)
Lens' (t 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' :: forall (b :: * -> *) n p.
(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)]
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' :: forall (b :: * -> *) n p.
(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)]
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 :: forall a s d.
(Eq a, Monoid a, HasNote s a d, HasTie s) =>
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)
Lens' s (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 a. Eq a => a -> [a] -> 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 :: 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 = (c m -> n -> c m) -> c m -> b n -> c m
forall b a. (b -> a -> b) -> b -> b a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' c m -> n -> c m
forall {a} {a} {s} {p}.
(Snoc a a a a, Show s, HasTie s, HasTie a, Eq p, Monoid p,
 HasNote a p Rational, HasNote s p Rational) =>
a -> s -> a
apply c m
forall a. Monoid a => a
mempty where
    apply :: a -> s -> a
apply a
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
Lens' s Rational
noteDur s
n) of
                       [] -> [Char] -> a
forall a. HasCallStack => [Char] -> a
error ([Char] -> a) -> [Char] -> a
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
_] -> a
r a -> a -> a
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)
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)
Lens' s (Maybe Tie)
tie s
n) (s -> a
forall n. HasNote n p Rational => n -> a
forall s p d n. (HasNote s p d, HasNote n p d) => n -> s
fromNote s
n)
                       [Rational]
ds -> (a -> a -> a) -> a -> [a] -> a
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl a -> a -> a
forall s a. Snoc s s a a => s -> a -> s
(|>) a
r ([a] -> a) -> ([Rational] -> [a]) -> [Rational] -> a
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}. (HasTie s, HasNote s p Rational) => Rational -> s
mkTied ([Rational] -> a) -> [Rational] -> a
forall a b. (a -> b) -> a -> b
$ [Rational]
ds
                           where mkTied :: Rational -> s
mkTied Rational
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 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
Lens' s Rational
noteDur Rational
d (s -> s
forall n. HasNote n p Rational => n -> 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)
Lens' s (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
Traversal' [a] 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)
Lens' a (Maybe Tie)
tie) ((Tie -> Tie) -> Maybe Tie -> Maybe Tie
forall a b. (a -> b) -> Maybe a -> Maybe b
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
Traversal' [a] 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)
Lens' a (Maybe Tie)
tie) ((Tie -> Tie) -> Maybe Tie -> Maybe Tie
forall a b. (a -> b) -> Maybe a -> Maybe b
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' :: forall (b :: * -> *) n p.
(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)
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
$c== :: TsConfig -> TsConfig -> Bool
== :: TsConfig -> TsConfig -> Bool
$c/= :: TsConfig -> TsConfig -> Bool
/= :: 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
$cshowsPrec :: Int -> TsConfig -> [Char] -> [Char]
showsPrec :: Int -> TsConfig -> [Char] -> [Char]
$cshow :: TsConfig -> [Char]
show :: TsConfig -> [Char]
$cshowList :: [TsConfig] -> [Char] -> [Char]
showList :: [TsConfig] -> [Char] -> [Char]
Show)
makeLenses ''TsConfig

selectTimeSig :: HasRatioNotes t n p => [t n] -> Maybe TimeSignature
selectTimeSig :: forall (t :: * -> *) n p.
HasRatioNotes t n p =>
[t n] -> Maybe TimeSignature
selectTimeSig [t n]
phrases = ((TimeSignature, Rational) -> TimeSignature)
-> Maybe (TimeSignature, Rational) -> Maybe TimeSignature
forall a b. (a -> b) -> Maybe a -> Maybe b
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 :: forall (t :: * -> *) n p.
HasRatioNotes t n p =>
[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 a. (a -> a -> a) -> [a] -> a
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 b c c'. (b -> c) -> (b -> c') -> b -> (c, c')
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)
forall (m :: * -> *) a. Monad m => [m a] -> m [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 a. [a] -> 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 a b.
([Rational] -> a -> b) -> ([Rational] -> a) -> [Rational] -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Rational] -> [Rational]
forall a. HasCallStack => [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 a. a -> [a]
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 a b. (a -> b) -> Maybe a -> Maybe b
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 :: forall (t :: * -> *) n p. HasRatioNotes t n p => t n -> [TsConfig]
selectTsConfigs t n
phrase | t n -> Bool
forall a. t a -> 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 :: forall (t :: * -> *) n p.
HasRatioNotes t n p =>
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)
forall (f :: * -> *) a b.
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
Lens' n Rational
noteDur) t n
phrase) [Rational] -> Int -> Rational
forall a. HasCallStack => [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 a. t a -> 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 :: forall a. RealFrac a => a -> a -> a
frem a
a a
b = let (Int
_ :: Int,a
f) = a -> (Int, a)
forall b. Integral b => a -> (b, 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 :: forall a. RealFrac a => 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 :: forall (t :: * -> *) n p.
HasRatioNotes t n p =>
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 a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t n
phrase)
    where
      pulseNoteCount :: Int
pulseNoteCount = [(Rational, n)] -> Int
forall a. [a] -> 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