diff --git a/midi.cabal b/midi.cabal --- a/midi.cabal +++ b/midi.cabal @@ -1,5 +1,5 @@ Name: midi -Version: 0.1.7.1 +Version: 0.2 License: GPL License-File: LICENSE Author: Henning Thielemann @@ -30,7 +30,7 @@ Source-Repository this type: darcs location: http://code.haskell.org/~thielema/midi/ - tag: 0.1.7.1 + tag: 0.2 Flag splitBase description: Choose the new smaller, split-up base package. @@ -46,7 +46,7 @@ explicit-exception >=0.1 && <0.2, bytestring >=0.9.0.1 && <0.10, binary >=0.4.2 && <0.6, - transformers >=0.2 && <0.3, + transformers >=0.2 && <0.4, monoid-transformer >=0.0.1 && <0.1, QuickCheck >=1 && <3 If flag(splitBase) @@ -76,8 +76,10 @@ Sound.MIDI.Message.System.Common Sound.MIDI.Message.System.RealTime Sound.MIDI.Message.Class.Check + Sound.MIDI.Message.Class.Query Sound.MIDI.Controller Sound.MIDI.Manufacturer + Sound.MIDI.KeySignature Sound.MIDI.General -- exports ByteList data type Sound.MIDI.IO 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 @@ -142,7 +142,7 @@ EventList.T NonNegW.Rational Event.T secondsFromTicks division = EventList.catMaybes . - flip MS.evalState MetaEvent.defltST . + flip MS.evalState MetaEvent.defltTempo . EventList.mapM (\ticks -> do microsPerQN <- MS.get 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 @@ -1,19 +1,20 @@ module Sound.MIDI.File.Event.Meta ( T(..), - Key(..), Scale(..), ElapsedTime, fromElapsedTime, toElapsedTime, Tempo, fromTempo, toTempo, + defltTempo, SMPTEHours, SMPTEMinutes, SMPTESeconds, SMPTEFrames, SMPTEBits, - defltST, defltDurT, get, put, ) where import Sound.MIDI.Message.Channel (Channel, toChannel, fromChannel, ) -import Sound.MIDI.Parser.Primitive +import qualified Sound.MIDI.KeySignature as KeySig + +import Sound.MIDI.Parser.Primitive (get1, get2, get3, getVar, getBigN, ) import qualified Sound.MIDI.Parser.Class as Parser import qualified Sound.MIDI.Parser.Restricted as ParserRestricted -import Control.Monad (liftM, liftM2, liftM4, liftM5, ) +import Control.Monad (liftM, liftM4, liftM5, ) import qualified Sound.MIDI.Writer.Basic as Writer import qualified Sound.MIDI.Bit as Bit @@ -23,14 +24,11 @@ import qualified Numeric.NonNegative.Wrapper as NonNeg import Sound.MIDI.IO (ByteList, listCharFromByte, listByteFromChar, ) -import Data.Ix (Ix, index, ) import Sound.MIDI.Utility - (arbitraryString, arbitraryByteList, - enumRandomR, boundedEnumRandom, chooseEnum, ) + (arbitraryString, arbitraryByteList, ) import Test.QuickCheck (Arbitrary(arbitrary), ) import qualified Test.QuickCheck as QC -import System.Random (Random(random, randomR), ) import Prelude hiding (putStr, ) @@ -59,7 +57,7 @@ | SetTempo Tempo | SMPTEOffset SMPTEHours SMPTEMinutes SMPTESeconds SMPTEFrames SMPTEBits | TimeSig Int Int Int Int - | KeySig Key Scale + | KeySig KeySig.T | SequencerSpecific ByteList | Unknown Int ByteList deriving (Show, Eq, Ord) @@ -81,7 +79,7 @@ liftM (SetTempo . NonNeg.fromNumberMsg "Tempo always positive") (QC.choose (0,0xFFFFFF)) : liftM5 SMPTEOffset arbitraryByte arbitraryByte arbitraryByte arbitraryByte arbitraryByte : liftM4 TimeSig arbitraryByte arbitraryByte arbitraryByte arbitraryByte : - liftM2 KeySig arbitrary arbitrary : + liftM KeySig arbitrary : liftM SequencerSpecific arbitraryByteList : -- liftM Unknown arbitrary arbitraryByteList : [] @@ -90,57 +88,6 @@ arbitraryByte = QC.choose (0,0xFF::Int) -{- | -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, Bounded) - - -instance Random Key where - random = boundedEnumRandom - randomR = enumRandomR - -instance Arbitrary Key where - arbitrary = chooseEnum - - - -{- | -The Key Signature specifies a mode, either major or minor. --} -data Scale = Major | Minor - deriving (Show, Eq, Ord, Ix, Enum, Bounded) - - -instance Random Scale where - random = boundedEnumRandom - randomR = enumRandomR - -instance Arbitrary Scale where - arbitrary = chooseEnum - - - -{- | -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) - - toElapsedTime :: Integer -> ElapsedTime toElapsedTime = NonNeg.fromNumberMsg "toElapsedTime" @@ -154,8 +101,15 @@ fromTempo :: Tempo -> Int fromTempo = NonNeg.toNumber +{- | +The default SetTempo value, in microseconds per quarter note. +This expresses the default of 120 beats per minute. +-} +defltTempo :: Tempo +defltTempo = 500000 + -- * serialization get :: Parser.C parser => Parser.Fallible parser T @@ -193,21 +147,13 @@ b <- get1 return (TimeSig n d c b) - 089 -> parse $ - do - sf <- get1 - sc <- getEnum - return (KeySig (toKeyName sf) sc) + 089 -> parse $ liftM KeySig KeySig.get 127 -> liftM SequencerSpecific $ getBigN len _ -> liftM (Unknown code) $ getBigN len -toKeyName :: Int -> Key -toKeyName sf = toEnum (mod (sf+7) 15) - - put :: Writer.C writer => T -> writer put ev = Writer.putByte 255 +#+ @@ -227,11 +173,7 @@ SMPTEOffset hr mn se fr ff -> putList 84 [hr,mn,se,fr,ff] TimeSig n d c b -> putList 88 [n,d,c,b] - KeySig sf mi -> putList 89 [sf', fromEnum mi] - where k = index (KeyCf,KeyCs) sf - 7 - sf' = if k >= 0 - then k - else 255+k + KeySig key -> putList 89 $ KeySig.toBytes key SequencerSpecific codes -> putByteList 127 codes Unknown typ s -> putByteList typ s diff --git a/src/Sound/MIDI/KeySignature.hs b/src/Sound/MIDI/KeySignature.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/KeySignature.hs @@ -0,0 +1,183 @@ +module Sound.MIDI.KeySignature ( + T(..), + Accidentals(..), Mode(..), keyName, + + cfMajor, gfMajor, dfMajor, afMajor, efMajor, + bfMajor, fMajor, cMajor, gMajor, dMajor, aMajor, + eMajor, bMajor, fsMajor, csMajor, + afMinor, efMinor, bfMinor, fMinor, cMinor, + gMinor, dMinor, aMinor, eMinor, bMinor, fsMinor, + csMinor, gsMinor, dsMinor, asMinor, + + get, toBytes, ) where + +import Sound.MIDI.Parser.Primitive (getByte, getEnum, makeEnum, ) +import qualified Sound.MIDI.Parser.Class as Parser + +import Control.Monad (liftM2, ) + +import Data.Ix (Ix, inRange, ) +import Sound.MIDI.Utility + (enumRandomR, boundedEnumRandom, chooseEnum, checkRange, ) + +import Test.QuickCheck (Arbitrary(arbitrary), ) +import qualified Test.QuickCheck as QC +import System.Random (Random(random, randomR), ) + +import Data.Int (Int8, ) + +import Prelude hiding (putStr, ) + + + +data T = Cons Mode Accidentals + deriving (Eq, Ord) + +instance Show T where + showsPrec p (Cons mode accs) = + if inRange (minBound, maxBound) accs + then showString "KeySig." . + showString (keyName mode accs) . shows mode + else showParen (p>10) $ + showString "KeySig.Cons " . shows mode . + showString " " . showsPrec 11 accs + +instance Arbitrary T where + arbitrary = liftM2 Cons arbitrary arbitrary + +{- | +The Key Signature specifies a mode, either major or minor. +-} +data Mode = Major | Minor + deriving (Show, Eq, Ord, Ix, Enum, Bounded) + + +instance Random Mode where + random = boundedEnumRandom + randomR = enumRandomR + +instance Arbitrary Mode where + arbitrary = chooseEnum + + + + + +keyName :: Mode -> Accidentals -> String + +keyName Major (Accidentals (-7)) = "cf" +keyName Major (Accidentals (-6)) = "gf" +keyName Major (Accidentals (-5)) = "df" +keyName Major (Accidentals (-4)) = "af" +keyName Major (Accidentals (-3)) = "ef" +keyName Major (Accidentals (-2)) = "bf" +keyName Major (Accidentals (-1)) = "f" +keyName Major (Accidentals 0) = "c" +keyName Major (Accidentals 1) = "g" +keyName Major (Accidentals 2) = "d" +keyName Major (Accidentals 3) = "a" +keyName Major (Accidentals 4) = "e" +keyName Major (Accidentals 5) = "b" +keyName Major (Accidentals 6) = "fs" +keyName Major (Accidentals 7) = "cs" + +keyName Minor (Accidentals (-7)) = "af" +keyName Minor (Accidentals (-6)) = "ef" +keyName Minor (Accidentals (-5)) = "bf" +keyName Minor (Accidentals (-4)) = "f" +keyName Minor (Accidentals (-3)) = "c" +keyName Minor (Accidentals (-2)) = "g" +keyName Minor (Accidentals (-1)) = "d" +keyName Minor (Accidentals 0) = "a" +keyName Minor (Accidentals 1) = "e" +keyName Minor (Accidentals 2) = "b" +keyName Minor (Accidentals 3) = "fs" +keyName Minor (Accidentals 4) = "cs" +keyName Minor (Accidentals 5) = "gs" +keyName Minor (Accidentals 6) = "ds" +keyName Minor (Accidentals 7) = "as" + +keyName _ (Accidentals n) = + if n<0 + then show (-n) ++ " flats" + else show n ++ " sharps" + + +{- | +Accidentals as used in key signature. +-} +newtype Accidentals = Accidentals Int + deriving (Show, Eq, Ord, Ix) + +instance Bounded Accidentals where + minBound = Accidentals (-7) + maxBound = Accidentals 7 + +instance Enum Accidentals where + fromEnum (Accidentals n) = fromIntegral n + toEnum = checkRange "Accidentals" (Accidentals . fromIntegral) + +instance Random Accidentals where + random = boundedEnumRandom + randomR = enumRandomR + +instance Arbitrary Accidentals where + arbitrary = chooseEnum + + + + +major, minor :: Accidentals -> T +major = Cons Major +minor = Cons Minor + +cfMajor, gfMajor, dfMajor, afMajor, efMajor, + bfMajor, fMajor, cMajor, gMajor, dMajor, aMajor, + eMajor, bMajor, fsMajor, csMajor :: T + +afMinor, efMinor, bfMinor, fMinor, cMinor, + gMinor, dMinor, aMinor, eMinor, bMinor, fsMinor, + csMinor, gsMinor, dsMinor, asMinor :: T + +cfMajor = major (Accidentals (-7)) +gfMajor = major (Accidentals (-6)) +dfMajor = major (Accidentals (-5)) +afMajor = major (Accidentals (-4)) +efMajor = major (Accidentals (-3)) +bfMajor = major (Accidentals (-2)) +fMajor = major (Accidentals (-1)) +cMajor = major (Accidentals 0) +gMajor = major (Accidentals 1) +dMajor = major (Accidentals 2) +aMajor = major (Accidentals 3) +eMajor = major (Accidentals 4) +bMajor = major (Accidentals 5) +fsMajor = major (Accidentals 6) +csMajor = major (Accidentals 7) + +afMinor = minor (Accidentals (-7)) +efMinor = minor (Accidentals (-6)) +bfMinor = minor (Accidentals (-5)) +fMinor = minor (Accidentals (-4)) +cMinor = minor (Accidentals (-3)) +gMinor = minor (Accidentals (-2)) +dMinor = minor (Accidentals (-1)) +aMinor = minor (Accidentals 0) +eMinor = minor (Accidentals 1) +bMinor = minor (Accidentals 2) +fsMinor = minor (Accidentals 3) +csMinor = minor (Accidentals 4) +gsMinor = minor (Accidentals 5) +dsMinor = minor (Accidentals 6) +asMinor = minor (Accidentals 7) + + +get :: (Parser.C parser) => Parser.Fallible parser T +get = liftM2 (flip Cons) getAccidentals getEnum + +getAccidentals :: (Parser.C parser) => Parser.Fallible parser Accidentals +getAccidentals = + makeEnum . fromIntegral . (id :: Int8 -> Int8) . fromIntegral =<< getByte + +toBytes :: T -> [Int] +toBytes (Cons mi sf) = [fromEnum sf, fromEnum mi] diff --git a/src/Sound/MIDI/Message/Channel/Voice.hs b/src/Sound/MIDI/Message/Channel/Voice.hs --- a/src/Sound/MIDI/Message/Channel/Voice.hs +++ b/src/Sound/MIDI/Message/Channel/Voice.hs @@ -6,7 +6,7 @@ ControllerValue, PitchBendRange, Pressure, isNote, isNoteOn, isNoteOff, zeroKey, explicitNoteOff, implicitNoteOff, - toFloatController, + realFromControllerValue, bankSelect, modulation, breathControl, footControl, portamentoTime, dataEntry, mainVolume, balance, panorama, expression, @@ -35,7 +35,7 @@ CtrlP.Controller, CtrlP.fromController, CtrlP.toController, increasePitch, subtractPitch, frequencyFromPitch, - maximumVelocity, normalVelocity, toFloatVelocity, + maximumVelocity, normalVelocity, realFromVelocity, ) where import qualified Sound.MIDI.ControllerPrivate as CtrlP @@ -223,6 +223,14 @@ minBound = Pitch 0 maxBound = Pitch 127 +{- | +ToDo: +We have defined minBound = Velocity 0, +but strictly spoken the minimum Velocity is 1, +since Velocity zero means NoteOff. +One can at least think of NoteOff with (Velocity 0), +but I have never seen that. +-} instance Bounded Velocity where minBound = Velocity 0 maxBound = Velocity 127 @@ -249,33 +257,28 @@ {- | The velocity of an ordinary key stroke and the maximum possible velocity. - -ToDo: -This should be of type Velocity. -} -normalVelocity, maximumVelocity :: Num quant => quant - -- Velocity -normalVelocity = 64 -maximumVelocity = 127 +normalVelocity, maximumVelocity :: Velocity +normalVelocity = Velocity 64 +maximumVelocity = maxBound {- | -64 is given as default value by the MIDI specification -and thus we map it to 1. -0 is mapped to 0. -All other values are interpolated linearly. - -ToDo: MIDI specification says, if velocity is simply mapped to amplitude, then this should be done by an exponential function. -Thus we should be better map 'normalVelocity' to 0, -'maximumVelocity' to 1, -and 'minimumVelocity' to -1. +Thus we map 'normalVelocity' (64) to 0, +'maximumVelocity' (127) to 1, +and 'minimumVelocity' (1) to -1. +That is, normally you should write something like +@amplitude = 2 ** realFromVelocity vel@ or @3 ** realFromVelocity vel@. -} -toFloatVelocity :: (Integral a, Fractional b) => a -> b -toFloatVelocity x = fromIntegral x / normalVelocity +realFromVelocity :: (Fractional b) => Velocity -> b +realFromVelocity (Velocity x) = + fromIntegral (x - fromVelocity normalVelocity) / + fromIntegral (fromVelocity maximumVelocity - fromVelocity normalVelocity) -maximumControllerValue :: Num quant => quant + +maximumControllerValue :: Num a => a maximumControllerValue = 127 {- | @@ -283,8 +286,8 @@ Maximum integral MIDI controller value 127 is mapped to 1. Minimum integral MIDI controller value 0 is mapped to 0. -} -toFloatController :: (Integral a, Fractional b) => a -> b -toFloatController x = fromIntegral x / maximumControllerValue +realFromControllerValue :: (Integral a, Fractional b) => a -> b +realFromControllerValue x = fromIntegral x / maximumControllerValue diff --git a/src/Sound/MIDI/Message/Class/Check.hs b/src/Sound/MIDI/Message/Class/Check.hs --- a/src/Sound/MIDI/Message/Class/Check.hs +++ b/src/Sound/MIDI/Message/Class/Check.hs @@ -11,6 +11,15 @@ import Control.Monad (guard, ) +{- | +All methods have default implementations that return 'Nothing'. +This helps implementing event data types +that support only a subset of types of events. + +Maybe a better approach is to provide type classes +for every type of event +and make 'C' a subclass of all of them. +-} class C event where note :: Channel -> event -> Maybe (Velocity, Pitch, Bool) program :: Channel -> event -> Maybe Program @@ -18,6 +27,14 @@ pitchBend :: Channel -> event -> Maybe Int channelPressure :: Channel -> event -> Maybe Int mode :: Channel -> event -> Maybe Mode.T + + note _chan _ev = Nothing + program _chan _ev = Nothing + anyController _chan _ev = Nothing + pitchBend _chan _ev = Nothing + channelPressure _chan _ev = Nothing + mode _chan _ev = Nothing + controller :: (C event) => diff --git a/src/Sound/MIDI/Message/Class/Query.hs b/src/Sound/MIDI/Message/Class/Query.hs new file mode 100644 --- /dev/null +++ b/src/Sound/MIDI/Message/Class/Query.hs @@ -0,0 +1,86 @@ +module Sound.MIDI.Message.Class.Query 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 + + +{- | +All methods have default implementations that return 'Nothing'. +This helps implementing event data types +that support only a subset of types of events. + +Maybe a better approach is to provide type classes +for every type of event +and make 'C' a subclass of all of them. +-} +class C event where + note :: event -> Maybe (Channel, (Velocity, Pitch, Bool)) + program :: event -> Maybe (Channel, Program) + anyController :: event -> Maybe (Channel, (Controller, Int)) + pitchBend :: event -> Maybe (Channel, Int) + channelPressure :: event -> Maybe (Channel, Int) + mode :: event -> Maybe (Channel, Mode.T) + + note _ev = Nothing + program _ev = Nothing + anyController _ev = Nothing + pitchBend _ev = Nothing + channelPressure _ev = Nothing + mode _ev = Nothing + + +instance C ChannelMsg.T where + note msg = do + ChannelMsg.Voice voice <- Just $ ChannelMsg.messageBody msg + fmap ((,) (ChannelMsg.messageChannel msg)) $ + case voice of + VoiceMsg.NoteOn pitch velocity -> Just (velocity, pitch, True) + VoiceMsg.NoteOff pitch velocity -> Just (velocity, pitch, False) + _ -> Nothing + + program msg = do + ChannelMsg.Voice (VoiceMsg.ProgramChange pgm) <- + Just $ ChannelMsg.messageBody msg + return (ChannelMsg.messageChannel msg, pgm) + + anyController msg = do + ChannelMsg.Voice (VoiceMsg.Control ctrl val) <- + Just $ ChannelMsg.messageBody msg + return (ChannelMsg.messageChannel msg, (ctrl, val)) + + pitchBend msg = do + ChannelMsg.Voice (VoiceMsg.PitchBend bend) <- + Just $ ChannelMsg.messageBody msg + return (ChannelMsg.messageChannel msg, bend) + + channelPressure msg = do + ChannelMsg.Voice (VoiceMsg.MonoAftertouch pressure) <- + Just $ ChannelMsg.messageBody msg + return (ChannelMsg.messageChannel msg, pressure) + + mode msg = do + ChannelMsg.Mode m <- + Just $ ChannelMsg.messageBody msg + return (ChannelMsg.messageChannel msg, m) + + +liftMidi :: + (ChannelMsg.T -> Maybe (Channel, a)) -> + (MidiMsg.T -> Maybe (Channel, a)) +liftMidi checkMsg msg = + case msg of + MidiMsg.Channel chanMsg -> checkMsg 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 diff --git a/src/Sound/MIDI/Parser/File.hs b/src/Sound/MIDI/Parser/File.hs --- a/src/Sound/MIDI/Parser/File.hs +++ b/src/Sound/MIDI/Parser/File.hs @@ -63,10 +63,13 @@ fromIO :: (IO.Handle -> IO a) -> T a fromIO act = Cons $ lift . act =<< ask +ioeTry :: IO a -> IO (Either IOError a) +ioeTry = Exc.try + fallibleFromIO :: (IO.Handle -> IO a) -> Parser.Fallible T a fallibleFromIO act = Sync.ExceptionalT . Cons . lift . - fmap (Sync.mapException show . Sync.fromEither) . IOE.try . act + fmap (Sync.mapException show . Sync.fromEither) . ioeTry . act =<< lift (Cons ask) instance Parser.EndCheck T where