{- |
MIDI-File Datatype

Taken from Haskore.
-}

module Sound.MIDI.File(
   T(..), Division(..), Track, Type(..),
   SchedEvent, Event(..), ElapsedTime,
   Tempo, SMPTEHours, SMPTEMins, SMPTESecs, SMPTEFrames, SMPTEBits,
   MetaEvent(..),
   maybeMIDIEvent, maybeMetaEvent,
   Key(..), Mode(..),
   defltST, defltDurT, empty,

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

import qualified Sound.MIDI.Event as MIDIEvent
-- import Sound.MIDI.Event (T(NoteOn, NoteOff))
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Numeric.NonNegative.Wrapper as NonNeg

import Sound.MIDI.IO(ByteString)
import Sound.MIDI.String (rightS, concatS)
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 (Show, Eq)

data Type     = Mixed | Parallel | Serial
     deriving (Show,Eq,Enum)
data Division = Ticks Tempo | SMPTE Int Int
     deriving (Show,Eq)

type Track       = EventList.T ElapsedTime Event
type SchedEvent  = (ElapsedTime, Event)
type ElapsedTime = NonNeg.Integer

data Event =
     MIDIEvent MIDIEvent.Channel MIDIEvent.T
   | MetaEvent MetaEvent
   | SysExStart ByteString         -- F0
   | SysExCont  ByteString         -- F7
     deriving (Show,Eq,Ord)


maybeMIDIEvent :: Event -> Maybe (MIDIEvent.Channel, MIDIEvent.T)
maybeMIDIEvent (MIDIEvent ch ev) = Just (ch,ev)
maybeMIDIEvent _ = Nothing

maybeMetaEvent :: Event -> Maybe MetaEvent
maybeMetaEvent (MetaEvent mev) = Just mev
maybeMetaEvent _ = Nothing


{- * Meta Events -}

type Tempo       = NonNeg.Int
type SMPTEHours  = Int
type SMPTEMins   = Int
type SMPTESecs   = Int
type SMPTEFrames = Int
type SMPTEBits   = Int

data MetaEvent =
     SequenceNum Int
   | TextEvent String
   | Copyright String
   | TrackName String
   | InstrName String
   | Lyric String
   | Marker String
   | CuePoint String
   | MIDIPrefix MIDIEvent.Channel
   | EndOfTrack
   | SetTempo Tempo
   | SMPTEOffset SMPTEHours SMPTEMins SMPTESecs SMPTEFrames SMPTEBits
   | TimeSig Int Int Int Int
   | KeySig Key Mode
   | SequencerSpecific ByteString
   | Unknown Int ByteString
     deriving (Show, Eq, Ord)

{- |
The following enumerated type lists all the keys in order of their key
signatures from flats to sharps.
(@Cf@ = 7 flats, @Gf@ = 6 flats ... @F@ = 1 flat, @C@ = 0 flats\/sharps,
@G@ = 1 sharp, ... @Cs@ = 7 sharps.)
Useful for transposition.
-}

data Key = KeyCf | KeyGf | KeyDf | KeyAf | KeyEf | KeyBf | KeyF
         | KeyC  | KeyG  | KeyD  | KeyA  | KeyE  | KeyB  | KeyFs | KeyCs
             deriving (Show, Eq, Ord, Ix, Enum)

{- |
The Key Signature specifies a mode, either major or minor.
-}

data Mode = Major | Minor
            deriving (Show, Eq, Ord, Enum)

{- |
Default duration of a whole note, in seconds; and the default SetTempo
value, in microseconds per quarter note.  Both express the default of
120 beats per minute.
-}

defltDurT :: ElapsedTime
defltDurT = 2
defltST :: Tempo
defltST = div 1000000 (fromIntegral defltDurT)

{- |
An empty MIDI file.
-}

empty :: T
empty = Cons Mixed (Ticks 0) [EventList.empty]


{- * 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 (Cons mfType division tracks) =
   let showTrack track =
          unlines
             ("    (" :
              map
                 (\event -> "      " ++ show event ++ " :")
                 (EventList.toPairList track) ++
              "    []) :" :
              [])
   in  "MIDIFile.Cons " ++ show mfType ++ " (" ++ show division ++ ") (\n" ++
       concatMap showTrack tracks ++
       "  [])"

showTime :: ElapsedTime -> ShowS
showTime t =
   rightS 10 (shows t) . showString " : "

showEvent :: Event -> ShowS
showEvent (MIDIEvent ch e) =
   showString "MIDIEvent " . shows ch . showString " " . shows e
showEvent (MetaEvent e) =
   showString "MetaEvent " . shows e
showEvent (SysExStart s) =
   showString "SysExStart " . concatS (map shows s)
showEvent (SysExCont s) =
   showString "SysExCont "  . concatS (map shows s)


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

changeVelocity :: Double -> T -> T
changeVelocity r (Cons mfType division tracks) =
   let multVel vel = MIDIEvent.toVelocity $
          round (r * fromIntegral (MIDIEvent.fromVelocity vel))
       procMIDIEvent (MIDIEvent.NoteOn  pitch vel) = MIDIEvent.NoteOn  pitch (multVel vel)
       procMIDIEvent (MIDIEvent.NoteOff pitch vel) = MIDIEvent.NoteOff pitch (multVel vel)
       procMIDIEvent me = me
       procEvent (MIDIEvent chan ev) = MIDIEvent chan (procMIDIEvent ev)
       procEvent ev = ev
   in  Cons mfType division (map (EventList.mapBody procEvent) tracks)

{- |
Change the time base.
-}

resampleTime :: Double -> T -> T
resampleTime r (Cons mfType division tracks) =
   let divTime  time = round (fromIntegral time / r)
       newTempo tmp  = round (fromIntegral tmp  * r)
       procEvent ev =
          case ev of
             MetaEvent (SetTempo tmp) ->
                MetaEvent (SetTempo (newTempo tmp))
             _ -> ev
   in  Cons mfType division
          (map (EventList.mapBody procEvent . EventList.mapTime divTime) tracks)

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

{- |
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 (Cons mfType division tracks) =
   let coincideNote (MIDIEvent _ x0) (MIDIEvent _ x1) =
          MIDIEvent.isNote x0 && MIDIEvent.isNote x1
       coincideNote _ _ = False
       sortTrack =
          EventList.flatten . EventList.mapBody sort .
          EventList.mapCoincident (groupBy coincideNote)
   in  Cons mfType division (map sortTrack tracks)

{- |
Old versions of "Haskore.Interface.MIDI.Write"
wrote 'MIDIEvent.ProgramChange' and '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 'SetTempo'.
For checking equivalence with old MIDI files we can switch this back.
-}

progChangeBeforeSetTempo :: T -> T
progChangeBeforeSetTempo (Cons mfType division tracks) =
   let sortTrack evs =
          do ((t0,st@(MetaEvent (SetTempo _))), rest0)
                   <- EventList.viewL evs
             ((t1,pc@(MIDIEvent _ (MIDIEvent.ProgramChange _))), rest1)
                   <- EventList.viewL rest0
             return $
                EventList.cons t0 pc $
                EventList.cons 0  st $
                EventList.delay t1 rest1
   in  Cons mfType division
          (map (\track -> fromMaybe track (sortTrack track)) tracks)