{- |
MIDI-File Datatype

Taken from Haskore.
-}

module Sound.MIDI.File (
   T(..), Division(..), Track, Type(..),
   empty,
   ElapsedTime, fromElapsedTime, toElapsedTime,
   Tempo,       fromTempo,       toTempo,
   explicitNoteOff, implicitNoteOff,
   getTracks, mergeTracks, mapTrack,
   secondsFromTicks, ticksPerQuarterNote,

   showLines, changeVelocity, resampleTime,
   showEvent, showTime,
   sortEvents, progChangeBeforeSetTempo,
   ) where

import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import qualified Sound.MIDI.Message.Channel as ChannelMsg
import qualified Sound.MIDI.File.Event.Meta as MetaEvent
import qualified Sound.MIDI.File.Event as Event
import Sound.MIDI.File.Event.Meta (
   ElapsedTime, fromElapsedTime, toElapsedTime,
   Tempo,       fromTempo,       toTempo,
   )


import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Numeric.NonNegative.Wrapper as NonNegW
import qualified Numeric.NonNegative.Class as NonNeg

import Test.QuickCheck (Arbitrary(arbitrary, shrink), )
import qualified Test.QuickCheck as QC

import qualified Control.Monad.Trans.State as MS
import Control.Monad (liftM, liftM2, )
import Sound.MIDI.String (rightS, )

import Data.Ratio((%))
import Data.Ix(Ix)
import Data.List(groupBy, sort)
import Data.Maybe(fromMaybe)

{- |
The datatypes for MIDI Files and MIDI Events
-}

data T = Cons Type Division [Track] deriving (Int -> T -> ShowS
[T] -> ShowS
T -> String
(Int -> T -> ShowS) -> (T -> String) -> ([T] -> ShowS) -> Show T
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [T] -> ShowS
$cshowList :: [T] -> ShowS
show :: T -> String
$cshow :: T -> String
showsPrec :: Int -> T -> ShowS
$cshowsPrec :: Int -> T -> ShowS
Show, T -> T -> Bool
(T -> T -> Bool) -> (T -> T -> Bool) -> Eq T
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: T -> T -> Bool
$c/= :: T -> T -> Bool
== :: T -> T -> Bool
$c== :: T -> T -> Bool
Eq)

