midi-0.1.6: src/Sound/MIDI/Example/Tomatosalad.hs
{-
The famous song, that is named "Tomatensalat" in German.
-}
module Main where
import qualified Sound.MIDI.File as MidiFile
import qualified Sound.MIDI.File.Save as Save
import Sound.MIDI.File (ElapsedTime, )
import qualified Sound.MIDI.File.Event.Meta as MetaEvent
import qualified Sound.MIDI.File.Event as Event
import qualified Sound.MIDI.Message.Channel as ChannelMsg
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
-- import qualified Sound.MIDI.Parser.Report as Report
import qualified Data.EventList.Relative.TimeMixed as EventListTM
import qualified Data.EventList.Relative.BodyTime as EventListBT
import qualified Data.EventList.Relative.MixedTime as EventListMT
import qualified Data.EventList.Relative.TimeBody as EventList
-- import Data.EventList.Relative.MixedBody ((/.), (./), )
import qualified Data.ByteString.Lazy as B
-- import qualified Numeric.NonNegative.Wrapper as NonNeg
import Data.Tuple.HT (mapFst, )
import qualified Control.Monad.Trans.State as State
import Control.Monad (liftM3, )
g0,a0,b0,c1,cs1,d1,e1,f1,g1,a1,as1 :: VoiceMsg.Pitch
[g0,a0,b0,c1,cs1,d1,e1,f1,g1,a1,as1] =
map VoiceMsg.toPitch [55,57,59,60,61,62,64,65,67,69,70]
melody :: [(VoiceMsg.Pitch, ElapsedTime)]
melody =
let n p t = (VoiceMsg.increasePitch (-12) p, t)
in n g0 3 :
n c1 1 :
n c1 1 :
n c1 1 :
n e1 1 :
n d1 1 :
n c1 1 :
n d1 1 :
n g0 1 :
n g0 1 :
n g0 3 :
n c1 1 :
n c1 1 :
n c1 1 :
n e1 1 :
n d1 1 :
n c1 1 :
n g1 3 :
n e1 3 :
n f1 1 :
n f1 1 :
n f1 1 :
n a1 1 :
n g1 1 :
n f1 1 :
n e1 1 :
n e1 1 :
n e1 1 :
n g1 1 :
n f1 1 :
n e1 1 :
n d1 1 :
n d1 1 :
n d1 1 :
n f1 1 :
n e1 1 :
n d1 1 :
n c1 3 :
[]
melodyEvents ::
[(VoiceMsg.Pitch, ElapsedTime)] -> Int ->
EventListBT.T ElapsedTime Event.T
melodyEvents mel pn =
let chan = ChannelMsg.toChannel 0
vel = VoiceMsg.toVelocity (VoiceMsg.normalVelocity+25)
event =
Event.MIDIEvent .
ChannelMsg.Cons chan .
ChannelMsg.Voice
in EventListBT.fromPairList $
concatMap (\(pgm, (n,t)) ->
[(event $ VoiceMsg.ProgramChange pgm, 0),
(event $ VoiceMsg.NoteOn n vel, t),
(event $ VoiceMsg.NoteOff n vel, 0)]) $
zip (cycle $ map VoiceMsg.toProgram [pn..(pn+4)]) $
concat $ replicate 5 $ mel
solo :: Int -> MidiFile.T
solo pn =
MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 4)
[EventList.cons 0
(Event.MetaEvent $ MetaEvent.SetTempo 1500000) $
EventListTM.switchTimeR const $
EventListMT.consTime 0 $
melodyEvents melody pn]
melody2 :: [(VoiceMsg.Pitch, ElapsedTime)]
melody2 =
let n p t = (p, t)
in n g0 3 :
n c1 1 :
n c1 1 :
n c1 1 :
n e1 1 :
n d1 1 :
n c1 1 :
n d1 1 :
n g0 1 :
n g0 1 :
n g0 3 :
n d1 1 :
n d1 1 :
n d1 1 :
n f1 1 :
n e1 1 :
n d1 1 :
n g1 3 :
n e1 3 :
n f1 1 :
n f1 1 :
n f1 1 :
n a1 1 :
n g1 1 :
n f1 1 :
n e1 1 :
n e1 1 :
n e1 1 :
n g1 1 :
n f1 1 :
n e1 1 :
n d1 1 :
n d1 1 :
n d1 1 :
n f1 1 :
n e1 1 :
n d1 1 :
n c1 3 :
[]
nextProgram :: State.State [VoiceMsg.Program] VoiceMsg.Program
nextProgram = State.state $ \(pgm:pgms) -> (pgm,pgms)
accompEvents :: Int -> EventListBT.T ElapsedTime Event.T
accompEvents pn =
let chan = ChannelMsg.toChannel 0
vel = VoiceMsg.toVelocity (VoiceMsg.normalVelocity-25)
event =
Event.MIDIEvent .
ChannelMsg.Cons chan .
ChannelMsg.Voice
chord ::
VoiceMsg.Pitch ->
(VoiceMsg.Pitch, VoiceMsg.Pitch) ->
State.State [VoiceMsg.Program] [(Event.T, ElapsedTime)]
chord a_ (b_,c_) =
liftM3
(\ pgm0 pgm1 pgm2 ->
let a = VoiceMsg.increasePitch (-12) a_
b = VoiceMsg.increasePitch (-12) b_
c = VoiceMsg.increasePitch (-12) c_
in map (mapFst event) $
(VoiceMsg.ProgramChange pgm0, 0) :
(VoiceMsg.NoteOn a vel, 1) :
(VoiceMsg.NoteOff a vel, 0) :
(VoiceMsg.ProgramChange pgm1, 0) :
(VoiceMsg.NoteOn b vel, 0) :
(VoiceMsg.NoteOn c vel, 1) :
(VoiceMsg.NoteOff b vel, 0) :
(VoiceMsg.NoteOff c vel, 0) :
(VoiceMsg.ProgramChange pgm2, 0) :
(VoiceMsg.NoteOn b vel, 0) :
(VoiceMsg.NoteOn c vel, 1) :
(VoiceMsg.NoteOff b vel, 0) :
(VoiceMsg.NoteOff c vel, 0) :
[])
nextProgram nextProgram nextProgram
introChords =
chord c1 (e1, g1) :
chord g0 (e1, g1) :
chord c1 (e1, g1) :
chord g0 (e1, g1) :
[]
chords =
chord c1 (e1, g1) :
chord g0 (e1, g1) :
chord b0 (d1, g1) :
chord g0 (d1, g1) :
chord b0 (f1, g1) :
chord g0 (f1, g1) :
chord c1 (e1, g1) :
chord g0 (g1, as1) :
chord c1 (f1, a1) :
chord a0 (f1, a1) :
chord c1 (e1, g1) :
chord cs1 (e1, a1) :
chord b0 (d1, g1) :
chord g0 (d1, g1) :
chord c1 (e1, g1) :
chord g0 (e1, g1) :
[]
in EventListBT.fromPairList $
concat $ State.evalState
(sequence $ concat $ introChords : replicate 5 chords) $
cycle $ map VoiceMsg.toProgram [pn..(pn+4)]
song :: Int -> Int -> MidiFile.T
song pna pnm =
MidiFile.Cons MidiFile.Parallel (MidiFile.Ticks 4)
[EventList.cons 0
(Event.MetaEvent $ MetaEvent.SetTempo 1500000) $
let tb t =
EventListTM.switchTimeR const .
EventListMT.consTime t
in EventList.mergeBy (\ _ _ -> True)
(tb 0 $ accompEvents pna) (tb 9 $ melodyEvents melody2 pnm)]
main :: IO ()
main =
B.writeFile "tomatosalad.mid" (Save.toByteString (solo 16)) >>
B.writeFile "hal.mid" (Save.toByteString (solo 21)) >>
B.writeFile "graphtheory.mid" (Save.toByteString (solo 26)) >>
B.writeFile "haltomato.mid" (Save.toByteString (song 16 21))