module Music.Score.Score (
Score,
) where
import Prelude hiding (null, length, repeat, foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)
import Data.Semigroup
import Control.Applicative
import Control.Monad (ap, join, MonadPlus(..))
import Data.Foldable
import Data.Traversable
import Data.Typeable
import Data.Maybe
import Data.Either
import Data.Pointed
import Data.Function (on)
import Data.Ord (comparing)
import Data.Ratio
import Data.VectorSpace
import Data.AffineSpace
import Test.QuickCheck (Arbitrary(..),Gen(..))
import qualified Data.Map as Map
import qualified Data.List as List
import Music.Pitch.Literal
import Music.Dynamics.Literal
import Music.Time
import Music.Score.Voice
import Music.Score.Track
newtype Score a = Score { getScore :: [(TimeT, DurationT, a)] }
deriving (Eq, Ord, Show, Functor, Foldable, Typeable, Traversable)
type instance Time Score = TimeT
instance Semigroup (Score a) where
(<>) = mappend
instance Monoid (Score a) where
mempty = Score []
Score as `mappend` Score bs = Score (as `m` bs)
where
m = mergeBy (comparing fst3)
instance Monad Score where
return x = Score [(0, 1, x)]
a >>= k = join' $ fmap k a
where
join' sc = fold $ mapTime (\t d -> delay' t . stretch d) sc
instance Pointed Score where
point = return
instance Applicative Score where
pure = return
(<*>) = ap
instance Alternative Score where
empty = mempty
(<|>) = mappend
instance MonadPlus Score where
mzero = mempty
mplus = mappend
instance Performable Score where
perform = getScore
instance Stretchable (Score) where
d `stretch` Score sc = Score $ fmap (first3 (^* fromDurationT d) . second3 (^* d)) $ sc
instance Delayable (Score) where
d `delay` Score sc = Score . fmap (first3 (.+^ d)) $ sc
instance HasOnset (Score) where
onset (Score []) = 0
onset (Score xs) = on (head xs) where on (t,d,x) = t
instance HasOffset (Score) where
offset (Score []) = 0
offset (Score xs) = maximum (fmap off xs) where off (t,d,x) = t + (fromDurationT $ d)
instance HasDuration (Score) where
duration x = offset x .-. onset x
instance IsPitch a => IsPitch (Score a) where
fromPitch = pure . fromPitch
instance IsDynamics a => IsDynamics (Score a) where
fromDynamics = pure . fromDynamics
instance AdditiveGroup (Score a) where
zeroV = error "Not impl"
(^+^) = error "Not impl"
negateV = error "Not impl"
instance VectorSpace (Score a) where
type Scalar (Score a) = DurationT
d *^ s = d `stretch` s
instance Arbitrary a => Arbitrary (Score a) where
arbitrary = do
x <- arbitrary
t <- fmap toDurationT $ (arbitrary::Gen Double)
d <- fmap toDurationT $ (arbitrary::Gen Double)
return $ delay t $ stretch d $ (note x)
note :: a -> Score a
note = return
rest :: Score (Maybe a)
rest = return Nothing
repeat :: Score a -> Score a
repeat a = a `plus` delay (duration a) (repeat a)
where
Score as `plus` Score bs = Score (as <> bs)
mapTime :: (TimeT -> DurationT -> a -> b) -> Score a -> Score b
mapTime f = Score . fmap (mapEvent f) . getScore
mapEvent :: (TimeT -> DurationT -> a -> b) -> (TimeT, DurationT, a) -> (TimeT, DurationT, b)
mapEvent f (t, d, x) = (t, d, f t d x)
delay' t = delay (fromTimeT t)
fst3 (a,b,c) = a
list z f [] = z
list z f xs = f xs
first f (x,y) = (f x, y)
second f (x,y) = (x, f y)
first3 f (a,b,c) = (f a,b,c)
second3 f (a,b,c) = (a,f b,c)
mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeBy f [] ys = ys
mergeBy f xs [] = xs
mergeBy f xs'@(x:xs) ys'@(y:ys)
| x `f` y == LT = x : mergeBy f xs ys'
| x `f` y /= LT = y : mergeBy f xs' ys