data Type     = Mixed | Parallel | Serial
     deriving (Int -> Type -> ShowS
[Type] -> ShowS
Type -> String
(Int -> Type -> ShowS)
-> (Type -> String) -> ([Type] -> ShowS) -> Show Type
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Type] -> ShowS
$cshowList :: [Type] -> ShowS
show :: Type -> String
$cshow :: Type -> String
showsPrec :: Int -> Type -> ShowS
$cshowsPrec :: Int -> Type -> ShowS
Show, Type -> Type -> Bool
(Type -> Type -> Bool) -> (Type -> Type -> Bool) -> Eq Type
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Type -> Type -> Bool
$c/= :: Type -> Type -> Bool
== :: Type -> Type -> Bool
$c== :: Type -> Type -> Bool
Eq, Eq Type
Eq Type
-> (Type -> Type -> Ordering)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Bool)
-> (Type -> Type -> Type)
-> (Type -> Type -> Type)
-> Ord Type
Type -> Type -> Bool
Type -> Type -> Ordering
Type -> Type -> Type
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Type -> Type -> Type
$cmin :: Type -> Type -> Type
max :: Type -> Type -> Type
$cmax :: Type -> Type -> Type
>= :: Type -> Type -> Bool
$c>= :: Type -> Type -> Bool
> :: Type -> Type -> Bool
$c> :: Type -> Type -> Bool
<= :: Type -> Type -> Bool
$c<= :: Type -> Type -> Bool
< :: Type -> Type -> Bool
$c< :: Type -> Type -> Bool
compare :: Type -> Type -> Ordering
$ccompare :: Type -> Type -> Ordering
$cp1Ord :: Eq Type
Ord, Ord Type
Ord Type
-> ((Type, Type) -> [Type])
-> ((Type, Type) -> Type -> Int)
-> ((Type, Type) -> Type -> Int)
-> ((Type, Type) -> Type -> Bool)
-> ((Type, Type) -> Int)
-> ((Type, Type) -> Int)
-> Ix Type
(Type, Type) -> Int
(Type, Type) -> [Type]
(Type, Type) -> Type -> Bool
(Type, Type) -> Type -> Int
forall a.
Ord a
-> ((a, a) -> [a])
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Int)
-> ((a, a) -> a -> Bool)
-> ((a, a) -> Int)
-> ((a, a) -> Int)
-> Ix a
unsafeRangeSize :: (Type, Type) -> Int
$cunsafeRangeSize :: (Type, Type) -> Int
rangeSize :: (Type, Type) -> Int
$crangeSize :: (Type, Type) -> Int
inRange :: (Type, Type) -> Type -> Bool
$cinRange :: (Type, Type) -> Type -> Bool
unsafeIndex :: (Type, Type) -> Type -> Int
$cunsafeIndex :: (Type, Type) -> Type -> Int
index :: (Type, Type) -> Type -> Int
$cindex :: (Type, Type) -> Type -> Int
range :: (Type, Type) -> [Type]
$crange :: (Type, Type) -> [Type]
$cp1Ix :: Ord Type
Ix, Int -> Type
Type -> Int
Type -> [Type]
Type -> Type
Type -> Type -> [Type]
Type -> Type -> Type -> [Type]
(Type -> Type)
-> (Type -> Type)
-> (Int -> Type)
-> (Type -> Int)
-> (Type -> [Type])
-> (Type -> Type -> [Type])
-> (Type -> Type -> [Type])
-> (Type -> Type -> Type -> [Type])
-> Enum Type
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Type -> Type -> Type -> [Type]
$cenumFromThenTo :: Type -> Type -> Type -> [Type]
enumFromTo :: Type -> Type -> [Type]
$cenumFromTo :: Type -> Type -> [Type]
enumFromThen :: Type -> Type -> [Type]
$cenumFromThen :: Type -> Type -> [Type]
enumFrom :: Type -> [Type]
$cenumFrom :: Type -> [Type]
fromEnum :: Type -> Int
$cfromEnum :: Type -> Int
toEnum :: Int -> Type
$ctoEnum :: Int -> Type
pred :: Type -> Type
$cpred :: Type -> Type
succ :: Type -> Type
$csucc :: Type -> Type
Enum, Type
Type -> Type -> Bounded Type
forall a. a -> a -> Bounded a
maxBound :: Type
$cmaxBound :: Type
minBound :: Type
$cminBound :: Type
Bounded)
data Division = Ticks Tempo | SMPTE Int Int
     deriving (Int -> Division -> ShowS
[Division] -> ShowS
Division -> String
(Int -> Division -> ShowS)
-> (Division -> String) -> ([Division] -> ShowS) -> Show Division
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Division] -> ShowS
$cshowList :: [Division] -> ShowS
show :: Division -> String
$cshow :: Division -> String
showsPrec :: Int -> Division -> ShowS
$cshowsPrec :: Int -> Division -> ShowS
Show, Division -> Division -> Bool
(Division -> Division -> Bool)
-> (Division -> Division -> Bool) -> Eq Division
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Division -> Division -> Bool
$c/= :: Division -> Division -> Bool
== :: Division -> Division -> Bool
$c== :: Division -> Division -> Bool
Eq)

type Track = EventList.T ElapsedTime Event.T


{- |
An empty MIDI file.
Tempo is set to one tick per quarter note.
-}
empty :: T
empty :: T
empty = Type -> Division -> [Track] -> T
Cons Type
Mixed (Tempo -> Division
Ticks Tempo
1) [Track
forall time body. T time body
EventList.empty]


instance Arbitrary T where
   arbitrary :: Gen T
arbitrary =
      do (Type
typ, [Track]
content) <-
             [Gen (Type, [Track])] -> Gen (Type, [Track])
forall a. [Gen a] -> Gen a
QC.oneof ([Gen (Type, [Track])] -> Gen (Type, [Track]))
-> [Gen (Type, [Track])] -> Gen (Type, [Track])
forall a b. (a -> b) -> a -> b
$
                (Track -> (Type, [Track])) -> Gen Track -> Gen (Type, [Track])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Track
