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 ts = rebar ts . 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 ts = reverse . fixup . foldl' go [mempty] . fmap fromNote where
tslen = tsToRatio ts
go [] _ = error "impossible"
go bss@(b:bs) n | barlen == tslen = go (mempty:bss) n
| newBarLen <= tslen = (b |> n):bs
| otherwise = go ((b |> pre):bs) post
where barlen = sumDurs b
ndur = view noteDur n
newBarLen = barlen + ndur
remaining = newBarLen tslen
post = tieMay TStop . set noteDur remaining $ n
pre = tieMay TStart . set noteDur (ndur remaining) $ n
fixup [] = []
fixup bs = over _head fixLast . joinLast . over _last (timeSignature ?~ ts) $ bs
fixLast b | barlen == tslen = b
| otherwise = case tsFromRatio' ts barlen of
Just t -> b & timeSignature ?~ t
Nothing -> b
where barlen = sumDurs b
joinLast aas@(a:b:as) | sumDurs a + sumDurs b < tslen * (3%2) =
(b `mappend` a):as
| otherwise = aas
joinLast a = a
rebar' :: (HasRatioNotes b n p,Monoid p,Eq p,Show p) =>
TimeSignature -> b n -> [Bar (Note' p Rational)]
rebar' = rebar
rebars' :: (HasRatioNotes b n p,Monoid (b n),Monoid p,Eq p,Show p) =>
TimeSignature -> [b n] -> [Bar (Note' p Rational)]
rebars' = rebars
tieMay :: (Eq a, Monoid a, HasNote s a d, HasTie s) => Tie -> s -> s
tieMay end v | isRest v = v
| otherwise = over tie setTie v
where setTie o@(Just old) | old == end = o
| otherwise = Just TBoth
setTie Nothing = Just end
validDenoms :: [Integer]
validDenoms = [1,2,3,4,7]
maxDur :: Rational
maxDur = 2
validDur :: Rational -> Bool
validDur r = r == maxDur ||
(r < maxDur && numerator r `elem` validDenoms)
splitDur :: Rational -> [Rational]
splitDur r | r < 0 = error "splitDur: negative duration"
| r == 0 = []
| validDur r = [r]
| otherwise = split:splitDur (r split)
where split = findSplit r
findSplit :: Rational -> Rational
findSplit r = case filter validDur candidates of
[] -> splitOnValid
(v:_) -> v
where
n = numerator r
d = denominator r
pow2s = [x | p <- [(1 :: Integer)..], x<-[2^p]]
denomPow2s = reverse $ takeWhile (\v -> v < d && d `rem` v == 0) pow2s
candidates = filter (<r) $ map (\cd -> (n * cd `div` d) :% (d `div` cd)) denomPow2s
splitOnValid = case filter (<= min r maxDur) $ map (:%d) $ reverse $
takeWhile (<min n 8) pow2s of
[] -> r
(v:_) -> 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 = foldl' apply mempty where
apply r n = case splitDur (view noteDur n) of
[] -> error $ "tieRules: empty result from splitDur for " ++ show n
[_] -> r |> set tie (view tie n) (fromNote n)
ds -> foldl (|>) r . fixLast . fixFirst . map mkTied $ ds
where mkTied d = tieMay TBoth (set noteDur d (fromNote n))
forOrgTie t = case view tie n of
Nothing -> t
(Just a) | a == t -> t
| otherwise -> TBoth
fixFirst = over (_head.tie) (fmap (const (forOrgTie TStart)))
fixLast = over (_last.tie) (fmap (const (forOrgTie TStop)))
tieRules' :: (HasRatioNotes b n p, HasTie n, Monoid p, Eq p, Show n) =>
b n -> Bar (Note' p Rational)
tieRules' = tieRules
data TsConfig = TsConfig {
_tSig :: TimeSignature
, _tWeight :: Rational
, _tPulse :: Rational
} deriving (Eq,Show)
makeLenses ''TsConfig
selectTimeSig :: HasRatioNotes t n p => [t n] -> Maybe TimeSignature
selectTimeSig phrases = fmap fst $ headMay $ selectTimeSigs phrases
selectTimeSigs :: HasRatioNotes t n p => [t n] -> [(TimeSignature,Rational)]
selectTimeSigs = mergeScores . preferDivisableHeads . map selectTsConfigs where
mergeScores = sortBy (flip compare `on` snd) .
M.toList . foldl1 (M.unionWith (+)) .
map (M.fromListWith max . map (_tSig &&& _tWeight))
preferDivisableHeads :: [[TsConfig]] -> [[TsConfig]]
preferDivisableHeads [] = []
preferDivisableHeads [a] = [a]
preferDivisableHeads phraseTss =
case sequence (map headMay phraseTss) of
Nothing -> phraseTss
Just heads | length (nub heads) == 1 -> phraseTss
| otherwise -> case nub $ (zipWith commonDivHeur <*> tail) (map tsConfigToDur heads) of
[] -> phraseTss
[a] -> maybe phraseTss ((:phraseTss).return) $ tsConfigFromDur 100 a
_ -> phraseTss
commonDivHeur :: Rational -> Rational -> Rational
commonDivHeur d1 d2 | d1 == d2 = d1
| c / (abs (d1 d2)) > (1%4) = min d1 d2
| otherwise = c
where c = d1 / fromIntegral (numerator (d1/d2))
tsConfigToDur :: TsConfig -> Rational
tsConfigToDur = tsToRatio . _tSig
tsConfigFromDur :: Rational -> Rational -> Maybe TsConfig
tsConfigFromDur weight = fmap (\t -> TsConfig t weight (minMedianDur (_tsUnit t))) . tsFromRatio
tsConfigs :: [TsConfig]
tsConfigs = [TsConfig (4/:Q4) 9 (1%4)
,TsConfig (3/:Q4) 8 (1%4)
,TsConfig (6/:Q8) 8 (3%8)
,TsConfig (12/:Q8) 7 (3%8)
,TsConfig (2/:Q4) 6 (1%4)
,TsConfig (5/:Q4) 5 (5%4)
,TsConfig (5/:Q8) 5 (5%8)
,TsConfig (7/:Q4) 5 (7%4)
,TsConfig (7/:Q8) 5 (7%8)
,TsConfig (9/:Q8) 5 (3%8)
]
minMedianDur :: Quanta -> Rational
minMedianDur q = fromMaybe (1%32) . lookup q $
[(Q8,1%32),(Q4,1%16),(Q2,1%4)]
selectTsConfigs :: HasRatioNotes t n p => t n -> [TsConfig]
selectTsConfigs phrase | null phrase = []
| otherwise = sortBy (flip compare `on` _tWeight) $
mapMaybe (evalTsConfig phrase)
(maybe tsConfigs (:tsConfigs) (tsConfigFromDur 4 (sumDurs phrase)))
evalTsConfig :: HasRatioNotes t n p => t n -> TsConfig -> Maybe TsConfig
evalTsConfig phrase c@(TsConfig ts@(TimeSignature _n q) _ pulse)
| medianDur < minMedianDur q = Nothing
| phraseDur < tsDur = Nothing
| tsDur >= 2 = Nothing
| phraseDur == tsDur = Just $ over tWeight (* (9%4)) c
| otherwise = Just $ over tWeight computeWeight c
where medianDur = sort (toListOf (traverse.noteDur) phrase) !! (phraseLength `div` 2)
phraseLength = length phrase
phraseDur = sumDurs phrase
tsDur = tsToRatio ts
computeWeight w = (w * pulseCoverage pulse phrase) (phraseDur `frem` tsDur)
frem :: RealFrac a => a -> a -> a
frem a b = let (_ :: Int,f) = properFraction (a/b) in f
isDivBy :: RealFrac a => a -> a -> Bool
isDivBy a b = 0 == frem a b
pulseCoverage :: HasRatioNotes t n p => Rational -> t n -> Rational
pulseCoverage pulse phrase = fromIntegral pulseNoteCount % fromIntegral (length phrase)
where
pulseNoteCount = length . filter ((`isDivBy` pulse) . fst) . mapTime $ phrase