zmidi-score (empty) → 0.3.0.0
raw patch · 15 files changed
+1603/−0 lines, 15 filesdep +aesondep +basedep +binarysetup-changed
Dependencies added: aeson, base, binary, containers, data-ordlist, deepseq, deepseq-generics, directory, filepath, mtl, parallel-io, text, zmidi-core
Files
- CHANGELOG.md +2/−0
- LICENSE +165/−0
- README.md +6/−0
- Setup.hs +2/−0
- src/ZMidi/IO/Common.hs +161/−0
- src/ZMidi/Score.hs +27/−0
- src/ZMidi/Score/BarBeatPos.hs +74/−0
- src/ZMidi/Score/Datatypes.hs +296/−0
- src/ZMidi/Score/Internal.hs +19/−0
- src/ZMidi/Score/Quantise.hs +243/−0
- src/ZMidi/Score/Show.hs +82/−0
- src/ZMidi/Score/ToMidiFile.hs +91/−0
- src/ZMidi/Score/ToMidiScore.hs +174/−0
- src/ZMidi/Score/Utilities.hs +210/−0
- zmidi-score.cabal +51/−0
+ CHANGELOG.md view
@@ -0,0 +1,2 @@+### Changelog +0.3 Initial released version (versions 0.1 and 0.2 were kept internal)
+ LICENSE view
@@ -0,0 +1,165 @@+ GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/> + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library.
+ README.md view
@@ -0,0 +1,6 @@+### Representing a MidiFile as a musical score + +This library was designed to be able to statistically analyse large corpora +of MIDI files. The library is based on the ZMidi.Core library: +https://hackage.haskell.org/package/zmidi-core +
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ src/ZMidi/IO/Common.hs view
@@ -0,0 +1,161 @@+{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE TupleSections #-} +-- | +-- Module : ZMidi.IO.Common +-- Copyright : (c) 2012--2014, Utrecht University +-- License : LGPL-3 +-- +-- Maintainer : W. Bas de Haas <w.b.dehaas@uu.nl> +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Some common IO utilities +module ZMidi.IO.Common (-- * Mapping + mapDirInDir + , mapDir + , mapDir_ + -- * Folding + , foldrDirInDir + , foldrDir + -- * Reading and Writing + , readMidiFile + , readMidiScoreSafe + , readQMidiScoreSafe + , readMidiScore + , readQMidiScore + , writeMidiScore + -- * Utilities + , logDuplicates + , removeTrackLabels + , putErrStrLn + , warning + )where + +import ZMidi.Core ( MidiFile (..), readMidi, writeMidi ) +import ZMidi.Score ( MidiScore (..), midiFileToMidiScore + , midiScoreToMidiFile, removeLabels, QMidiScore (..) + , quantiseQDevSafe, quantise ) +import Control.Monad ( filterM, void ) +import System.Directory ( getDirectoryContents, canonicalizePath + , doesDirectoryExist ) +import System.IO ( stderr, hPutStrLn ) +import System.FilePath ( (</>) ) +import Data.Foldable ( foldrM ) +import Data.List ( sort ) +import Control.Concurrent.ParallelIO.Global ( parallel ) + +-------------------------------------------------------------------------------- +-- Mapping +-------------------------------------------------------------------------------- + +-- | Applies a function to every directory inside a specific directory +mapDirInDir :: (FilePath -> IO a) -> FilePath -> IO [a] +mapDirInDir f fp = do fs <- getDirectoryContents fp + >>= return . filter (\x -> x /= "." && x /= "..") + cfp <- canonicalizePath fp + filterM doesDirectoryExist (fmap (cfp </>) fs) >>= mapM f + +-- | Applies a function to every file/dir in a directory, similar to 'mapDir', +-- but it discards the result of the evaluation +mapDir_ :: (FilePath -> IO a) -> FilePath -> IO () +mapDir_ f = void . mapDir f + +-- | Applies a function to every file/dir in a directory +mapDir :: (FilePath -> IO a) -> FilePath -> IO [a] +mapDir f fp = do fs <- getCurDirectoryContents fp + cin <- canonicalizePath fp + -- putErrStrLn cin + res <- parallel . map (f . (cin </>)) $ fs + return res + +-- | Folds a function to every directory inside a specific directory +foldrDirInDir :: (FilePath -> b -> IO b) -> b -> FilePath -> IO b +foldrDirInDir f b fp = + do fs <- getDirectoryContents fp + >>= return . filter (\x -> x /= "." && x /= "..") + cfp <- canonicalizePath fp + filterM doesDirectoryExist (fmap (cfp </>) fs) >>= foldrM f b + +-- | Folds a function to every file/dir in a directory +foldrDir :: (FilePath -> b -> IO b) -> b -> FilePath -> IO b +foldrDir f b fp = do fs <- getCurDirectoryContents fp + cin <- canonicalizePath fp + putErrStrLn cin + foldrM (\x y -> f (cin </> x) $! y) b fs + +-------------------------------------------------------------------------------- +-- Reading & Writing +-------------------------------------------------------------------------------- + +-- | Reads a 'MidiFile' using 'readMidiScoreSafe', 'quantise'es the result +-- and checks if the 'MidiScore' has a reasonable average quantisation deviation +-- (see 'QDevPerc') +readQMidiScoreSafe :: FilePath -> IO (Either String QMidiScore) +readQMidiScoreSafe f = readMidiScoreSafe f >>= return . (>>= quantiseQDevSafe) + +-- | Reads a 'MidiFile' converts it into a 'MidiScore' and checks if the +-- 'MidiScore' has a reasonable average quantisation deviation (see 'QDevPerc') +readMidiScoreSafe :: FilePath -> IO (Either String MidiScore) +readMidiScoreSafe f = readMidi f >>= return . either (Left . show) + (Right . midiFileToMidiScore) +-- TODO: maybe solved with an arrow in a nicer way + +-- | Reads a 'MidiFile' using 'readMidiScore' but 'quantise'es the result. +readQMidiScore :: FilePath -> IO (QMidiScore) +readQMidiScore f = readMidiScore f >>= return . quantise + +-- | Reads a 'MidiFile' converts it into a 'MidiScore' and returns it +readMidiScore :: FilePath -> IO (MidiScore) +readMidiScore f = readMidiFile f >>= return . midiFileToMidiScore + +-- | Reads a 'MidiFile' +readMidiFile :: FilePath -> IO (MidiFile) +readMidiFile f = readMidi f >>= return . either (error . show) id + +-- | Writes a 'MidiScore' to a file. +writeMidiScore :: MidiScore -> FilePath -> IO () +writeMidiScore mf f = writeMidi f . midiScoreToMidiFile $ mf + + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +-- | Reads all midifiles at a specific location and compares all files to +-- all files, printing the paths of the files with the same MIDI content +-- to the user +logDuplicates :: FilePath -> IO () +logDuplicates fp = do midis <- getCurDirectoryContents fp + >>= mapM (return . (fp </>)) + >>= mapM (\x -> readMidiFile x >>= return . (x,)) + mapM_ (checkFile midis) midis where + + -- Prints if the paths differ, but the midi content is identical. + checkFile :: [(FilePath, MidiFile)] -> (FilePath, MidiFile) -> IO () + checkFile midis (f, mf) = case filter (\(x,y) -> x /= f && y == mf) midis of + [] -> return () + l -> mapM_ (\(m,_) -> putStrLn (f ++ " == " ++ m)) l + +-- | Removes the Track labels from a 'MidiFile' +removeTrackLabels :: FilePath -> IO () +removeTrackLabels f = readMidiFile f >>= + writeMidi (f ++ ".noLab.mid") . removeLabels + +-- | Sends a warning about a file that cannot be read to the stderr +warning :: FilePath -> String -> IO () +warning fp w = putErrStrLn ("Warning: skipping " ++ fp ++ ": " ++ w) + +-- | Prints a string to the standard error stream +putErrStrLn :: String -> IO () +putErrStrLn s = hPutStrLn stderr s + + +-------------------------------------------------------------------------------- +-- Unexported directory utils +-------------------------------------------------------------------------------- + +-- | Like 'getCurDirectoryContents', but filters the results for "." and ".." +getCurDirectoryContents :: FilePath -> IO [FilePath] +getCurDirectoryContents fp = + getDirectoryContents fp >>= return . sort . filter (\x -> x /= "." && x /= "..") +
+ src/ZMidi/Score.hs view
@@ -0,0 +1,27 @@+-- | +-- Module : ZMidi.Score +-- Copyright : (c) 2012--2014, Utrecht University +-- License : LGPL-3 +-- +-- Maintainer : W. Bas de Haas <w.b.dehaas@uu.nl> +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: this module exports all modules inside ZMidi.Score +module ZMidi.Score + ( module ZMidi.Score.Datatypes + , module ZMidi.Score.ToMidiScore + , module ZMidi.Score.ToMidiFile + , module ZMidi.Score.Quantise + , module ZMidi.Score.BarBeatPos + , module ZMidi.Score.Utilities + , module ZMidi.Score.Show + ) where + +import ZMidi.Score.Datatypes +import ZMidi.Score.ToMidiScore +import ZMidi.Score.ToMidiFile +import ZMidi.Score.Quantise +import ZMidi.Score.BarBeatPos +import ZMidi.Score.Utilities +import ZMidi.Score.Show
+ src/ZMidi/Score/BarBeatPos.hs view
@@ -0,0 +1,74 @@+-- | +-- Module : ZMidi.Score.BarBeatPos +-- Copyright : (c) 2012--2014, Utrecht University +-- License : LGPL-3 +-- +-- Maintainer : W. Bas de Haas <w.b.dehaas@uu.nl> +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Functions for representing MIDI time musically. +module ZMidi.Score.BarBeatPos ( getBeatInBar + , getBarRat + , toRatInBeat + , toBarRat + ) where + +import ZMidi.Score.Datatypes +import ZMidi.Score.Quantise + +import Control.Arrow ( (***) ) +import Data.Ratio ( (%) ) + +-------------------------------------------------------------------------------- +-- Bar & Beat position +-------------------------------------------------------------------------------- + +-- NOTE: It is probably a good idea use a BarRat internally instead of a +-- (Beat, BeatRat) because this makes rotations much more intuitive. + +-- | Within a 'MidiScore' we can musically describe every (quantised) +-- position in time in 'Bar', Beat, and 'BarRat'. Therefore, we need the +-- 'TimeSig'nature, the length of a beat ('TPB', in ticks), and the actual +-- 'Time' stamp. +getBeatInBar :: TimeSig -> TPB -> Time -> (Bar, Beat, BeatRat) +getBeatInBar NoTimeSig _ _ = error "getBeatInBar applied to noTimeSig" +getBeatInBar (TimeSig num _den _ _) t o = + let (Beat bt, rat) = getRatInBeat t o + (br, bib) = (succ *** succ) $ bt `divMod` num + in (Bar br, Beat bib, rat) + +-- | Returns the position within a 'Bar', see 'getBeatInBar'. +getRatInBeat :: TPB -> Time -> (Beat, BeatRat) +getRatInBeat (TPB t) (Time o) = + ((Beat) *** (BeatRat . (% t))) (o `divMod` t) + +-- | Similar to 'getBeatInBar' we can also describe the musical position as the +-- combination of a 'Bar' and a 'BarRat'. The latter denotes the ratio within +-- a bar, e.g. BarRat (3 % 4) denotes the 4th 'Beat' in the bar. +getBarRat :: TimeSig -> TPB -> Time -> (Bar, BarRat) +getBarRat NoTimeSig _ _ = error "getBeatInBar applied to noTimeSig" +getBarRat (TimeSig num den _ _) (TPB t) (Time o) = + let (bt, rest) = o `divMod` t + (b , bib) = bt `divMod` num + br = ((bib * t) + rest) % (den * t) + in (Bar (succ b), BarRat br) + +-- | toRatInBeat allows us to convert a 'BarRat' into a ('Beat','BeatRat') +toRatInBeat :: TimeSig -> BarRat -> (Beat, BeatRat) +toRatInBeat ts br = countBeat (Beat 0, BeatRat . barRat $ br) + + where oneBeat = BeatRat (1 % tsNum ts) :: BeatRat + + countBeat :: (Beat, BeatRat) -> (Beat, BeatRat) + countBeat (b,x) | rest < 0 = (b,x) + | otherwise = countBeat (succ b, rest) + where rest = x - oneBeat + +-- | Musically it is sometimes more intuitive to have a 'BarRat', i.e. the +-- onset is defined as the ratio within the bar. For example 1%4 denotes them +-- the position of the second quarter note within a 4/4 meter +toBarRat :: QBins -> TimeSig -> (Beat, BeatRat) -> BarRat +toBarRat _ NoTimeSig _ = error "toBarRat applied to noTimeSig" +toBarRat q@(QBins x) (TimeSig _n d _ _) (Beat b, BeatRat r) = + BarRat (((pred b * x) + getNumForQBins q r) % (x * d))
+ src/ZMidi/Score/Datatypes.hs view
@@ -0,0 +1,296 @@+{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +-- | +-- Module : ZMidi.Score.Datatypes +-- Copyright : (c) 2012--2014, Utrecht University +-- License : LGPL-3 +-- +-- Maintainer : W. Bas de Haas <w.b.dehaas@uu.nl> +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: a simple score representation derived from a MidiFile (as parsed +-- by the ZMidi.Core library: <https://hackage.haskell.org/package/zmidi-core> +module ZMidi.Score.Datatypes ( -- * Score representation of a MidiFile + MidiScore (..) + , Key (..) + , TimeSig (..) + , Voice + , Channel (..) + , Pitch (..) + , Octave (..) + , PitchClass (..) + , Interval (..) + , Velocity (..) + , Timed (..) + , Time (..) + , Bar (..) + , Beat (..) + , BeatRat (..) + , BarRat (..) + , TPB (..) + , ScoreEvent (..) + ) where + +import ZMidi.Score.Internal +import ZMidi.Core ( MidiFormat (..), MidiScaleType (..) ) +import Data.Ratio ( Ratio, numerator, denominator, (%) ) +import Data.Word ( Word8 ) +import Data.Int ( Int8 ) +import Data.Char ( toLower ) +import Text.Printf ( PrintfArg ) +import Data.Aeson ( ToJSON (..), FromJSON (..) + , (.=), (.:), Value (..), object) +import Data.Text ( pack ) +import Data.Binary ( Binary, Get ) +import qualified Data.Binary as B ( get, put ) +import GHC.Generics ( Generic ) +import Control.DeepSeq ( NFData (..) ) +import Control.DeepSeq.Generics ( genericRnf) +import Control.Applicative ( (<$>), (<*>) ) +import Control.Monad ( mzero ) + + +-------------------------------------------------------------------------------- +-- A less low-level MIDI data representation +-------------------------------------------------------------------------------- + +-- | Stores the main elements of a musical score that can be derived from a +-- midifile +data MidiScore = MidiScore { -- | The 'Key's of the piece with time stamps + getKey :: [Timed Key] + -- | The 'TimeSig'natures of the piece with time stamps + , getTimeSig :: [Timed TimeSig] + -- | The number of MIDI-ticks-per-beat + , ticksPerBeat :: TPB + -- | The kind of midi file that created this score + , midiFormat :: MidiFormat + -- | The microseconds per quarter note + , tempo :: [Timed Time] + -- | The minimum note length found. + , minDur :: Time + -- | The midi 'Voice's + , getVoices :: [Voice] + } deriving (Eq, Show, Generic) + +-- | Represents a musical key +data Key = Key { keyRoot :: Int8 + , keyMode :: MidiScaleType + } + | NoKey deriving (Eq, Ord, Generic) + +-- | A 'TimeSig'nature has a fraction, e.g. 4\/4, 3\/4, or 6\/8. +data TimeSig = TimeSig { tsNum :: Int + , tsDen :: Int + , metronome :: Word8 + , nr32ndNotes:: Word8 + } + | NoTimeSig deriving (Generic) + +-- Note: we could consider adding a Voice label, like there is a track label +-- | A 'Voice' is a list of 'ScoreEvent's that have time stamps. +type Voice = [Timed ScoreEvent] + +-- | The MIDI Channel as stored in the MIDI file +newtype Channel = Channel {channel :: Word8 } + deriving ( Eq, Show, Num, Ord, Enum, Real, Integral, Binary, NFData ) + +-- | Pitch is represented by a 'PitchClass' and an 'Octave' +newtype Pitch = Pitch ( Octave, PitchClass ) + deriving ( Eq, Ord, Binary, NFData, Generic ) + +-- | Represents a musical octave +newtype Octave = Octave { octave :: Int } + deriving ( Eq, Show, Num, Ord, Enum, Real, Integral, Binary, PrintfArg, NFData, Generic ) +-- | A Pitch class representation (there is no check for values > 11) +newtype PitchClass = PitchClass { pitchclass :: Int } + deriving ( Eq, Show, Num, Ord, Enum, Real, Integral, Binary, PrintfArg, NFData, Generic ) + +-- | Represents a musical interval +newtype Interval = Interval { interval :: Int } + deriving ( Eq, Show, Num, Ord, Enum, Real, Integral, Binary, PrintfArg, NFData, Generic ) + +-- | Represents MIDI velocity +newtype Velocity = Velocity { velocity :: Word8 } + deriving ( Eq, Show, Num, Ord, Enum, Real, Integral, Binary, NFData, Generic ) + +-- | Represents MIDI time in ticks +newtype Time = Time { time :: Int } + deriving ( Eq, Show, Num, Ord, Enum, Real, Integral, Binary, PrintfArg, NFData, Generic ) + +-- | A Bar counter used to interpret a MIDI 'Time' stamp +newtype Bar = Bar { bar :: Int } + deriving ( Eq, Show, Num, Ord, Enum, Real, Integral, Binary, PrintfArg, NFData, Generic ) + +-- | A counter for musical beats +newtype Beat = Beat { beat :: Int } + deriving ( Eq, Show, Num, Ord, Enum, Real, Integral, Binary, PrintfArg, NFData, Generic ) + +-- | Representing time within a 'Beat' as a 'Ratio' +newtype BeatRat = BeatRat { beatRat :: Ratio Int } + deriving ( Eq, Show, Num, Ord, Enum, Real, Binary, NFData, Generic ) + +-- | Representing time within a 'Bar' as a 'Ratio' +newtype BarRat = BarRat { barRat :: Ratio Int } + deriving ( Eq, Show, Num, Ord, Enum, Real, Binary, NFData, Generic ) + +-- | The MIDI ticks in 'Time' per 'Beat' +newtype TPB = TPB { tpb :: Int } + deriving ( Eq, Show, Num, Ord, Enum, Real, Integral, Binary, PrintfArg, NFData, Generic ) + +-- | Adds MIDI 'Time' information to a datatype +data Timed a = Timed { onset :: Time + , getEvent :: a + } deriving (Functor, Eq, Ord, Generic) + +-- | Within ZMidi.Score we represent four score events: a note, a key change, +-- a time signature or a tempo change +data ScoreEvent = NoteEvent { chan :: Channel + , pitch :: Pitch + , velo :: Velocity + -- No, this should this not be in Timed + -- because only a NoteEvent has a duration + -- (or we should give Key and TimeSig changes + -- also a duration) + , duration :: Time + } + | KeyChange { keyChange :: Key + } + | TimeSigChange { tsChange :: TimeSig + } + | TempoChange { tempChange :: Time + } deriving (Eq, Ord, Show, Generic) + + +-------------------------------------------------------------------------------- +-- Some ad-hoc instances +-------------------------------------------------------------------------------- + +instance Show a => Show (Timed a) where + show (Timed t a) = show a ++ " @ " ++ show (time t) + +instance Eq TimeSig where + (TimeSig a1 b1 _ _) == (TimeSig a2 b2 _ _) = a1 == a2 && b1 == b2 + NoTimeSig == NoTimeSig = True + _ == _ = False + +instance Ord TimeSig where + compare _ NoTimeSig = GT + compare NoTimeSig _ = LT + compare (TimeSig a1 b1 _ _) (TimeSig a2 b2 _ _) = + case compare b1 b2 of + EQ -> compare a1 a2 + c -> c + +instance Show TimeSig where + show (TimeSig n d _ _) = show n ++ '/' : show d + show NoTimeSig = "NoTimeSig" + +instance Read TimeSig where + readsPrec _ = error "Read TimeSig: implement me" + +instance Show Key where + show NoKey = "NoKey" + show (Key rt m) = showRoot rt ++ ' ' : (map toLower . show $ m) where + + showRoot :: Int8 -> String + showRoot i = let r = fromIntegral i in case compare r 0 of + LT -> replicate (abs r) 'b' + EQ -> "0" + GT -> replicate r '#' + +instance Show Pitch where + show (Pitch (oct, p)) = showOct oct ++ showPitch p where + + showOct :: Octave -> String + showOct (Octave i) | i < 0 = show i + | otherwise = ' ' : show i + +-- shows the Midi number in a musical way +-- N.B. ignoring all pitch spelling, at the moment +showPitch :: PitchClass -> String +showPitch p = case pitchclass p of + 0 -> "C " + 1 -> "C#" + 2 -> "D " + 3 -> "D#" + 4 -> "E " + 5 -> "F " + 6 -> "F#" + 7 -> "G " + 8 -> "G#" + 9 -> "A " + 10 -> "Bb" + 11 -> "B " + n -> invalidMidiNumberError n + +-- Binary instances +instance Binary MidiScore +instance Binary TimeSig +instance Binary ScoreEvent +instance Binary Key +instance (Binary a) => Binary (Timed a) +instance Binary MidiScaleType where + put MAJOR = B.put (0 :: Word8) + put MINOR = B.put (1 :: Word8) + put (SCALE_OTHER i) = do B.put (2 :: Word8) + B.put i + + get = do t <- B.get :: Get Word8 + case t of + 0 -> return MAJOR + 1 -> return MINOR + 2 -> do i <- B.get + return (SCALE_OTHER i) + _ -> error "invalid binary encoding of MidiScaleType" + +instance Binary MidiFormat where + put MF0 = B.put (0 :: Word8) + put MF1 = B.put (1 :: Word8) + put MF2 = B.put (2 :: Word8) + + get = do t <- B.get :: Get Word8 + case t of + 0 -> return MF0 + 1 -> return MF1 + 2 -> return MF2 + _ -> error "invalid binary encoding of MidiFormat" + +-- NFData instances +instance NFData MidiScore where rnf = genericRnf +instance NFData TimeSig where rnf = genericRnf +instance NFData ScoreEvent where rnf = genericRnf +instance NFData Key where rnf = genericRnf +instance NFData a => NFData (Timed a) where rnf = genericRnf +instance NFData MidiScaleType where rnf a = a `seq` () +instance NFData MidiFormat where rnf a = a `seq` () + +-------------------------------------------------------------------------------- +-- JSON import and export +-------------------------------------------------------------------------------- +instance ToJSON Beat +instance ToJSON BeatRat +instance ToJSON BarRat + +instance (Integral a, ToJSON a) => ToJSON (Ratio a) where + toJSON r = object [pack "num" .= numerator r, pack "den" .= denominator r] + +instance ToJSON (TimeSig) where + toJSON (TimeSig n d _ _) = object [pack "ts_num" .= n, pack "ts_den" .= d] + toJSON NoTimeSig = object [pack "ts" .= pack "none"] + +instance FromJSON Beat +instance FromJSON BeatRat +instance FromJSON BarRat + +instance (Integral a, FromJSON a) => FromJSON (Ratio a) where + parseJSON (Object v) = (%) <$> v .: (pack "num") <*> v .: (pack "den") + parseJSON _ = mzero + +instance FromJSON (TimeSig) where + parseJSON (Object v) = (\n d -> TimeSig n d 0 0) + <$> v .: (pack "ts_num") <*> v .: (pack "ts_den") + + parseJSON _ = mzero
+ src/ZMidi/Score/Internal.hs view
@@ -0,0 +1,19 @@+-- | +-- Module : ZMidi.Score.Internal +-- Copyright : (c) 2012--2014, Utrecht University +-- License : LGPL-3 +-- +-- Maintainer : W. Bas de Haas <w.b.dehaas@uu.nl> +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: functions that are kept internal + +module ZMidi.Score.Internal where + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +invalidMidiNumberError :: Show a => a -> b +invalidMidiNumberError w = error ("invalid MIDI note number" ++ show w)
+ src/ZMidi/Score/Quantise.hs view
@@ -0,0 +1,243 @@+{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +-- | +-- Module : ZMidi.Score.Quantise +-- Copyright : (c) 2012--2014, Utrecht University +-- License : LGPL-3 +-- +-- Maintainer : W. Bas de Haas <w.b.dehaas@uu.nl> +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Functions for quantising a 'MidiScore' +module ZMidi.Score.Quantise ( -- * Quantisation specific datatypes + QMidiScore (..) + , ShortestNote (..) + , GridUnit (..) + , QBins (..) + , QDev (..) + , QDevPerc (..) + -- * Quantisation functions + , quantise + , quantiseSafe + , quantiseQDevSafe + -- * Utilities + , avgQDev + , avgQDevQMS + , canBeQuantisedAt + , removeOverlap + , getMinGridSize + , qToQBins + , toQBins + , getNumForQBins + ) where + +import ZMidi.Score.Datatypes +import ZMidi.Score.Utilities + +import Control.Arrow ( second ) +import Text.Printf ( printf, PrintfArg ) + +import Data.Binary ( Binary ) +import GHC.Generics ( Generic ) +import Control.DeepSeq ( NFData ) +import Data.Ratio ( Ratio, numerator, denominator ) + +-------------------------------------------------------------------------------- +-- Quantisation contants +-------------------------------------------------------------------------------- + +acceptableQuantisationDeviation :: QDevPerc +acceptableQuantisationDeviation = 0.02 + +shortestNote :: ShortestNote +shortestNote = FourtyEighth + +-------------------------------------------------------------------------------- +-- Quantisation datatypes +-------------------------------------------------------------------------------- + +-- | QMidiScore wraps around a 'MidiScore' and stores some additional +-- information about the quantisation process. +data QMidiScore = QMidiScore { qMidiScore :: MidiScore + , qShortestNote :: ShortestNote + , qGridUnit :: GridUnit + , totDeviation :: QDev + } deriving (Show, Eq, Generic) +instance Binary QMidiScore + +-- | The 'ShortestNote' determines the minimal grid length of a quantised +-- 'QMidiScore', when quantised with 'quantise'. +data ShortestNote = Eighth | Sixteenth | ThirtySecond + | FourtyEighth | SixtyFourth + deriving (Eq, Show, Generic) +instance Binary ShortestNote + +-- | The 'GridUnit' describes the minimal length of a quantised event and +-- is controlled by the number of 'QBins' +newtype GridUnit = GridUnit { gridUnit :: Int } + deriving ( Eq, Show, Num, Ord, Enum, Real, Integral, Binary ) + +-- | The 'QBins' describes the number of quantisation bins per (annotated) beat +-- length and is generally controlled by the 'ShortestNote' parameter. +-- (see also: 'toQBins' ) +newtype QBins = QBins { qbins :: Int } + deriving ( Eq, Show, Num, Ord, Enum, Real, Integral, Binary, NFData ) + +-- | Represents a quantisation deviation, i.e. the number of ticks that an +-- event was moved to match the time grid. +newtype QDev = QDev { qDev :: Int } + deriving ( Eq, Show, Num, Ord, Enum, Real, Integral, Binary ) + +-- | Represents the average quantisation deviation per onset +newtype QDevPerc = QDevPerc { qDevPerc :: Double } + deriving ( Eq, Show, Num, Ord, Enum, Real, Floating + , Fractional, RealFloat, RealFrac, PrintfArg, Binary ) + +-------------------------------------------------------------------------------- +-- Quantisation function +-------------------------------------------------------------------------------- + +-- | Quantises a 'MidiScore' snapping all events to a 'ShortestNote' grid. +quantise :: MidiScore -> QMidiScore +quantise = either error id . quantiseSafe shortestNote + +-- | Quantises a 'MidiScore' or returns a warning if the quantisation deviation +-- exceeds the 'acceptableQuantisationDeviation'. +quantiseQDevSafe :: MidiScore -> Either String QMidiScore +quantiseQDevSafe ms = quantiseSafe shortestNote ms >>= qDevCheck + +-- | Checks if a 'QMidiScore' exceeds the 'acceptableQuantisationDeviation' +-- and return the 'QMidiScore' or a warning. +qDevCheck :: QMidiScore -> Either String QMidiScore +qDevCheck qm | d < acceptableQuantisationDeviation = Right qm + | otherwise = Left ("the average quantisation deviation is above " + ++ printf "allowed deviation: %.3f < %.3f" + d acceptableQuantisationDeviation ) + where d = avgQDevQMS qm + +-- | calculating the average quantisation deviation +avgQDevQMS :: QMidiScore -> QDevPerc +avgQDevQMS qm = avgQDev (qGridUnit qm) (totDeviation qm) + (nrOfNotes . qMidiScore $ qm) + +avgQDev :: GridUnit -> QDev -> Int -> QDevPerc +avgQDev gu qd nrn = + QDevPerc ((fromIntegral qd / fromIntegral nrn) / fromIntegral gu) + +-- | Quantises a 'MidiScore' snapping all events to a 'ShortestNote' grid. +-- The absolute size of the grid is based on the 'GridUnit', which is the +-- 'ticksPerBeat' divided by the number of quantization bins per beat. Besides +-- the quantised 'MidiScore' and the 'GridUnit' also the cumulative deviation +-- from the grid is returned. +quantiseSafe :: ShortestNote -> MidiScore -> Either String QMidiScore +quantiseSafe sn (MidiScore k ts (TPB dv) mf tp _md vs) = + -- the grid unit is the number of ticks per beat divided by the maximum + -- number of notes in one beat + case dv `divMod` (qbins . toQBins $ sn) of + (gu, 0) -> let -- snap all events to a grid, and remove possible overlaps + (vs',d) = unzip . map (quantiseVoice . GridUnit $ gu) $ vs + -- the minimum duration might have changed + md' = gcIOId . buildTickMap $ vs' + -- also align the time signatures to a grid + ts' = map (snapTimed . GridUnit $ gu) ts + -- update the MidiScore + ms' = MidiScore k ts' (TPB dv) mf tp md' vs' + in Right (QMidiScore ms' sn (GridUnit gu) (sum d)) + _ -> Left ("MidiFile cannot be quantised: " ++ show dv ++ + " cannot be divided by " ++ show (toQBins sn)) + +-- | quantises a 'Timed' event +snapTimed :: GridUnit -> Timed a -> Timed a +snapTimed gu t = t {onset = fst . snap gu $ onset t} + +-- | quantises a 'Voice', and returns the cumulative 'Deviation'. +quantiseVoice :: GridUnit -> Voice -> (Voice, QDev) +quantiseVoice gu = second sum . unzip . map snapEvent where + + snapEvent :: Timed ScoreEvent -> (Timed ScoreEvent, QDev) + snapEvent (Timed ons dat) = let (t', d) = snap gu ons + in case dat of + (NoteEvent c p v l) -> (Timed t' (NoteEvent c p v (fst $ snap gu l)), d) + _ -> (Timed t' dat , d) + +-- | snaps a 'Time' to a grid +snap :: GridUnit -> Time -> (Time, QDev) +snap gu t | m == 0 = (t, 0) -- score event is on the grid + | m > 0 = if (g - m) >= m -- score event is off the grid + -- and closer to the past grid point + then let t' = d * g + in (t', fromIntegral (t - t')) -- snap backwards + -- or closer to the next grid point + else let t' = (1+d) * g + in (t', fromIntegral (t' - t )) -- snap forwards + | otherwise = error "Negative time stamp found" + where (d,m) = t `divMod` g + g = fromIntegral gu + + +-- | Returns true if the number of ticks per beat can be divided by the +-- maximal number of quantisation bins. +canBeQuantisedAt :: ShortestNote -> MidiScore -> Bool +canBeQuantisedAt sn ms = ((tpb . ticksPerBeat $ ms) + `mod` (qbins . toQBins $ sn)) == 0 + +-- | Although 'quantise' also quantises the duration of 'NoteEvents', it can +-- happen that melody notes do still overlap. This function removes the overlap +-- N.B. This function is designed only for monophonic melodies, it does not +-- work on a polyphonic score. +removeOverlap :: Voice -> Voice +removeOverlap = foldr step [] where + + step :: Timed ScoreEvent -> [Timed ScoreEvent] -> [Timed ScoreEvent] + step t [] = [t] + step t n = updateDur : n where + + updateDur :: Timed ScoreEvent + updateDur = case getEvent t of + (NoteEvent c p v d) -> let nxt = onset . head $ n + d' = if onset t + d > nxt + then nxt - onset t else d + in t {getEvent = NoteEvent c p v d'} + _ -> t + + +-- | Returns the minimal grid size of a 'MidiScore' if it has been quantised. +-- This is the 'ticksPerBeat' divided by the number of quantisation bins. +-- N.B. this function does not check whether a file is quantised. +getMinGridSize :: ShortestNote -> MidiScore -> TPB +getMinGridSize q ms = case (tpb . ticksPerBeat $ ms) `divMod` + (qbins . toQBins $ q) of + (d,0) -> TPB d + _ -> error "getMinGridSize: invalid quantisation" + +-- | Applies 'toQBins' to the 'ShortestNote' in a 'QMidiScore' +qToQBins :: QMidiScore -> QBins +qToQBins = toQBins . qShortestNote + +-- | takes the quantisation granularity parameter 'ShortestNote' and returns +-- a the 'GridUnit' that the beat length should be divided by. The resulting +-- value we name 'GridUnit'; it describes the minimal length of an event. +toQBins :: ShortestNote -> QBins +toQBins Eighth = QBins 2 +toQBins Sixteenth = QBins 4 +toQBins ThirtySecond = QBins 8 +toQBins FourtyEighth = QBins 12 +toQBins SixtyFourth = QBins 16 + + +-- | Returns the numerator of a Ratio given a certain 'QBins' as denominator. +-- The standard Ratio implementation simplifies the Ration, e.g. 3 % 12 +-- is converted into 1 % 4. This function reverses that process: +-- +-- >>> getNumForQBins 12 (1 % 4) +-- >>> 3 +-- +-- >>> getNumForQBins 12 (1 % 1) +-- >>> 12 +getNumForQBins :: QBins -> Ratio Int -> Int +getNumForQBins (QBins q) r = numerator r * (q `div` denominator r) + + +
+ src/ZMidi/Score/Show.hs view
@@ -0,0 +1,82 @@+{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +-- | +-- Module : ZMidi.Score.Show +-- Copyright : (c) 2012--2014, Utrecht University +-- License : LGPL-3 +-- +-- Maintainer : W. Bas de Haas <w.b.dehaas@uu.nl> +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: functions for representing a 'MidiScore' as text. +module ZMidi.Score.Show ( showMidiScore + , showVoices + ) where + +import ZMidi.Score.Datatypes +import Control.Monad.State ( State, modify, get + , evalState ) +import Control.Monad ( mapAndUnzipM ) +import Data.List ( intercalate ) +import Text.Printf ( printf ) + + +-------------------------------------------------------------------------------- +-- Printing MidiScores +-------------------------------------------------------------------------------- + +-- | Show a MidiScore in a readable way +showMidiScore :: MidiScore -> String +showMidiScore ms@(MidiScore k ts tb mf tp st _vs) = "Key: " ++ show k + ++ "\nMeter: " ++ show ts + ++ "\nTicks per Beat: " ++ show tb + ++ "\nMidi format: " ++ show mf + ++ "\nTempo: " ++ show tp + ++ "\nShortest tick: " ++ show st + ++ "\nNotes:\n" ++ showVoices ms + +-- | Shows the voices in a MidiScore in a readable way, but this function +-- only works for monophonic channels. TODO: fix +showVoices :: MidiScore -> String +showVoices ms = intercalate "\n" $ evalState (showTimeSlice . getVoices $ ms) 0 + where + + -- shows a the sounding notes at a specific time + showTimeSlice :: [Voice] -> State Time [String] + showTimeSlice vs = + do (str, vs') <- mapAndUnzipM showVoiceAtTime vs + case noMoreNotesToShow vs' of -- the stopping condition + True -> return [] + False -> do t <- get + -- update the clock + modify (+ minDur ms) + x <- showTimeSlice vs' -- recursively calculate a next slice + -- the output string: + let out = intercalate "\t" (printf "%7d" (time t) : str) + return (out : x) + + -- The stopping condition: when there are no more notes in all of the tracks + noMoreNotesToShow :: [Voice] -> Bool + noMoreNotesToShow = and . map null + + -- Takes a Voice and shows the head of the voice appropriately depending on + -- the location in time. showVoicAtTime also returns the tail of the voice. + showVoiceAtTime :: Voice -> State Time (String, Voice) + showVoiceAtTime [] = return (" ",[]) + showVoiceAtTime x@(v:vs) = + do t <- get + case hasStarted t v of + True -> case hasEnded t v of + -- if v has ended, an new note at the same voice + -- might start at the same time. Hence, call ourselves again + True -> showVoiceAtTime vs + False -> return (show . pitch . getEvent $ v, x) + False -> return (" " , x) + + hasStarted, hasEnded :: Time -> Timed ScoreEvent -> Bool + -- returns true if the Timed ScoreEvent is has started to sound at Time t + hasStarted t tse = t >= onset tse + -- returns true if the Timed ScoreEvent is still sounding at Time t + hasEnded t (Timed ons se) = ons + duration se < t
+ src/ZMidi/Score/ToMidiFile.hs view
@@ -0,0 +1,91 @@+{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : ZMidi.Score.Datatypes +-- Copyright : (c) 2012--2014, Utrecht University +-- License : LGPL-3 +-- +-- Maintainer : W. Bas de Haas <w.b.dehaas@uu.nl> +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: converting a 'MidiScore' into a ZMidi.Core.MidiFile +-- (see: <https://hackage.haskell.org/package/zmidi-core> ). +module ZMidi.Score.ToMidiFile ( midiScoreToMidiFile ) where + +import Data.Maybe ( mapMaybe ) +import Data.List ( genericLength, sort ) +import Control.Monad.State ( State, get, evalState, put ) + +import GHC.Float ( integerLogBase ) + +import ZMidi.Core ( MidiFile (..), MidiEvent (..), DeltaTime + , MidiVoiceEvent (..), MidiMetaEvent (..) + , MidiMessage, MidiTrack (..), MidiHeader (..) + , MidiTimeDivision (..), MidiRunningStatus (..) + ) + +import ZMidi.Score.Datatypes hiding ( TPB (..) ) +import ZMidi.Score.Utilities ( toMidiNr ) + +-------------------------------------------------------------------------------- +-- Converting a MidiScore into a MidiFile +-------------------------------------------------------------------------------- + +-- | Transforms a 'MidiFile' into a 'MidiScore' +midiScoreToMidiFile :: MidiScore -> MidiFile +midiScoreToMidiFile (MidiScore ks ts dv mf tp _ vs) = MidiFile hdr trks where + + hdr = MidiHeader mf (genericLength trks) (TPB . fromIntegral $ dv) + trks = metaToMidiEvent : map voiceToTrack vs -- the MidiTracks + + -- Takes the Key and TimeSig fields and tranforms them into + -- a MidiTrack containing only MetaEvents + metaToMidiEvent :: MidiTrack + metaToMidiEvent = mkMidiTrack MetaEvent ( mapMaybe keyToMidiEvent ks + ++ (mapMaybe tsToMidiEvent ts) + ++ map tempoToMidiEvent tp) + +-- transforms a Key into a MetaEvent +keyToMidiEvent :: Timed Key -> Maybe (Timed MidiMetaEvent) +keyToMidiEvent (Timed _ NoKey ) = Nothing +keyToMidiEvent (Timed o (Key r s)) = Just $ Timed o (KeySignature r s) + +-- transforms a TimeSig into a MetaEvent +tsToMidiEvent :: Timed TimeSig -> Maybe (Timed MidiMetaEvent) +tsToMidiEvent (Timed _ NoTimeSig ) = Nothing +tsToMidiEvent (Timed o (TimeSig n d m n32)) = + Just $ Timed o (TimeSignature (fromIntegral n) + (fromIntegral . integerLogBase 2 . fromIntegral $ d) m n32) + + +-- transforms a tempo into a MetaEvent +tempoToMidiEvent :: Timed Time -> Timed MidiMetaEvent +tempoToMidiEvent = fmap (SetTempo . fromIntegral) + +-- transforms a Voice into a MidiTrack +voiceToTrack :: Voice -> MidiTrack +voiceToTrack = mkMidiTrack (VoiceEvent RS_OFF) . concatMap toMidiNote + +-- transforms a NoteEvent into a MidiVoiceEvent +toMidiNote :: Timed ScoreEvent -> [Timed MidiVoiceEvent] +toMidiNote (Timed o (NoteEvent c p v d)) = + let p' = toMidiNr p + c' = channel c + v' = velocity v + in [Timed o (NoteOn c' p' v'), Timed (o + d) (NoteOff c' p' 0)] +toMidiNote _ = error "noteEventToMidiNote: not a NoteEvent." + +-- this is where the magic happens. A list of timed events is made relative +-- such that timestamps denote the time between elements. We close +-- the track by appending a EndOfTrack marker with final time stamp. +-- The track is sorted by midi tick +mkMidiTrack :: forall a. Ord a => (a -> MidiEvent) -> [Timed a] -> MidiTrack +mkMidiTrack f e = MidiTrack $ (trk ++ [(0, MetaEvent EndOfTrack)]) + + where trk = evalState (mapM mkRelative . sort $ e) 0 + + mkRelative :: Timed a -> State DeltaTime MidiMessage + mkRelative (Timed o me) = do let o' = fromIntegral o + t <- get ; put o' + return (o' - t, f me)
+ src/ZMidi/Score/ToMidiScore.hs view
@@ -0,0 +1,174 @@+{-# OPTIONS_GHC -Wall #-} +-- | +-- Module : ZMidi.Score.ToMidiScore +-- Copyright : (c) 2012--2014, Utrecht University +-- License : LGPL-3 +-- +-- Maintainer : W. Bas de Haas <w.b.dehaas@uu.nl> +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: Transforms a raw ZMidi MidiFile into a more high-level MidiScore +-- representation (see: <https://hackage.haskell.org/package/zmidi-core> ). +module ZMidi.Score.ToMidiScore ( midiFileToMidiScore ) where + +import Data.Word ( Word8 ) +import Data.Maybe ( catMaybes ) +import Data.Ord ( comparing ) +import Data.List ( partition, sortBy, nub ) +import Control.Arrow ( first, second ) +import Control.Monad.State ( State, modify, gets, evalState ) + +import ZMidi.Core ( MidiFile (..), MidiEvent (..) + , MidiVoiceEvent (..), MidiMetaEvent (..) + , MidiMessage, MidiTrack (..), MidiHeader (..) + , MidiTimeDivision (..) + ) + +import ZMidi.Score.Datatypes hiding ( TPB (..) ) +import qualified ZMidi.Score.Datatypes as S ( TPB (..) ) +import ZMidi.Score.Utilities + +-------------------------------------------------------------------------------- +-- Converting a MidiFile +-------------------------------------------------------------------------------- + +-- | Transforms a 'MidiFile' into a 'MidiScore' +midiFileToMidiScore :: MidiFile -> MidiScore +midiFileToMidiScore mf = MidiScore (select isKeyChange keyChange NoKey meta) + -- (map (updTimeSig tpb) . nub $ select isTimeSig tsChange NoTimeSig meta) + (nub $ select isTimeSig tsChange NoTimeSig meta) + tb + (hdr_format . mf_header $ mf) + (select isTempoChange tempChange 500000 meta) + (gcIOId . buildTickMap $ trks) + (filter (not . null) trks) where + + tb = getDivision . mf_header $ mf + (trks, meta) = second concat . -- merge all meta data into one list + -- separate meta data from note data + unzip . map (partition isNoteEvent . midiTrackToVoice) + . mf_tracks $ mf -- get midi tracks + + -- Given a filter function, a transformation function and a default value + -- this function transforms a list of score events, which can possibly be + -- empty, into a Timed meta information + select :: (Timed ScoreEvent -> Bool) -> (ScoreEvent -> a) -> a + -> [Timed ScoreEvent] -> [Timed a] + select f c def ses = case filter f ses of + [] -> [Timed 0 def] + t -> map (fmap c) t + + -- tsEq Timed TimeSig -> Timed TimeSig -> Bool + -- tsEq + + -- Returns the time division of the MidiScore, which is the length of a + -- quarter note + getDivision :: MidiHeader -> S.TPB + getDivision hd = case time_division hd of + (FPS _ ) -> error "no division found" + (TPB b ) -> fromIntegral b + + +-- | Transforms a 'MidiTrack' into a 'Voice' +midiTrackToVoice :: MidiTrack -> Voice +midiTrackToVoice m = + sortBy (comparing onset) . catMaybes + $ evalState (mapM toScoreEvent . getTrackMessages $ m) (0, []) where + + -- Transforms a 'MidiMessage' into a 'ScoreEvent' + toScoreEvent :: MidiMessage -> State MidiState (Maybe (Timed ScoreEvent)) + toScoreEvent mm@(dt, me) = do -- update the (absolute) midi clock + modify (stateTimeWith (+ (fromIntegral dt))) + case me of + (VoiceEvent _ _) -> voiceEvent mm + (MetaEvent _) -> metaEvent mm + _ -> return Nothing + +-- Transforms a 'MidiMessage' containing a 'VoiceEvent' into a 'ScoreEvent' +voiceEvent :: MidiMessage -> State MidiState (Maybe (Timed ScoreEvent)) +voiceEvent mm = case getVoiceEvent mm of + Just (NoteOff chn ptch _vel) -> toMidiNote chn ptch + Just (NoteOn chn ptch 0 ) -> toMidiNote chn ptch + Just n@(NoteOn _chn _ptch _vel) + -> do t <- gets fst + -- replace the deltaTime in the noteOn event by the absolute + -- time as stored in the MidiState + modify . addMessage $ (t, n) + return Nothing + _ -> return Nothing -- ignore NoteAftertouch, Controller, + -- ProgramChange, ChanAftertouch, PitchBend + +-- Transforms a 'MidiMessage' containing a 'MetaEvent' into a 'ScoreEvent' +metaEvent :: MidiMessage -> State MidiState (Maybe (Timed ScoreEvent)) +metaEvent mm = + do t <- gets fst + case getMetaEvent mm of + -- tempo meta event + Just (SetTempo tp) + -> return . Just . Timed t . TempoChange . fromIntegral $ tp + -- timesignature meta event + Just (TimeSignature num den metr n32n) + -> return . Just . Timed t $ TimeSigChange + (TimeSig (fromIntegral num) (2 ^ den) metr n32n) + -- key meta event + Just (KeySignature root scale) + -> return . Just $ Timed t (KeyChange (Key root scale )) + _ -> return Nothing + +-- Some utilities: +-- Given a note-on and a note off event, creates a new MidiNote ScoreEvent +toMidiNote :: Word8 -> Word8 -> State MidiState (Maybe (Timed ScoreEvent)) +toMidiNote c p = + do ms <- gets snd + case span (not . isNoteOnMatch c p) ms of + -- TODO: perhaps we should store the missed note offs?? + (_, [] ) -> -- trace ("no note on found for: " ++ show p + -- ++ " on channel: " ++ show c) + (return Nothing) + (x, (ons, noteOn) : y) -> + do modify (setMessages (x ++ y)) + t <- gets fst + -- N.B. the delta time in the note on has been replace + -- by an absolute timestamp + return . Just . Timed ons $ NoteEvent (fromIntegral c) + (toPitch p) (getVelocity noteOn) (t - ons) + +-- returns True if the NoteOn MidiMessage maches a Channel and Pitch +isNoteOnMatch :: Word8 -> Word8 -> (Time, MidiVoiceEvent) -> Bool +isNoteOnMatch offc offp (_t, NoteOn onc onp _v) = onc == offc && onp == offp +isNoteOnMatch _c _p _ = False + +-- Given a MidiMessage, returns the MidiVoiceEvent and Nothing if it +-- contains something else. +getVoiceEvent :: MidiMessage -> Maybe MidiVoiceEvent +getVoiceEvent (_t, (VoiceEvent _ e)) = Just e +getVoiceEvent _ = Nothing + +-- Given a MidiMessage, returns the MidiMetaEvent and Nothing if it +-- contains something else. +getMetaEvent :: MidiMessage -> Maybe MidiMetaEvent +getMetaEvent (_t, (MetaEvent e)) = Just e +getMetaEvent _ = Nothing + +getVelocity :: MidiVoiceEvent -> Velocity +getVelocity (NoteOn _ _ v) = Velocity v +getVelocity (NoteOff _ _ v) = Velocity v +getVelocity _ = error "not a noteOn or a noteOff event" + +-- We define a stat to store the absolute midi clock +-- and a list of note-on events. +type MidiState = (Time, [(Time, MidiVoiceEvent)]) + +-- We also define some accessor functions for our MidiState. 'setMessages' +-- replaces the list with 'MidiMessages' with a new one. +setMessages :: [(Time, MidiVoiceEvent)] -> MidiState -> MidiState +setMessages ms = second (const ms) + +-- adds a 'MidiMessage' to the list of 'MidiMessages' +addMessage :: (Time, MidiVoiceEvent) -> MidiState -> MidiState +addMessage m = second (m :) + +-- applies a function to the 'Time' field in our 'MidiState' +stateTimeWith :: (Time -> Time) -> MidiState -> MidiState +stateTimeWith f = first f
+ src/ZMidi/Score/Utilities.hs view
@@ -0,0 +1,210 @@+{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +-- | +-- Module : ZMidi.Score.ToMidiScore +-- Copyright : (c) 2012--2014, Utrecht University +-- License : LGPL-3 +-- +-- Maintainer : W. Bas de Haas <w.b.dehaas@uu.nl> +-- Stability : experimental +-- Portability : non-portable +-- +-- Summary: some utilities for manipulating and extracting information from +-- 'MidiFile's. +module ZMidi.Score.Utilities ( + -- * Minimum length calculation + TickMap + , buildTickMap + , gcIOId + -- * Utilities + , isTempoChange + , isTimeSig + , isKeyChange + , isNoteEvent + , nrOfNotes + , toIOIs + , toOnsets + , toMidiNr + , toPitch + , getPitch + , getInterval + , changePitch + , pitchClass + , hasTimeSigs + , updateTimeSig + -- * MidiFile Utitlites + , removeLabels + , hasNotes + ) where + +import ZMidi.Score.Internal +import ZMidi.Score.Datatypes +import ZMidi.Core ( MidiFile (..), MidiEvent (..) + , MidiVoiceEvent (..), MidiMetaEvent (..) + , MidiMessage, MidiTrack (..) + ) +import Control.Monad.State ( State, modify, execState ) +import Control.Arrow ( first, (***) ) +import Data.Word ( Word8 ) +import Data.Maybe ( isJust ) +import Data.List ( find, sort ) +import qualified Data.List.Ordered as Sort ( nub ) +import Data.Foldable ( foldrM ) +import Data.IntMap.Lazy ( insertWith, IntMap, keys ) +import qualified Data.IntMap.Lazy as M ( empty ) + +-------------------------------------------------------------------------------- +-- Analysing durations +-------------------------------------------------------------------------------- + +-- | A 'TickMap' is basically a histogram of IOI counts of a piece (of all +-- voices) +type TickMap = IntMap Time + +-- | The Inter Onset Interval that is the greatest common divider. It can be +--used to estimate whether a track is quantised or not. +gcIOId :: TickMap -> Time +gcIOId tm = case keys $ tm of + [] -> 0 + l -> Time . foldr1 gcd $ l + +-- | builds a 'TickMap'. +buildTickMap :: [Voice] -> TickMap +buildTickMap = foldr oneVoice M.empty where + + -- calculated all IOIs and order them per duration + oneVoice :: Voice -> TickMap -> TickMap + oneVoice [] tm = tm -- to account for offsets we add the first onset too + oneVoice vs tm = step (onset . head $ vs) . foldr step tm $ (toIOIs vs) + + step :: Time -> TickMap -> TickMap + step (Time se) tm = insertWith succIfExists se 0 tm + + succIfExists :: Time -> Time -> Time + succIfExists _ old = succ old + +-- printTickMap :: TickMap -> String +-- printTickMap tm = "tickmap:\n" ++ (concatMap showTick . toAscList $ tm) where + + -- showTick :: (Int, Time) -> String + -- showTick (i, t) = show i ++ ": " ++ show t ++ "\n" + +-------------------------------------------------------------------------------- +-- Utilities +-------------------------------------------------------------------------------- + +-- | Returns the number of 'ScoreEvent's in a 'MidiScore' +nrOfNotes :: MidiScore -> Int +nrOfNotes = sum . map length . getVoices + +-- | Returns True if the 'ScoreEvent' is a time signature change +isTimeSig :: Timed ScoreEvent -> Bool +isTimeSig (Timed _ (TimeSigChange _ )) = True +isTimeSig _ = False + +-- | Returns True if the 'ScoreEvent' is a key change +isKeyChange :: Timed ScoreEvent -> Bool +isKeyChange (Timed _ (KeyChange _ )) = True +isKeyChange _ = False + +-- | Returns True if the 'ScoreEvent' is a key change +isTempoChange :: Timed ScoreEvent -> Bool +isTempoChange (Timed _ (TempoChange _ )) = True +isTempoChange _ = False + +-- | Returns True if the 'ScoreEvent' is a 'NoteEvent' +isNoteEvent :: Timed ScoreEvent -> Bool +isNoteEvent (Timed _ (NoteEvent _ _ _ _ )) = True +isNoteEvent _ = False + +-- | Returns the 'PitchClass' of a particular 'Pitch'. +pitchClass :: Pitch -> PitchClass +pitchClass (Pitch (_, pc)) = pc + +-- | Returns the 'Pitch' of a 'Timed' 'ScoreEvent'. In case of a non-'NoteEvent' +-- an error will be thrown +getPitch :: Timed ScoreEvent -> Pitch +getPitch tse = case getEvent tse of + (NoteEvent _c p _v _d) -> p + se -> error ("unexpected ScoreEvent: " ++ show se) + +-- | Returns the posibly negative 'Interval' between two 'Pitch'es +getInterval :: Pitch -> Pitch -> Interval +getInterval (Pitch (Octave fo, PitchClass fpc)) + (Pitch (Octave to, PitchClass tpc)) = + let (oct', pc') = divMod (tpc - fpc) 12 + in Interval ((12 * (to - fo + oct')) + pc') + +-- | Changes a 'Pitch' with a particular 'Interval' +changePitch :: Pitch -> Interval -> Pitch +changePitch (Pitch (Octave oct, PitchClass pc)) (Interval i) = + let (octi, pci) = divMod i 12 + (oct', pc') = divMod (pc + pci) 12 + in Pitch (Octave (oct + octi + oct'), PitchClass pc') + +-- | Ignores all pitch information and returns a list of onsets. N.B. in case +-- of a polyphonic track duplicate onsets are deleted. +toOnsets :: Voice -> [Time] +toOnsets = Sort.nub . map onset + +-- | Transforms a 'Voice' into a list of Inter Onset Intervals (IOIs) +toIOIs :: Voice -> [Time] +toIOIs v = execState (foldrM step [] v) [] where + + step :: Timed ScoreEvent -> [Timed ScoreEvent] + -> State [Time] [Timed ScoreEvent] + step t [] = return [t] + step t ts@(h : _) = do modify ((onset h - onset t) :) + return (t : ts) + +-- | Converts a 'Pitch' into a MIDI note number +toMidiNr :: Pitch -> Word8 +toMidiNr (Pitch (Octave o, PitchClass p)) = fromIntegral (((o + 5) * 12) + p) + +-- | Converts a MIDI note number into an octave and a pitch class, a.k.a 'Pitch' +toPitch :: Word8 -> Pitch +toPitch = Pitch . (Octave *** PitchClass) . midiNrToPitch where + + midiNrToPitch :: Word8 -> (Int, Int) + midiNrToPitch p | p < 0 = invalidMidiNumberError p + | p > 127 = invalidMidiNumberError p + | otherwise = first (+ (-5)) (fromIntegral p `divMod` 12) + +-- | Returns True if the 'MidiScore' has time signatures other than 'NoTimeSig' +hasTimeSigs :: MidiScore -> Bool +hasTimeSigs = not . null . filter (not . (== NoTimeSig) . getEvent) . getTimeSig + +-- | Updates a time signature, or returns a warning if the update fails +updateTimeSig :: MidiScore -> Timed TimeSig -> Timed TimeSig + -> Either String MidiScore +updateTimeSig ms old new + | ts == ts' = Left ("updateTimeSig: TimeSig " ++ show old ++ " not found") + | otherwise = Right $ ms {getTimeSig = sort (new : ts') } + where ts = getTimeSig ms + ts' = filter (== old) ts + +-------------------------------------------------------------------------------- +-- Some MidiFile utilities +-------------------------------------------------------------------------------- +-- | Returns True if the MidiTrack is non-empty +hasNotes :: MidiTrack -> Bool +hasNotes = isJust . find isNoteOnEvent . getTrackMessages + +-- | Returns True if the 'MidiMessage' is a NoteOn event. +isNoteOnEvent :: MidiMessage -> Bool +isNoteOnEvent (_, (VoiceEvent _ (NoteOn _ _ _))) = True +isNoteOnEvent _ = False + +-- | Removes the track labels from a 'MidiFile' +removeLabels :: MidiFile -> MidiFile +removeLabels f = f { mf_tracks = map filterLab . mf_tracks $ f } where + + filterLab :: MidiTrack -> MidiTrack + filterLab = MidiTrack . filter (not . isLab) . getTrackMessages + + isLab :: MidiMessage -> Bool + isLab (_, (MetaEvent (TextEvent _ _))) = True + isLab _ = False +
+ zmidi-score.cabal view
@@ -0,0 +1,51 @@+name: zmidi-score +version: 0.3.0.0 +synopsis: Representing MIDI a simple score. +description: Representing MIDI data as a simple score using the zmidi-core library. +license: LGPL-3 +license-file: LICENSE +author: W. Bas de Haas +maintainer: W.B.deHaas@uu.nl +copyright: 2012--2014, Utrecht University +homepage: https://bitbucket.org/bash/zmidi-score +category: Music +build-type: Simple +tested-with: GHC == 7.6.1, GHC == 7.8.2 +cabal-version: >=1.8 +extra-Source-Files: README.md CHANGELOG.md +source-repository head + type: git + location: git@bitbucket.org:bash/zmidi-score.git + +library + exposed-modules: ZMidi.Score + ZMidi.Score.BarBeatPos + ZMidi.Score.Datatypes + ZMidi.Score.Quantise + ZMidi.Score.Show + ZMidi.Score.ToMidiFile + ZMidi.Score.ToMidiScore + ZMidi.Score.Utilities + + ZMidi.IO.Common + + hs-source-dirs: src + + other-modules: ZMidi.Score.Internal + + build-depends: base >= 4.4 && < 4.8, + zmidi-core ==0.7.*, + mtl ==2.1.*, + containers >= 0.5.0.0, + directory ==1.2.*, + filepath ==1.3.*, + data-ordlist >= 0.4.5, + aeson >= 0.7.0.6, + text == 1.1.1.*, + binary >= 0.7.1, + deepseq >= 1.3, + deepseq-generics >= 0.1, + parallel-io >= 0.3.3 + + ghc-options: -Wall -O2 + ghc-prof-options: -fprof-auto