track -> (Type
Mixed, [Track
track])) Gen Track
forall a. Arbitrary a => Gen a
arbitrary Gen (Type, [Track])
-> [Gen (Type, [Track])] -> [Gen (Type, [Track])]
forall a. a -> [a] -> [a]
:
                ([Track] -> (Type, [Track])) -> Gen [Track] -> Gen (Type, [Track])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Track]
tracks -> (Type
Parallel, [Track]
tracks)) Gen [Track]
forall a. Arbitrary a => Gen a
arbitrary Gen (Type, [Track])
-> [Gen (Type, [Track])] -> [Gen (Type, [Track])]
forall a. a -> [a] -> [a]
:
                ([Track] -> (Type, [Track])) -> Gen [Track] -> Gen (Type, [Track])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\[Track]
tracks -> (Type
Serial, [Track]
tracks)) Gen [Track]
forall a. Arbitrary a => Gen a
arbitrary Gen (Type, [Track])
-> [Gen (Type, [Track])] -> [Gen (Type, [Track])]
forall a. a -> [a] -> [a]
:
                []
         Division
division <- Gen Division
forall a. Arbitrary a => Gen a
arbitrary
         T -> Gen T
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Division -> [Track] -> T
Cons Type
typ Division
division [Track]
content)
   shrink :: T -> [T]
shrink (Cons Type
typ Division
division [Track]
tracks) =
      ([Track] -> T) -> [[Track]] -> [T]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Division -> [Track] -> T
Cons Type
typ Division
division) ([[Track]] -> [T]) -> [[Track]] -> [T]
forall a b. (a -> b) -> a -> b
$ [Track] -> [[Track]]
forall a. Arbitrary a => a -> [a]
shrink [Track]
tracks

instance Arbitrary Division where
   arbitrary :: Gen Division
arbitrary =
      [Gen Division] -> Gen Division
forall a. [Gen a] -> Gen a
QC.oneof ([Gen Division] -> Gen Division) -> [Gen Division] -> Gen Division
forall a b. (a -> b) -> a -> b
$
         (Tempo -> Division) -> Gen Tempo -> Gen Division
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM  (Tempo -> Division
Ticks (Tempo -> Division) -> (Tempo -> Tempo) -> Tempo -> Division
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tempo
1Tempo -> Tempo -> Tempo
forall a. Num a => a -> a -> a
+) (Tempo -> Tempo) -> (Tempo -> Tempo) -> Tempo -> Tempo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tempo -> Tempo -> Tempo) -> Tempo -> Tempo -> Tempo
forall a b c. (a -> b -> c) -> b -> a -> c
flip Tempo -> Tempo -> Tempo
forall a. Integral a => a -> a -> a
mod Tempo
32767) Gen Tempo
forall a. Arbitrary a => Gen a
arbitrary Gen Division -> [Gen Division] -> [Gen Division]
forall a. a -> [a] -> [a]
:
         (Int -> Int -> Division) -> Gen Int -> Gen Int -> Gen Division
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (\Int
x Int
y -> Int -> Int -> Division
SMPTE (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
x Int
127) (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int -> Int -> Int
forall a. Integral a => a -> a -> a
mod Int
y Int
255)) Gen Int
forall a. Arbitrary a => Gen a
arbitrary Gen Int
forall a. Arbitrary a => Gen a
arbitrary Gen Division -> [Gen Division] -> [Gen Division]
forall a. a -> [a] -> [a]
:
         []



{- * Processing -}

{- |
Apply a function to each track.
-}
mapTrack :: (Track -> Track) -> T -> T
mapTrack :: (Track -> Track) -> T -> T
mapTrack Track -> Track
f (Cons Type
mfType Division
division [Track]
tracks) =
   Type -> Division -> [Track] -> T
Cons Type
mfType Division
division ((Track -> Track) -> [Track] -> [Track]
forall a b. (a -> b) -> [a] -> [b]
map Track -> Track
f [Track]
tracks)

{- |
Convert all @NoteOn p 0@ to @NoteOff p 64@.
The latter one is easier to process.
-}
explicitNoteOff :: T -> T
explicitNoteOff :: T -> T
explicitNoteOff =
   (Track -> Track) -> T -> T
