AlgoRhythm-0.1.0.0: test/TMidi.hs
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE ScopedTypeVariables #-}
module TMidi where
import Codec.Midi (importFile)
import Control.Applicative ((<|>))
import qualified Data.ByteString as B
import Data.Char (toUpper)
import Data.List (find, intersect, sort)
import qualified Euterpea as E
import Euterpea.IO.MIDI (fromMidi)
import System.Directory (doesFileExist, removeFile)
import System.IO.Unsafe (unsafePerformIO)
import System.Random (newStdGen, randomRs)
import Test.Framework (Test, buildTestBracketed,
testGroup)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit ((@?=), Assertion)
import Text.Printf (printf)
import Export
import Grammar hiding ((<|>))
import Music
-- | Generates a random filename `f` with the .midi extension, runs the given
-- test `t` using that filename, and immediately removes the file stored at
-- location `f` after the test finished. The reason that we have to generate
-- random file names and cannot use the same one all the time is that tests
-- can be exectued concurrently.
testAndCleanup :: (String -> Test) -> Test
testAndCleanup t = buildTestBracketed $ do
g <- newStdGen
let f = take 8 (randomRs ('a','z') g) ++ ".midi"
let test = t f
let cleanup = removeFile f
return (test, cleanup)
midiTests :: Test
midiTests = testGroup "MIDI export"
[ testAndCleanup $ \f -> testCase "Successfully write to file" $ do
let res = unsafePerformIO $ do
let ?harmonyConfig = defHarmonyConfig
let ?melodyConfig = defMelodyConfig
let ?midiConfig = defaultMIDIConfig
(back, fore) <- integrate (16 * wn)
writeToMidiFile f (back :=: fore)
doesFileExist f
res @?= True
-- Check if the header is correct (HCodecs (which is used by Euterpea))
-- doesn't check MIDI headers properly.
, testAndCleanup $ \f -> testCase "Correct Midi header" $ do
{- See: https://www.csie.ntu.edu.tw/~r92092/ref/midi/
4D546864 = "MThd", which represents the start of a MIDI header chunk.
00000006 = length of the actual header chunk. This is always 6 bytes.
000100000060 = The six byte long header chunk. Can be subdivided in:
0001 = MIDI file format. Should be 0,1 or 2. 1 means that there
is only 1 track and that everything is played concurrently.
0000 = The number of track chunks. Should be 0 obviously, since
our music only consists of a rest.
0060 = Speed. hex 0060 = bin 0-000000001100000. Here, the most
significant bit says that the unit of speed is ticks per
quarternote. The last 15 bits are the number of ticks,
so 96 in decimal.
-}
let midiHex = "4D546864-00000006-000100000060"
let m = Rest 0 :: Music Chord
let byteString = unsafePerformIO $ do
let ?midiConfig = defaultMIDIConfig
writeToMidiFile f m
B.readFile f
let hex = concatMap (printf "%02x") (B.unpack byteString)
let upperHex = map toUpper hex
upperHex @?= filter ('-'/=) midiHex
, testCase "Sequential music to Euterpea" $ do
let ?midiConfig = MIDIConfig (1%2) [AcousticGrandPiano]
let m = toMusicCore $ C#4<|qn :+: Cs#3<|hn
let mE = musicToE m
let mEExpected = E.Modify (E.Tempo (1 % 2)) (
E.Modify (E.Instrument AcousticGrandPiano) (
E.Prim (E.Note (1 % 4) ((E.C,4),[]))
E.:+:
E.Prim (E.Note (1 % 2) ((E.Cs,3),[]))
)
)
mE @?= mEExpected
, testCase "Parallel music to Euterpea" $ do
let ?midiConfig = MIDIConfig (1%4) [Piccolo]
let m = toMusicCore $ G#1<|qn :=: Ds#6<|hn
let mE = musicToE m
let mEExpected = E.Modify (E.Tempo (1 % 4)) (E.Modify (E.Instrument Piccolo) (
E.Prim (E.Note (1 % 4) ((E.G,1),[]))
))
E.:=:
E.Modify (E.Tempo (1 % 4)) (E.Modify (E.Instrument Piccolo) (
E.Prim (E.Note (1 % 2) ((E.Ds,6),[]))
))
mE @?= mEExpected
, testAndCleanup $ \f -> testCase "Sequential music to Midi and back" $ do
let ?midiConfig = defaultMIDIConfig
let m = toMusicCore $ C#4<|qn :+: Cs#3<|hn
let mE1 = musicToE m
unsafePerformIO $ do
writeToMidiFile f m
mE2 <- importFile f >>= \(Right m') -> return (fromMidi m')
return $ compareMusic1s (preprocess mE1) (preprocess (preprocess mE2))
, testAndCleanup $ \f -> testCase "Parallel music to Midi and back" $ do
let ?midiConfig = MIDIConfig 1 [AcousticGrandPiano, Banjo]
let m = toMusicCore $ G#1<|qn :=: Ds#6<|hn
let mE1 = musicToE m
unsafePerformIO $ do
writeToMidiFile f m
mE2 <- importFile f >>= \(Right m) -> return (fromMidi m)
return $ compareMusic1s (preprocess mE1) (preprocess (preprocess mE2))
]
-- | Rewrites the Music1 that was read from a MIDI file, preprocesses it,
-- permutes it, e.g. a :=: b is the same as b :=: a, and checks if there is at
-- least 1 permutation that is exactly equal to the original Music1.
compareMusic1s :: E.Music1 -> E.Music1 -> Assertion
compareMusic1s mOriginal mRead = do
let mOriginalMs = commonModifiers [] mOriginal
let mOriginal' = stripModifiers mOriginalMs mOriginal
let mReadMs = commonModifiers [] mRead
let mRead' = stripModifiers mReadMs mRead
-- remove e.g. empty rests in iteration 1, rewrite in iteration 2.
let mReadPreprocessed = preprocess $ preprocess mRead'
let mReadPerms = perms mReadPreprocessed
let (Just p) = find (mOriginal'==) mReadPerms <|> Just (head mReadPerms)
(p, sort mReadMs) @?= (mOriginal', sort mOriginalMs)
commonModifiers :: [E.Control] -> E.Music1 -> [E.Control]
commonModifiers cs (E.Modify c m) = commonModifiers (c:cs) m
commonModifiers cs (a E.:=: b) = commonModifiers cs a `intersect` commonModifiers cs b
commonModifiers cs (a E.:+: b) = commonModifiers cs a `intersect` commonModifiers cs b
commonModifiers cs _ = cs
stripModifiers :: [E.Control] -> E.Music1 -> E.Music1
stripModifiers cs (E.Modify c m) | elem c cs = stripModifiers cs m
stripModifiers cs (E.Modify c m) | otherwise = E.Modify c (stripModifiers cs m)
stripModifiers cs (a E.:=: b) = stripModifiers cs a E.:=: stripModifiers cs b
stripModifiers cs (a E.:+: b) = stripModifiers cs a E.:+: stripModifiers cs b
stripModifiers _ x = x
perms :: E.Music1 -> [E.Music1]
perms (m1 E.:=: m2) = concatMap (\(m1',m2') -> [m1' E.:=: m2', m2' E.:=: m1']) (perms' m1 m2)
perms (m1 E.:+: m2) = concatMap (\(m1',m2') -> [m1' E.:+: m2']) (perms' m1 m2)
perms (E.Modify x (E.Modify y m)) = concatMap ops (perms m)
where ops m' = [E.Modify x (E.Modify y m'), E.Modify y (E.Modify x m')]
perms (E.Modify x m) = map (E.Modify x) (perms m)
perms prim = [prim]
perms' :: E.Music1 -> E.Music1 -> [(E.Music1, E.Music1)]
perms' m1 m2 = [(m1',m2') | m1'<-perms m1, m2' <-perms m2]
-- | The data read from file is slightly differently formatted (rests with
-- duration 0 and some other stuff, so the preprocess function is called
-- on the Music1 that was generated by reading from a midi file, before
-- the Music1 can be compared to the original Music1.)
preprocess :: E.Music1 -> E.Music1
preprocess (E.Modify x m) = E.Modify x (preprocess m)
preprocess (n@(E.Prim (E.Note l1 _)) E.:=: (E.Prim (E.Rest l2) E.:+: m))
| l1 == l2 = (preprocess n) E.:+: (preprocess m)
| otherwise = (preprocess n) E.:=: (E.Prim (E.Rest l2) E.:+: (preprocess m))
preprocess (r@(E.Prim (E.Rest l)) E.:+: m) = if l == 0 then preprocess m else (r E.:+: (preprocess m))
preprocess (m E.:+: r@(E.Prim (E.Rest l))) = if l == 0 then preprocess m else ((preprocess m) E.:+: r)
preprocess (r@(E.Prim (E.Rest l)) E.:=: m) = if l == 0 then preprocess m else (r E.:=: (preprocess m))
preprocess (m E.:=: r@(E.Prim (E.Rest l))) = if l == 0 then preprocess m else ((preprocess m) E.:+: r)
preprocess (m1 E.:+: m2) = preprocess m1 E.:+: preprocess m2
preprocess (m1 E.:=: m2) = preprocess m1 E.:=: preprocess m2
preprocess (E.Prim (E.Rest l)) = E.Prim (E.Rest l)
preprocess (E.Prim (E.Note l (x, xs))) = E.Prim (E.Note l (x, filter notVol xs))
where notVol (E.Volume _) = False
notVol _ = True