{-# 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)
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
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
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 = [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 :: [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 :: [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
| Bool
otherwise = [t a]
aas
joinLast [t a]
a = [t a]
a
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' :: (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
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
validDenoms :: [Integer]
validDenoms :: [Integer]
validDenoms = [Integer
1,Integer
2,Integer
3,Integer
4,Integer
7]
maxDur :: Rational
maxDur :: Rational
maxDur = Rational
2
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)
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]
| 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
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
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)))
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
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
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))
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
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
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
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)
]
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)]
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)
([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)))
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
| Rational
phraseDur Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
< Rational
tsDur = Maybe TsConfig
forall a. Maybe a
Nothing
| Rational
tsDur Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
2 = Maybe TsConfig
forall a. Maybe a
Nothing
| 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
| 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
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)
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
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