mapTrack ((T -> T) -> Track -> Track
forall body0 body1 time.
(body0 -> body1) -> T time body0 -> T time body1
EventList.mapBody ((T -> T) -> T -> T
Event.mapVoice T -> T
VoiceMsg.explicitNoteOff))


{- |
Convert all @NoteOff p 64@ to @NoteOn p 0@.
The latter one can be encoded more efficiently using the running status.
-}
implicitNoteOff :: T -> T
implicitNoteOff :: T -> T
implicitNoteOff =
   (Track -> Track) -> T -> T
mapTrack ((T -> T) -> Track -> Track
forall body0 body1 time.
(body0 -> body1) -> T time body0 -> T time body1
EventList.mapBody ((T -> T) -> T -> T
Event.mapVoice T -> T
VoiceMsg.implicitNoteOff))


getTracks :: T -> [Track]
getTracks :: T -> [Track]
getTracks (Cons Type
_ Division
_ [Track]
trks) = [Track]
trks

{- |
Merge all tracks into a single track
according to the MIDI file type.
-}
mergeTracks ::
   (NonNeg.C time) =>
   Type ->
   [EventList.T time event] ->
   EventList.T time event
mergeTracks :: Type -> [T time event] -> T time event
mergeTracks Type
typ [T time event]
tracks =
   case Type
typ of
      Type
Mixed    -> (T time event -> T time event -> T time event)
-> T time event -> [T time event] -> T time event
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((event -> event -> Bool)
-> T time event -> T time event -> T time event
forall time body.
C time =>
(body -> body -> Bool) -> T time body -> T time body -> T time body
EventList.mergeBy (\event
_ event
_ -> Bool
True)) T time event
forall time body. T time body
EventList.empty [T time event]
tracks
      Type
Parallel -> (T time event -> T time event -> T time event)
-> T time event -> [T time event] -> T time event
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((event -> event -> Bool)
-> T time event -> T time event -> T time event
forall time body.
C time =>
(body -> body -> Bool) -> T time body -> T time body -> T time body
EventList.mergeBy (\event
_ event
_ -> Bool
True)) T time event
forall time body. T time body
EventList.empty [T time event]
tracks
      Type
Serial   -> [T time event] -> T time event
forall time body. [T time body] -> T time body
EventList.concat [T time event]
tracks

{- |
Process and remove all @SetTempo@ events.
The result is an event list where the times are measured in seconds.
-}
secondsFromTicks ::
   Division ->
   EventList.T ElapsedTime Event.T ->
   EventList.T NonNegW.Rational Event.T
secondsFromTicks :: Division -> Track -> T Rational T
secondsFromTicks Division
division =
   T Rational (Maybe T) -> T Rational T
forall time body. C time => T time (Maybe body) -> T time body
EventList.catMaybes (T Rational (Maybe T) -> T Rational T)
-> (Track -> T Rational (Maybe T)) -> Track -> T Rational T
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (State Tempo (T Rational (Maybe T))
 -> Tempo -> T Rational (Maybe T))
-> Tempo
-> State Tempo (T Rational (Maybe T))
-> T Rational (Maybe T)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Tempo (T Rational (Maybe T)) -> Tempo -> T Rational (Maybe T)
forall s a. State s a -> s -> a
MS.evalState Tempo
MetaEvent.defltTempo (State Tempo (T Rational (Maybe T)) -> T Rational (Maybe T))
-> (Track -> State Tempo (T Rational (Maybe T)))
-> Track
-> T Rational (Maybe T)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
   (ElapsedTime -> StateT Tempo Identity Rational)
-> (T -> StateT Tempo Identity (Maybe T))
-> Track
-> State Tempo (T Rational (Maybe T))
forall (m :: * -> *) time0 time1 body0 body1.
Monad m =>
(time0 -> m time1)
-> (body0 -> m body1) -> T time0 body0 -> m (T time1 body1)
EventList.mapM
      (\ElapsedTime
ticks -> do
         Tempo
microsPerQN <- StateT Tempo Identity Tempo
forall (m :: * -> *) s. Monad m => StateT s m s
MS.get
         -- cf. Standard MIDI Files 1.0, page 14
         Rational -> StateT Tempo Identity Rational
forall (m :: * -> *) a. Monad m => a -> m a
return (Rational -> StateT Tempo Identity Rational)
-> Rational -> StateT Tempo Identity Rational
forall a b. (a -> b) -> a -> b
$
            String -> Ratio Integer -> Rational
forall a. (Ord a, Num a) => String -> a -> T a
NonNegW.fromNumberMsg String
"MIDI.File.processTempo" (Ratio Integer -> Rational) -> Ratio Integer -> Rational
forall a b. (a -> b) -> a -> b
$
            ElapsedTime -> Integer
fromElapsedTime ElapsedTime
ticks Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Tempo -> Int
forall a. T a -> a
NonNegW.toNumber Tempo
microsPerQN)
               Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
