{- |
MIDI-File Datatype

Taken from Haskore.
-}

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

   showLines, changeVelocity, getTracks, 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 NonNeg

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

import Control.Monad (liftM, liftM2, )
-- import Sound.MIDI.IO(ByteList)
import Sound.MIDI.String (rightS, )
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, Ord, Ix, Enum, Bounded)
data Division = Ticks Tempo | SMPTE Int Int
     deriving (Show, Eq)

type Track = EventList.T ElapsedTime Event.T


{- |
An empty MIDI file.
-}

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


instance Arbitrary T where
   arbitrary =
      do (typ, content) <-
             QC.oneof $
                fmap (\track -> (Mixed, [track])) arbitrary :
                fmap (\tracks -> (Parallel, tracks)) arbitrary :
                fmap (\tracks -> (Serial, tracks)) arbitrary :
                []
         division <- arbitrary
         return (Cons typ division content)
   coarbitrary = error "not implemented"

instance Arbitrary Division where
   arbitrary =
      QC.oneof $
         liftM  (Ticks . (1+)) arbitrary :
         liftM2 (\x y -> SMPTE (1+abs x) (1+abs y)) arbitrary arbitrary :
         []
   coarbitrary = error "not implemented"



{- * Processing -}

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

{- |
Convert all @NoteOn p 0@ to @NoteOff p 64@.
The latter one is easier to process.
-}
explicitNoteOff :: T -> T
explicitNoteOff =
   mapTrack (EventList.mapBody (Event.mapVoice 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 =
   mapTrack (EventList.mapBody (Event.mapVoice VoiceMsg.implicitNoteOff))


{- * Debugging -}

{-# DEPRECATED
      showLines, changeVelocity, getTracks, 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 (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.T -> ShowS
showEvent (Event.MIDIEvent e) =
   showString "Event.MIDIEvent " . shows e
showEvent (Event.MetaEvent e) =
   showString "Event.MetaEvent " . shows e
showEvent (Event.SystemExclusive s) =
   showString "SystemExclusive " . shows s


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

changeVelocity :: Double -> T -> T
changeVelocity r =
   let multVel vel =
          VoiceMsg.toVelocity $
          round (r * fromIntegral (VoiceMsg.fromVelocity vel))
       procVoice (VoiceMsg.NoteOn  pitch vel) = VoiceMsg.NoteOn  pitch (multVel vel)
       procVoice (VoiceMsg.NoteOff pitch vel) = VoiceMsg.NoteOff pitch (multVel vel)
       procVoice me = me
   in  mapTrack (EventList.mapBody (Event.mapVoice procVoice))

{- |
Change the time base.
-}

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

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 =
   let coincideNote ev0 ev1 =
          fromMaybe False $
             do (_,x0) <- Event.maybeVoice ev0
                (_,x1) <- Event.maybeVoice ev1
                return (VoiceMsg.isNote x0 && VoiceMsg.isNote 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 =
          EventList.flatten . EventList.mapBody sort .
          EventList.mapCoincident (groupBy coincideNote)
   in  mapTrack 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 =
   let sortTrack evs =
          do ((t0,st@(Event.MetaEvent (MetaEvent.SetTempo _))), rest0)
                   <- EventList.viewL evs
             ((t1,pc@(Event.MIDIEvent (ChannelMsg.Cons _
                (ChannelMsg.Voice (VoiceMsg.ProgramChange _))))), rest1)
                   <- EventList.viewL rest0
             return $
                EventList.cons t0 pc $
                EventList.cons 0  st $
                EventList.delay t1 rest1
   in  mapTrack (\track -> fromMaybe track (sortTrack track))