module Music.Score.Voice (
Voice,
voice',
voice,
zipVoice,
zipVoiceWith,
dzipVoiceWith,
mergeEqual,
) where
import Control.Applicative
import Control.Arrow
import Control.Lens
import Control.Monad
import Control.Monad.Compose
import Data.Semigroup
import Data.Foldable (Foldable (..), foldMap)
import qualified Data.Foldable as F
import qualified Data.List as List
import Data.PairMonad ()
import Data.Traversable (Traversable (..))
import qualified Data.Traversable as T
import Data.Typeable
import Data.VectorSpace hiding (Sum)
import Music.Dynamics.Literal
import Music.Pitch.Literal
import Music.Score.Pitch
import Music.Score.Util
import Music.Time
newtype Voice a = Voice { getVoice' :: [Ev a] }
deriving (Eq, Ord, Show, Functor, Foldable, Monoid, Semigroup, Typeable, Traversable, Stretchable)
instance Wrapped (Voice a) where
type Unwrapped (Voice a) = [Ev a]
_Wrapped' = iso getVoice' Voice
instance Applicative Voice where
pure = return
(<*>) = ap
instance Monad Voice where
return = (^. _Unwrapped') . return . return
xs >>= f = (^. _Unwrapped') $ ((^. _Wrapped') . f) `mbind` ((^. _Wrapped') xs)
instance HasDuration (Voice a) where
duration = sum . fmap duration . getVoice'
instance IsPitch a => IsPitch (Voice a) where
fromPitch = pure . fromPitch
instance IsDynamics a => IsDynamics (Voice a) where
fromDynamics = pure . fromDynamics
instance IsInterval a => IsInterval (Voice a) where
fromInterval = pure . fromInterval
instance Num a => Num (Voice a) where
fromInteger = pure . fromInteger
type instance Pitch (Voice a) = Pitch a
instance (HasSetPitch a b, Transformable (Pitch a), Transformable (Pitch b)) => HasSetPitch (Voice a) (Voice b) where
type SetPitch g (Voice a) = Voice (SetPitch g a)
__mapPitch f = fmap (__mapPitch f)
voice' :: Iso' [(Duration, a)] (Voice a)
voice' = voice
voice :: Iso [(Duration, a)] [(Duration, b)] (Voice a) (Voice b)
voice = iso mkVoice getVoice
where
mkVoice = Voice . fmap (uncurry ev . first realToFrac)
getVoice = fmap (first realToFrac . getEv) . getVoice'
zipVoice :: Voice a -> Voice b -> Voice (a, b)
zipVoice = zipVoiceWith (,)
zipVoiceWith :: (a -> b -> c) -> Voice a -> Voice b -> Voice c
zipVoiceWith f (Voice a) (Voice b) = Voice $ zipWith (\(Ev (dx,vx)) (Ev (dy,vy)) -> Ev (dx <> dy, f vx vy)) a b
dzipVoiceWith :: (Duration -> Duration -> a -> b -> (Duration, c)) -> Voice a -> Voice b -> Voice c
dzipVoiceWith f (Voice a) (Voice b) = Voice $ zipWith (\(Ev (Product dx,vx)) (Ev (Product dy,vy)) -> Ev (first Product $ f dx dy vx vy)) a b
mergeEqual :: Eq a => Voice a -> Voice a
mergeEqual = over (from voice) $ fmap f . List.groupBy (inspecting snd)
where
f dsAs = let (ds,as) = unzip dsAs in (sum ds, head as)
inspecting :: Eq a => (b -> a) -> b -> b -> Bool
inspecting p x y = p x == p y
newtype Ev a = Ev (Product Duration, a)
deriving (Eq, Ord, Show, Functor, Applicative, Monad, Foldable, Traversable)
ev t x = Ev (Product t, x)
getEv (Ev (Product t, x)) = (t, x)
instance Stretchable (Ev a) where
stretch n (Ev (s,x)) = Ev (stretch n s, x)
instance HasDuration (Ev a) where
duration (Ev (s,x)) = duration s