% (Integer
1000000 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Tempo -> Int
forall a. T a -> a
NonNegW.toNumber (Division -> Tempo
ticksPerQuarterNote Division
division))))
      (\T
ev ->
         case T
ev of
            Event.MetaEvent (MetaEvent.SetTempo Tempo
microsPerQN) ->
               Tempo -> StateT Tempo Identity ()
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
MS.put Tempo
microsPerQN StateT Tempo Identity ()
-> StateT Tempo Identity (Maybe T)
-> StateT Tempo Identity (Maybe T)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe T -> StateT Tempo Identity (Maybe T)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe T
forall a. Maybe a
Nothing
            T
_ -> Maybe T -> StateT Tempo Identity (Maybe T)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe T -> StateT Tempo Identity (Maybe T))
-> Maybe T -> StateT Tempo Identity (Maybe T)
forall a b. (a -> b) -> a -> b
$ T -> Maybe T
forall a. a -> Maybe a
Just T
ev)


ticksPerQuarterNote :: Division -> Tempo
ticksPerQuarterNote :: Division -> Tempo
ticksPerQuarterNote Division
division =
   case Division
division of
      Ticks Tempo
ticksPerQN -> Tempo
ticksPerQN
      SMPTE Int
framesPerSecond Int
ticksPerFrames ->
         {-
         I am uncertain, whether this is correct.
         The "Standard MIDI File 1.0" is unprecise
         with respect to the question,
         whether SetTempo is relevant also in SMPTE mode.
         TiMidity-2.13.2 interprets this kind of division as we do
         and qualifies it as "totally untested".
         -}
         String -> Int -> Tempo
forall a. (Ord a, Num a) => String -> a -> T a
NonNegW.fromNumberMsg String
"MIDI.File.ticksPerQuarterNote" (Int -> Tempo) -> Int -> Tempo
forall a b. (a -> b) -> a -> b
$
         Int
framesPerSecond Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
ticksPerFrames



{- * Debugging -}

