module Sound.MIDI.File.Event.Meta ( T(..), Key(..), Scale(..), ElapsedTime, fromElapsedTime, toElapsedTime, Tempo, fromTempo, toTempo, 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.Parser.Class as Parser import qualified Sound.MIDI.Parser.Restricted as ParserRestricted import Control.Monad (liftM, liftM2, liftM4, liftM5, ) import qualified Sound.MIDI.Writer.Basic as Writer import qualified Sound.MIDI.Bit as Bit 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, ) import Test.QuickCheck (Arbitrary(arbitrary), ) import qualified Test.QuickCheck as QC import System.Random (Random(random, randomR), ) import Prelude hiding (putStr, ) {- * Meta Events -} type ElapsedTime = NonNeg.Integer type Tempo = NonNeg.Int type SMPTEHours = Int type SMPTEMinutes = Int type SMPTESeconds = Int type SMPTEFrames = Int type SMPTEBits = Int data T = SequenceNum Int | TextEvent String | Copyright String | TrackName String | InstrumentName String | Lyric String | Marker String | CuePoint String | MIDIPrefix Channel | EndOfTrack | SetTempo Tempo | SMPTEOffset SMPTEHours SMPTEMinutes SMPTESeconds SMPTEFrames SMPTEBits | TimeSig Int Int Int Int | KeySig Key Scale | SequencerSpecific ByteList | Unknown Int ByteList deriving (Show, Eq, Ord) instance Arbitrary T where arbitrary = QC.oneof $ liftM SequenceNum (QC.choose (0,0xFFFF)) : liftM TextEvent arbitraryString : liftM Copyright arbitraryString : liftM TrackName arbitraryString : liftM InstrumentName arbitraryString : liftM Lyric arbitraryString : liftM Marker arbitraryString : liftM CuePoint arbitraryString : liftM (MIDIPrefix . toChannel) (QC.choose (0,15)) : -- return EndOfTrack : 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 SequencerSpecific arbitraryByteList : -- liftM Unknown arbitrary arbitraryByteList : [] coarbitrary = error "not implemented" arbitraryByte :: QC.Gen Int 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 coarbitrary = error "not implemented" {- | 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 coarbitrary = error "not implemented" {- | 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) toElapsedTime :: Integer -> ElapsedTime toElapsedTime = NonNeg.fromNumberMsg "toElapsedTime" fromElapsedTime :: ElapsedTime -> Integer fromElapsedTime = NonNeg.toNumber toTempo :: Int -> Tempo toTempo = NonNeg.fromNumberMsg "toTempo" fromTempo :: Tempo -> Int fromTempo = NonNeg.toNumber -- * serialization get :: Parser.C parser => Parser.Fallible parser T get = do code <- get1 len <- getVar let parse = ParserRestricted.runFallible len let returnText cons = liftM (cons . listCharFromByte) $ getBigN len case code of 000 -> parse $ liftM SequenceNum get2 001 -> returnText TextEvent 002 -> returnText Copyright 003 -> returnText TrackName 004 -> returnText InstrumentName 005 -> returnText Lyric 006 -> returnText Marker 007 -> returnText CuePoint 032 -> parse $ liftM (MIDIPrefix . toChannel) get1 047 -> return EndOfTrack 081 -> parse $ liftM (SetTempo . toTempo) get3 084 -> parse $ do {hrs <- get1 ; mins <- get1 ; secs <- get1; frames <- get1 ; bits <- get1 ; return (SMPTEOffset hrs mins secs frames bits)} 088 -> parse $ do n <- get1 d <- get1 c <- get1 b <- get1 return (TimeSig n d c b) 089 -> parse $ do sf <- get1 sc <- getEnum return (KeySig (toKeyName sf) sc) 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 >> case ev of SequenceNum num -> putInt 0 2 num TextEvent s -> putStr 1 s Copyright s -> putStr 2 s TrackName s -> putStr 3 s InstrumentName s -> putStr 4 s Lyric s -> putStr 5 s Marker s -> putStr 6 s CuePoint s -> putStr 7 s MIDIPrefix c -> putList 32 [fromChannel c] EndOfTrack -> putList 47 [] SetTempo tp -> putInt 81 3 (fromTempo tp) 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 SequencerSpecific codes -> putByteList 127 codes Unknown typ s -> putByteList typ s putByteList :: Writer.C writer => Int -> ByteList -> writer () putByteList code bytes = do Writer.putIntAsByte code Writer.putLenByteList bytes putInt :: Writer.C writer => Int -> Int -> Int -> writer () putInt code numBytes x = do Writer.putIntAsByte code Writer.putVar $ fromIntegral numBytes Writer.putByteList $ map fromIntegral $ Bit.someBytes numBytes x putStr :: Writer.C writer => Int -> String -> writer () putStr code = putByteList code . listByteFromChar putList :: Writer.C writer => Int -> [Int] -> writer () putList code = putByteList code . map fromIntegral