module Music.Score.Phrases (
HasPhrases(..),
HasPhrases',
phrases,
phrases',
Phrase,
MVoice,
PVoice,
mvoicePVoice,
unsafeMvoicePVoice,
singleMVoice,
) where
import Control.Applicative
import Control.Exception (assert)
import Control.Lens
import Control.Monad.Plus
import Data.AffineSpace
import qualified Data.List as List
import Data.Maybe
import Data.Ord
import Data.Semigroup
import Music.Score.Part
import Music.Score.Convert
import Music.Time
type Phrase a = Voice a
type MVoice a = Voice (Maybe a)
type PVoice a = [Either Duration (Phrase a)]
type TVoice a = Track (Phrase a)
class HasPhrases s t a b | s -> a, t -> b, s b -> t, t a -> s where
mvoices :: Traversal s t (MVoice a) (MVoice b)
instance HasPhrases (MVoice a) (MVoice b) a b where
mvoices = id
instance HasPhrases (PVoice a) (PVoice b) a b where
mvoices = from unsafeMvoicePVoice
instance (HasPart' a, Ord (Part a)) =>
HasPhrases (Score a) (Score b) a b where
mvoices = extracted . each . singleMVoice
type HasPhrases' s a = HasPhrases s s a a
phrases' :: HasPhrases' s a => Traversal' s (Phrase a)
phrases' = phrases
phrases :: HasPhrases s t a b => Traversal s t (Phrase a) (Phrase b)
phrases = mvoices . mvoicePVoice . each . _Right
mvoicePVoice :: Lens (MVoice a) (MVoice b) (PVoice a) (PVoice b)
mvoicePVoice = unsafeMvoicePVoice
unsafeMvoicePVoice :: Iso (MVoice a) (MVoice b) (PVoice a) (PVoice b)
unsafeMvoicePVoice = iso mvoiceToPVoice pVoiceToMVoice
where
mvoiceToPVoice :: MVoice a -> PVoice a
mvoiceToPVoice =
map ( bimap voiceToRest voiceToPhrase
. bimap (^.from unsafeEventsV) (^.from unsafeEventsV) )
. groupDiff' (isJust . snd)
. view eventsV
voiceToRest :: MVoice a -> Duration
voiceToRest = sumOf (eventsV.each._1) . fmap (\x -> assert (isNothing x) x)
voiceToPhrase :: MVoice a -> Phrase a
voiceToPhrase = fmap fromJust
pVoiceToMVoice :: (PVoice a) -> MVoice a
pVoiceToMVoice = mconcat . fmap (either restToVoice phraseToVoice)
restToVoice :: Duration -> MVoice a
restToVoice d = stretch d $ pure Nothing
phraseToVoice :: Phrase a -> MVoice a
phraseToVoice = fmap Just
singleMVoice :: Prism (Score a) (Score b) (MVoice a) (MVoice b)
singleMVoice = iso scoreToVoice voiceToScore'
where
scoreToVoice :: Score a -> MVoice a
scoreToVoice = (^. voice) . fmap (^. stretched) . fmap throwTime . addRests .
List.sortBy (comparing (^._1))
. (^. events)
where
throwTime (t,d,x) = (d,x)
addRests = concat . snd . List.mapAccumL g 0
where
g u (t, d, x)
| u == t = (t .+^ d, [(t, d, Just x)])
| u < t = (t .+^ d, [(u, t .-. u, Nothing), (t, d, Just x)])
| otherwise = error "singleMVoice: Strange prevTime"
voiceToScore :: Voice a -> Score a
voiceToScore = scat . fmap g . (^. stretcheds) where g = (^. stretchedValue) . fmap return
voiceToScore' :: MVoice a -> Score a
voiceToScore' = mcatMaybes . voiceToScore
groupDiff :: (a -> Bool) -> [a] -> [[a]]
groupDiff p [] = []
groupDiff p (x:xs)
| p x = (x : List.takeWhile p xs) : groupDiff p (List.dropWhile p xs)
| not (p x) = (x : List.takeWhile (not . p) xs) : groupDiff p (List.dropWhile (not . p) xs)
groupDiff' :: (a -> Bool) -> [a] -> [Either [a] [a]]
groupDiff' p [] = []
groupDiff' p (x:xs)
| not (p x) = Left (x : List.takeWhile (not . p) xs) : groupDiff' p (List.dropWhile (not . p) xs)
| p x = Right (x : List.takeWhile p xs) : groupDiff' p (List.dropWhile p xs)