{-# DEPRECATED
      showLines, changeVelocity, resampleTime,
      showEvent, showTime,
      sortEvents, progChangeBeforeSetTempo
         "only use this for debugging" #-}

{- |
Show the 'T' with one event per line,
suited for comparing MIDIFiles with @diff@.
Can this be replaced by 'Sound.MIDI.Load.showFile'?
-}
showLines :: T -> String
showLines :: T -> String
showLines (Cons Type
mfType Division
division [Track]
tracks) =
   let showTrack :: T a b -> String
showTrack T a b
track =
          [String] -> String
unlines
             (String
"    (" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
              ((a, b) -> String) -> [(a, b)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map
                 (\(a, b)
event -> String
"      " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (a, b) -> String
forall a. Show a => a -> String
show (a, b)
event String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" :")
                 (T a b -> [(a, b)]
forall a b. T a b -> [(a, b)]
EventList.toPairList T a b
track) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
              String
"    []) :" String -> [String] -> [String]
forall a. a -> [a] -> [a]
:
              [])
   in  String
"MIDIFile.Cons " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
mfType String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Division -> String
forall a. Show a => a -> String
show Division
division String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
") (\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++
       (Track -> String) -> [Track] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Track -> String
forall a b. (Show a, Show b) => T a b -> String
showTrack [Track]
tracks String -> ShowS
forall a. [a] -> [a] -> [a]
++
       String
"  [])"

showTime :: ElapsedTime -> ShowS
showTime :: ElapsedTime -> ShowS
showTime ElapsedTime
t =
   Int -> ShowS -> ShowS
rightS Int
10 (ElapsedTime -> ShowS
forall a. Show a => a -> ShowS
shows ElapsedTime
t) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" : "

showEvent :: Event.T -> ShowS
showEvent :: T -> ShowS
showEvent (Event.MIDIEvent T
e) =
   String -> ShowS
showString String
"Event.MIDIEvent " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T -> ShowS
forall a. Show a => a -> ShowS
shows T
e
showEvent (Event.MetaEvent T
e) =
   String -> ShowS
showString String
"Event.MetaEvent " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T -> ShowS
forall a. Show a => a -> ShowS
shows T
e
showEvent (Event.SystemExclusive T
s) =
   String -> ShowS
showString String
"SystemExclusive " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. T -> ShowS
forall a. Show a => a -> ShowS
shows T
s


{- |
A hack that changes the velocities by a rational factor.
-}

changeVelocity :: Double -> T -> T
changeVelocity :: Double -> T -> T
changeVelocity Double
r =
   let multVel :: Velocity -> Velocity
multVel Velocity
vel =
          Int -> Velocity
VoiceMsg.toVelocity (Int -> Velocity) -> Int -> Velocity
forall a b. (a -> b) -> a -> b
$
          Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
round (Double
r Double -> Double -> Double
forall a. Num a => a -> a -> a
* Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Velocity -> Int
VoiceMsg.fromVelocity Velocity
vel))
       procVoice :: T -> T
procVoice (VoiceMsg.NoteOn  Pitch
pitch Velocity
vel) = Pitch -> Velocity -> T
VoiceMsg.NoteOn  Pitch
pitch (Velocity -> Velocity
multVel Velocity
vel)
       procVoice (VoiceMsg.NoteOff Pitch
pitch Velocity
vel) = Pitch -> Velocity -> T
VoiceMsg.NoteOff Pitch
pitch (Velocity -> Velocity
multVel Velocity
vel)
       procVoice T
me = T
me
   in  (Track -> Track) -> T -> T
mapTrack ((T -> T) -> Track -> Track
forall body0 body1 time.
(body0 -> body1) -> T time body0 -> T time body1
EventList.mapBody ((T -> T) -> T -> T
Event.mapVoice T -> T
procVoice))

{- |
Change the time base.
-}

resampleTime :: Double -> T -> T
resampleTime :: Double -> T -> T
resampleTime Double
r =
   let divTime :: a -> b
divTime  a
time = Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
time Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
r)
       newTempo :: a -> b
newTempo a
tmp  = Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (a -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
tmp  Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
r)
       procEvent :: T -> T
procEvent T
ev =
          case T
ev of
             Event.MetaEvent (MetaEvent.SetTempo Tempo
tmp) ->
                T -> T
Event.MetaEvent (Tempo -> T
MetaEvent.SetTempo (Tempo -> Tempo
forall b a. (Integral b, Integral a) => a -> b
newTempo Tempo
tmp))
             T
_ -> T
ev
   in  (Track -> Track) -> T -> T
mapTrack ((T -> T) -> Track -> Track
forall body0 body1 time.
(body0 -> body1) -> T time body0 -> T time body1
EventList.mapBody T -> T
procEvent (Track -> Track) -> (Track -> Track) -> Track -> Track
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ElapsedTime -> ElapsedTime) -> Track -> Track
forall time0 time1 body.
(time0 -> time1) -> T time0 body -> T time1 body
EventList.mapTime ElapsedTime -> ElapsedTime
forall b a. (Integral b, Integral a) => a -> b
divTime)

{- |
Sort MIDI note events lexicographically.
This is to make MIDI files unique
and robust against changes in the computation.
In principle Performance.merge should handle this
but due to rounding errors in Float
the order of note events still depends on some internal issues.
The sample rate of MIDI events should be coarse enough
to assert unique results.
-}

sortEvents :: T -> T
sortEvents :: T -> T
sortEvents =
   let coincideNote :: T -> T -> Bool
