module Music.Score.Track (
Track,
track',
track,
) where
import Control.Applicative
import Control.Arrow
import Control.Lens
import Control.Monad
import Control.Monad.Compose
import Data.AffineSpace.Point
import Data.Foldable (Foldable (..), foldMap)
import qualified Data.Foldable as F
import qualified Data.List as List
import Data.PairMonad ()
import Data.Semigroup
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 Track a = Track { getTrack' :: [Occ a] }
deriving (Eq, Ord, Show, Functor, Foldable, Typeable, Traversable, Monoid, Semigroup, Delayable, Stretchable)
instance Wrapped (Track a) where
type Unwrapped (Track a) = [Occ a]
_Wrapped' = iso getTrack' Track
instance Applicative Track where
pure = return
(<*>) = ap
instance Monad Track where
return = (^. _Unwrapped') . return . return
xs >>= f = (^. _Unwrapped') $ mbind ((^. _Wrapped') . f) ((^. _Wrapped') xs)
instance Alternative Track where
empty = mempty
(<|>) = mappend
instance MonadPlus Track where
mzero = mempty
mplus = mappend
instance HasOnset (Track a) where
onset (Track a) = list origin (onset . head) a
instance IsPitch a => IsPitch (Track a) where
fromPitch = pure . fromPitch
instance IsDynamics a => IsDynamics (Track a) where
fromDynamics = pure . fromDynamics
instance IsInterval a => IsInterval (Track a) where
fromInterval = pure . fromInterval
type instance Pitch (Track a) = Pitch a
instance (HasSetPitch a b, Transformable (Pitch (Track a)), Transformable (Pitch (Track b))) => HasSetPitch (Track a) (Track b) where
type SetPitch g (Track a) = Track (SetPitch g a)
__mapPitch f = fmap (__mapPitch f)
track' :: Iso' [(Time, a)] (Track a)
track' = track
track :: Iso [(Time, a)] [(Time, b)] (Track a) (Track b)
track = iso mkTrack getTrack
where
mkTrack = Track . fmap (uncurry occ . first (fmap realToFrac))
getTrack = fmap (first (fmap realToFrac) . getOcc) . getTrack'
newtype Occ a = Occ (Sum Time, a)
deriving (Eq, Ord, Show, Functor, Applicative, Monad, Foldable, Traversable)
occ t x = Occ (Sum t, x)
getOcc (Occ (Sum t, x)) = (t, x)
instance Delayable (Occ a) where
delay n (Occ (s,x)) = Occ (delay n s, x)
instance Stretchable (Occ a) where
stretch n (Occ (s,x)) = Occ (stretch n s, x)
instance HasOnset (Occ a) where
onset (Occ (s,x)) = onset s