module Music.Score.Score (
Score,
notes,
events,
mapScore,
reifyScore,
mapWithSpan,
filterWithSpan,
mapFilterWithSpan,
mapEvents,
filterEvents,
mapFilterEvents,
) where
import Control.Applicative
import Control.Arrow
import Control.Comonad
import Control.Lens
import Control.Monad
import Control.Monad.Compose
import Control.Monad.Plus
import Data.Dynamic
import Data.Foldable (foldMap)
import Data.Maybe
import Data.Ord
import Data.Semigroup
import Data.AffineSpace
import Data.AffineSpace.Point
import Data.VectorSpace
import Test.QuickCheck (Arbitrary (..), Gen (..))
import Data.Default
import Data.Foldable (Foldable)
import qualified Data.Foldable as F
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Traversable (Traversable)
import qualified Data.Traversable as T
import Data.Typeable
import Music.Dynamics.Literal
import Music.Pitch.Literal
import Music.Score.Meta
import Music.Score.Note
import Music.Score.Part
import Music.Score.Pitch
import Music.Score.Util
import Music.Time
import Music.Time.Reactive
newtype Score a = Score { getScore' :: (Meta, NScore a) }
deriving (Functor, Semigroup, Monoid, Foldable, Traversable, Typeable)
notes :: Iso (Score a) (Score b) [Note a] [Note b]
notes = iso (getNScore . snd . getScore') (Score . return . NScore)
events :: Iso (Score a) (Score b) [(Time, Duration, a)] [(Time, Duration, b)]
events = iso getScore mkScore
inScore f = Score . f . getScore'
mkScore :: [(Time, Duration, a)] -> Score a
mkScore = mconcat . fmap (uncurry3 event)
where
event t d x = (delay (t .-. origin) . stretch d) (return x)
getScore :: Score a -> [(Time, Duration, a)]
getScore =
fmap (\(view delta -> (t,d),x) -> (t,d,x)) .
List.sortBy (comparing fst) .
F.toList .
fmap getNote .
reifyScore
mapScore :: (Note a -> b) -> Score a -> Score b
mapScore f = over _Wrapped (second $ mapNScore f)
reifyScore :: Score a -> Score (Note a)
reifyScore = over _Wrapped (second reifyNScore)
mapWithSpan :: (Span -> a -> b) -> Score a -> Score b
mapWithSpan f = mapScore (uncurry f . getNote)
filterWithSpan :: (Span -> a -> Bool) -> Score a -> Score a
filterWithSpan f = mapFilterWithSpan (partial2 f)
mapFilterWithSpan :: (Span -> a -> Maybe b) -> Score a -> Score b
mapFilterWithSpan f = mcatMaybes . mapWithSpan f
mapEvents :: (Time -> Duration -> a -> b) -> Score a -> Score b
mapEvents f = mapWithSpan (uncurry f . view delta)
filterEvents :: (Time -> Duration -> a -> Bool) -> Score a -> Score a
filterEvents f = mapFilterEvents (partial3 f)
mapFilterEvents :: (Time -> Duration -> a -> Maybe b) -> Score a -> Score b
mapFilterEvents f = mcatMaybes . mapEvents f
instance Wrapped (Score a) where
type Unwrapped (Score a) = (Meta, NScore a)
_Wrapped' = iso getScore' Score
instance Rewrapped (Score a) (Score b) where
instance Applicative Score where
pure = return
(<*>) = ap
instance Monad Score where
return = (^. _Unwrapped') . return . return
xs >>= f = (^. _Unwrapped') $ mbind ((^. _Wrapped') . f) ((^. _Wrapped') xs)
instance Alternative Score where
empty = mempty
(<|>) = mappend
instance MonadPlus Score where
mzero = mempty
mplus = mappend
instance HasOnset (Score a) where
onset (Score (m,x)) = onset x
instance HasOffset (Score a) where
offset (Score (m,x)) = offset x
instance Delayable (Score a) where
delay n (Score (m,x)) = Score (delay n m, delay n x)
instance Stretchable (Score a) where
stretch n (Score (m,x)) = Score (stretch n m, stretch n x)
instance HasDuration (Score a) where
duration = durationDefault
instance Reversible a => Reversible (Score a) where
rev = fmap rev . withSameOnset (stretch (1))
instance HasMeta (Score a) where
meta = _Wrapped' . _1
newtype NScore a = NScore { getNScore :: [Note a] }
deriving (Functor, Foldable, Semigroup, Monoid, Traversable, Delayable, Stretchable, HasOnset, HasOffset)
inNScore f = NScore . f . getNScore
mapNScore :: (Note a -> b) -> NScore a -> NScore b
mapNScore f = inNScore (fmap $ extend f)
reifyNScore :: NScore a -> NScore (Note a)
reifyNScore = inNScore $ fmap duplicate
instance Wrapped (NScore a) where
type Unwrapped (NScore a) = [Note a]
_Wrapped' = iso getNScore NScore
instance Applicative NScore where
pure = return
(<*>) = ap
instance Monad NScore where
return = (^. _Unwrapped') . return . return
xs >>= f = (^. _Unwrapped') $ mbind ((^. _Wrapped') . f) ((^. _Wrapped') xs)
instance MonadPlus NScore where
mzero = mempty
mplus = mappend
instance HasDuration (Note a) where
duration = durationDefault
instance IsPitch a => IsPitch (Score a) where
fromPitch = pure . fromPitch
instance IsDynamics a => IsDynamics (Score a) where
fromDynamics = pure . fromDynamics
instance IsInterval a => IsInterval (Score a) where
fromInterval = pure . fromInterval
instance Enum a => Enum (Score a) where
toEnum = return . toEnum
fromEnum = list 0 (fromEnum . head) . F.toList
instance Num a => Num (Score a) where
fromInteger = return . fromInteger
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) = Duration
d *^ s = d `stretch` s
type instance Pitch (Score a) = Pitch a
instance (HasSetPitch a b,
Transformable (Pitch a),
Transformable (Pitch b)) =>
HasSetPitch (Score a) (Score b) where
type SetPitch g (Score a) = Score (SetPitch g a)
__mapPitch f = mapWithSpan (__mapPitch . (`sunder` f))
type instance Part (Score a) = Part a
instance HasPart a => HasPart (Score a) where
getPart = error "No Score.getPart"
modifyPart f = fmap (modifyPart f)
partial2 :: (a -> b -> Bool) -> a -> b -> Maybe b
partial3 :: (a -> b -> c -> Bool) -> a -> b -> c -> Maybe c
partial2 f = curry (fmap snd . partial (uncurry f))
partial3 f = curry3 (fmap (view _3) . partial (uncurry3 f))