diff --git a/midi.cabal b/midi.cabal --- a/midi.cabal +++ b/midi.cabal @@ -1,24 +1,25 @@ Name: midi -Version: 0.1.6 +Version: 0.1.7 License: GPL License-File: LICENSE Author: Henning Thielemann Maintainer: Henning Thielemann Homepage: http://www.haskell.org/haskellwiki/MIDI Category: Sound, Music -Tested-With: GHC==6.4.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.3, GHC==7.0.4, GHC==7.2.1 +Tested-With: GHC==6.4.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.3 +Tested-With: GHC==7.0.4, GHC==7.2.1 Cabal-Version: >=1.6 Build-Type: Simple Synopsis: Handling of MIDI messages and files Description: - MIDI is the Musical Instrument Digital Interface. - The package contains definition of realtime and file MIDI messages, - reading and writing MIDI files, - and some definitions from General MIDI standard. - It contains no sending and receiving of MIDI messages. - Cf. @alsa-seq@, @PortMidi@, @hmidi@, @alsa@, @alsa-midi@ packages. - For music composition with MIDI output, see @haskore@. - Alternate packages are @HCodecs@, @zmidi-core@. + MIDI is the Musical Instrument Digital Interface. + The package contains definition of realtime and file MIDI messages, + reading and writing MIDI files, + and some definitions from the General MIDI standard. + It contains no sending and receiving of MIDI messages. + For this purpose see the @alsa-seq@, @jack@, @PortMidi@, @hmidi@ packages. + For music composition with MIDI output, see @haskore@. + Alternative packages are @HCodecs@, @zmidi-core@. Extra-Source-Files: Makefile src/Sound/MIDI/Example/Tomatosalad.hs @@ -29,7 +30,7 @@ Source-Repository this type: darcs location: http://code.haskell.org/~thielema/midi/ - tag: 0.1.6 + tag: 0.1.7 Flag splitBase description: Choose the new smaller, split-up base package. @@ -51,10 +52,10 @@ If flag(splitBase) Build-Depends: random >=1 && <2, - base >= 2 && <5 + base >= 3 && <5 Else Build-Depends: - base >= 1.0 && < 2 + base >= 1.0 && < 3 GHC-Options: -Wall Hs-Source-Dirs: src @@ -74,6 +75,7 @@ Sound.MIDI.Message.System.Exclusive Sound.MIDI.Message.System.Common Sound.MIDI.Message.System.RealTime + Sound.MIDI.Message.Class.Check Sound.MIDI.Controller Sound.MIDI.Manufacturer Sound.MIDI.General diff --git a/src/Sound/MIDI/File.hs b/src/Sound/MIDI/File.hs --- a/src/Sound/MIDI/File.hs +++ b/src/Sound/MIDI/File.hs @@ -10,8 +10,10 @@ ElapsedTime, fromElapsedTime, toElapsedTime, Tempo, fromTempo, toTempo, explicitNoteOff, implicitNoteOff, + getTracks, mergeTracks, + secondsFromTicks, ticksPerQuarterNote, - showLines, changeVelocity, getTracks, resampleTime, + showLines, changeVelocity, resampleTime, showEvent, showTime, sortEvents, progChangeBeforeSetTempo, ) where @@ -27,14 +29,18 @@ import qualified Data.EventList.Relative.TimeBody as EventList --- import qualified Numeric.NonNegative.Wrapper as NonNeg +import qualified Numeric.NonNegative.Wrapper as NonNegW +import qualified Numeric.NonNegative.Class as NonNeg import Test.QuickCheck (Arbitrary(arbitrary), ) import qualified Test.QuickCheck as QC +import qualified Control.Monad.Trans.State as MS import Control.Monad (liftM, liftM2, ) -- import Sound.MIDI.IO(ByteList) import Sound.MIDI.String (rightS, ) + +import Data.Ratio((%)) import Data.Ix(Ix) import Data.List(groupBy, sort) import Data.Maybe(fromMaybe) @@ -55,10 +61,10 @@ {- | An empty MIDI file. +Tempo is set to one tick per quarter note. -} - empty :: T -empty = Cons Mixed (Ticks 0) [EventList.empty] +empty = Cons Mixed (Ticks 1) [EventList.empty] instance Arbitrary T where @@ -108,10 +114,72 @@ mapTrack (EventList.mapBody (Event.mapVoice VoiceMsg.implicitNoteOff)) +getTracks :: T -> [Track] +getTracks (Cons _ _ trks) = 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 typ tracks = + case typ of + Mixed -> foldr (EventList.mergeBy (\_ _ -> True)) EventList.empty tracks + Parallel -> foldr (EventList.mergeBy (\_ _ -> True)) EventList.empty tracks + Serial -> EventList.concat 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 = + EventList.catMaybes . + flip MS.evalState MetaEvent.defltST . + EventList.mapM + (\ticks -> do + microsPerQN <- MS.get + -- cf. Standard MIDI Files 1.0, page 14 + return $ + NonNegW.fromNumberMsg "MIDI.File.processTempo" $ + fromElapsedTime ticks * fromIntegral (NonNegW.toNumber microsPerQN) + % (1000000 * fromIntegral (NonNegW.toNumber (ticksPerQuarterNote division)))) + (\ev -> + case ev of + Event.MetaEvent (MetaEvent.SetTempo microsPerQN) -> + MS.put microsPerQN >> return Nothing + _ -> return $ Just ev) + + +ticksPerQuarterNote :: Division -> Tempo +ticksPerQuarterNote division = + case division of + Ticks ticksPerQN -> ticksPerQN + SMPTE framesPerSecond 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". + -} + NonNegW.fromNumberMsg "MIDI.File.ticksPerQuarterNote" $ + framesPerSecond * ticksPerFrames + + + {- * Debugging -} {-# DEPRECATED - showLines, changeVelocity, getTracks, resampleTime, + showLines, changeVelocity, resampleTime, showEvent, showTime, sortEvents, progChangeBeforeSetTempo "only use this for debugging" #-} @@ -176,9 +244,6 @@ 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. diff --git a/src/Sound/MIDI/File/Event/Meta.hs b/src/Sound/MIDI/File/Event/Meta.hs --- a/src/Sound/MIDI/File/Event/Meta.hs +++ b/src/Sound/MIDI/File/Event/Meta.hs @@ -128,12 +128,15 @@ {- | -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. +Default number of quarter notes in a second. -} defltDurT :: ElapsedTime defltDurT = 2 + +{- | +The default SetTempo value, in microseconds per quarter note. +This expresses the default of 120 beats per minute. +-} defltST :: Tempo defltST = div 1000000 (fromIntegral defltDurT) diff --git a/src/Sound/MIDI/General.hs b/src/Sound/MIDI/General.hs --- a/src/Sound/MIDI/General.hs +++ b/src/Sound/MIDI/General.hs @@ -223,7 +223,7 @@ | Maracas | ShortWhistle | LongWhistle | ShortGuiro | LongGuiro | Claves | HiWoodBlock | LowWoodBlock | MuteCuica | OpenCuica | MuteTriangle - | OpenTriangle -- Midi Key 82 + | OpenTriangle -- Midi Key 81 deriving (Show, Eq, Ord, Ix, Enum, Bounded) -- http://oxygen.cside6.com/gallery/ins_gm.html diff --git a/src/Sound/MIDI/Message.hs b/src/Sound/MIDI/Message.hs --- a/src/Sound/MIDI/Message.hs +++ b/src/Sound/MIDI/Message.hs @@ -34,8 +34,6 @@ data T = Channel Channel.T | System System.T --- Show instance requires Show instance of System.T --- deriving (Show) get :: Parser.C parser => Parser.Fallible parser T diff --git a/src/Sound/MIDI/Message/Channel.hs b/src/Sound/MIDI/Message/Channel.hs --- a/src/Sound/MIDI/Message/Channel.hs +++ b/src/Sound/MIDI/Message/Channel.hs @@ -42,7 +42,6 @@ messageChannel :: Channel, messageBody :: Body } - -- ToDo: make nicer Show instance deriving (Show, Eq, Ord) data Body = diff --git a/src/Sound/MIDI/Message/Class/Check.hs b/src/Sound/MIDI/Message/Class/Check.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Message/Class/Check.hs @@ -0,0 +1,85 @@ +module Sound.MIDI.Message.Class.Check where + +import Sound.MIDI.Message.Channel (Channel, ) +import Sound.MIDI.Message.Channel.Voice (Pitch, Velocity, Program, Controller, ) + +import qualified Sound.MIDI.Message as MidiMsg +import qualified Sound.MIDI.Message.Channel as ChannelMsg +import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg +import qualified Sound.MIDI.Message.Channel.Mode as Mode + +import Control.Monad (guard, ) + + +class C event where + note :: Channel -> event -> Maybe (Velocity, Pitch, Bool) + program :: Channel -> event -> Maybe Program + anyController :: Channel -> event -> Maybe (Controller, Int) + pitchBend :: Channel -> event -> Maybe Int + channelPressure :: Channel -> event -> Maybe Int + mode :: Channel -> event -> Maybe Mode.T + +controller :: + (C event) => + Channel -> Controller -> event -> Maybe Int +controller chan ctrl e = do + (c,n) <- anyController chan e + guard (ctrl==c) + return n + + +instance C ChannelMsg.T where + note chan msg = do + guard (ChannelMsg.messageChannel msg == chan) + ChannelMsg.Voice voice <- Just $ ChannelMsg.messageBody msg + case voice of + VoiceMsg.NoteOn pitch velocity -> Just (velocity, pitch, True) + VoiceMsg.NoteOff pitch velocity -> Just (velocity, pitch, False) + _ -> Nothing + + program chan msg = do + guard (ChannelMsg.messageChannel msg == chan) + ChannelMsg.Voice (VoiceMsg.ProgramChange pgm) <- + Just $ ChannelMsg.messageBody msg + return pgm + + anyController chan msg = do + guard (ChannelMsg.messageChannel msg == chan) + ChannelMsg.Voice (VoiceMsg.Control ctrl val) <- + Just $ ChannelMsg.messageBody msg + return (ctrl, val) + + pitchBend chan msg = do + guard (ChannelMsg.messageChannel msg == chan) + ChannelMsg.Voice (VoiceMsg.PitchBend bend) <- + Just $ ChannelMsg.messageBody msg + return bend + + channelPressure chan msg = do + guard (ChannelMsg.messageChannel msg == chan) + ChannelMsg.Voice (VoiceMsg.MonoAftertouch pressure) <- + Just $ ChannelMsg.messageBody msg + return pressure + + mode chan msg = do + guard (ChannelMsg.messageChannel msg == chan) + ChannelMsg.Mode m <- + Just $ ChannelMsg.messageBody msg + return m + + +liftMidi :: + (Channel -> ChannelMsg.T -> Maybe a) -> + (Channel -> MidiMsg.T -> Maybe a) +liftMidi checkMsg chan msg = + case msg of + MidiMsg.Channel chanMsg -> checkMsg chan chanMsg + _ -> Nothing + +instance C MidiMsg.T where + note = liftMidi note + program = liftMidi program + anyController = liftMidi anyController + pitchBend = liftMidi pitchBend + channelPressure = liftMidi channelPressure + mode = liftMidi mode