coincideNote T
ev0 T
ev1 =
          Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$
             do (Channel
_,T
x0) <- T -> Maybe (Channel, T)
Event.maybeVoice T
ev0
                (Channel
_,T
x1) <- T -> Maybe (Channel, T)
Event.maybeVoice T
ev1
                Bool -> Maybe Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (T -> Bool
VoiceMsg.isNote T
x0 Bool -> Bool -> Bool
&& T -> Bool
VoiceMsg.isNote T
x1)
{-
       coincideNote
          (Event.MIDIEvent (ChannelMsg.Cons _ (ChannelMsg.Voice x0)))
          (Event.MIDIEvent (ChannelMsg.Cons _ (ChannelMsg.Voice x1))) =
          VoiceMsg.isNote x0 && VoiceMsg.isNote x1
       coincideNote _ _ = False
-}
       sortTrack :: Track -> Track
sortTrack =
          T ElapsedTime [T] -> Track
forall time body. C time => T time [body] -> T time body
EventList.flatten (T ElapsedTime [T] -> Track)
-> (Track -> T ElapsedTime [T]) -> Track -> Track
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([T] -> [T]) -> T ElapsedTime [T] -> T ElapsedTime [T]
forall body0 body1 time.
(body0 -> body1) -> T time body0 -> T time body1
EventList.mapBody [T] -> [T]
forall a. Ord a => [a] -> [a]
sort (T ElapsedTime [T] -> T ElapsedTime [T])
-> (Track -> T ElapsedTime [T]) -> Track -> T ElapsedTime [T]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
          ([T] -> [[T]]) -> Track -> T ElapsedTime [T]
forall time a b. C time => ([a] -> [b]) -> T time a -> T time b
EventList.mapCoincident ((T -> T -> Bool) -> [T] -> [[T]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy T -> T -> Bool
coincideNote)
   in  (Track -> Track) -> T -> T
mapTrack Track -> Track
sortTrack

{- |
Old versions of "Haskore.Interface.MIDI.Write"
wrote 'MIDIEvent.ProgramChange' and 'MetaEvent.SetTempo'
once at the beginning of a file in that order.
The current version supports multiple 'MIDIEvent.ProgramChange's in a track and
thus a 'MIDIEvent.ProgramChange' is set immediately before a note.
Because of this a 'MIDIEvent.ProgramChange' is now always after a 'MetaEvent.SetTempo'.
For checking equivalence with old MIDI files we can switch this back.
-}

progChangeBeforeSetTempo :: T -> T
progChangeBeforeSetTempo :: T -> T
progChangeBeforeSetTempo =
   let sortTrack :: T time T -> Maybe (T time T)
sortTrack T time T
evs =
          do ((time
t0,st :: T
st@(Event.MetaEvent (MetaEvent.SetTempo Tempo
_))), T time T
rest0)
                   <- T time T -> Maybe ((time, T), T time T)
forall time body. T time body -> Maybe ((time, body), T time body)
EventList.viewL T time T
evs
             ((time
t1,pc :: T
pc@(Event.MIDIEvent (ChannelMsg.Cons Channel
_
                (ChannelMsg.Voice (VoiceMsg.ProgramChange Program
_))))), T time T
rest1)
                   <- T time T -> Maybe ((time, T), T time T)
forall time body. T time body -> Maybe ((time, body), T time body)
EventList.viewL T time T
rest0
             T time T -> Maybe (T time T)
forall (m :: * -> *) a. Monad m => a -> m a
return (T time T -> Maybe (T time T)) -> T time T -> Maybe (T time T)
forall a b. (a -> b) -> a -> b
$
                time -> T -> T time T -> T time T
forall time body. time -> body -> T time body -> T time body
EventList.cons time
t0 T
pc (T time T -> T time T) -> T time T -> T time T
forall a b. (a -> b) -> a -> b
$
                time -> T -> T time T -> T time T
forall time body. time -> body -> T time body -> T time body
EventList.cons time
0  T
st (T time T -> T time T) -> T time T -> T time T
forall a b. (a -> b) -> a -> b
$
                time -> T time T -> T time T
forall time body. C time => time -> T time body -> T time body
EventList.delay time
t1 T time T
rest1
   in  (Track -> Track) -> T -> T
mapTrack (\Track
track -> Track -> Maybe Track -> Track
forall a. a -> Maybe a -> a
fromMaybe Track
track (Track -> Maybe Track
forall time. (Num time, C time) => T time T -> Maybe (T time T)
sortTrack Track
track))