music-score-1.6: src/Music/Score/Export/Midi.hs
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-------------------------------------------------------------------------------------
-- |
-- Copyright : (c) Hans Hoglund 2012
--
-- License : BSD-style
--
-- Maintainer : hans@hanshoglund.se
-- Stability : experimental
-- Portability : non-portable (TF,GNTD)
--
-------------------------------------------------------------------------------------
module Music.Score.Export.Midi (
HasMidi(..),
HasMidiPart,
HasMidiProgram(..),
toMidi,
toMidiTrack,
writeMidi,
-- playMidi,
playMidiIO,
) where
import Prelude hiding (concat, concatMap, foldl,
foldr, mapM, maximum, minimum, sum)
import Control.Applicative
import Control.Arrow
import Control.Lens hiding ((|>))
import Control.Monad hiding (mapM)
import Control.Monad.Plus
import Data.AffineSpace
import Data.AffineSpace.Point
import Data.Basis
import Data.Either
import Data.Foldable
import Data.Function (on)
import Data.Maybe
import Data.Ord (comparing)
import Data.Ratio
import Data.Semigroup
import Data.String
import Data.Traversable
import Data.Typeable
import Data.VectorSpace
import Codec.Midi hiding (Track)
-- import Control.Reactive hiding (Event)
-- import qualified Control.Reactive as R
-- import Control.Reactive.Midi
import Music.Dynamics.Literal
import Music.Pitch.Literal
import Music.Score.Articulation
import Music.Score.Chord
import Music.Score.Combinators
import Music.Score.Dynamics
import Music.Score.Export.Common
import Music.Score.Ornaments
import Music.Score.Part
import Music.Score.Pitch
import Music.Score.Rhythm
import Music.Score.Score
import Music.Score.Ties
import Music.Score.Track
import Music.Score.Voice
import Music.Time
import qualified Codec.Midi as Midi
import qualified Data.List as List
import qualified Data.Map as Map
import qualified Music.Lilypond as Lilypond
import qualified Music.MusicXml.Simple as Xml
import qualified Text.Pretty as Pretty
-- | Class of types with MIDI-compatible parts.
type HasMidiPart a = (HasPart' a, HasMidiProgram (Part a))
-- | Class of part types with an associated MIDI program number.
class HasMidiProgram a where
getMidiChannel :: a -> Midi.Channel
getMidiProgram :: a -> Midi.Preset
getMidiChannel _ = 0
instance HasMidiProgram () where
getMidiProgram _ = 0
instance HasMidiProgram Double where
getMidiProgram = fromIntegral . floor
instance HasMidiProgram Float where
getMidiProgram = fromIntegral . floor
instance HasMidiProgram Int where
getMidiProgram = id
instance HasMidiProgram Integer where
getMidiProgram = fromIntegral
instance (Integral a, HasMidiProgram a) => HasMidiProgram (Ratio a) where
getMidiProgram = fromIntegral . floor
-- |
-- Class of types that can be converted to MIDI.
--
-- Numeric types are interpreted as notes with a default velocity, pairs are
-- interpreted as @(pitch, velocity)@ pairs.
--
-- Minimal definition: 'getMidi'. Given 'getMidiScore', 'getMidi' can be implemented
-- as @getMidiScore . return@.
--
class HasMidi a where
-- | Convert a value to a MIDI score.
-- Typically, generates an /on/ event using 'note' followed by an optional /off/ event.
getMidi :: a -> Score Midi.Message
-- | Convert a score to a MIDI score.
-- The default definition can be overriden for efficiency.
getMidiScore :: Score a -> Score Midi.Message
getMidiScore = (>>= getMidi)
instance HasMidi (Integer, Integer) where
getMidi (p,v) = mempty
|> return (Midi.NoteOn 0 (fromIntegral p) (fromIntegral v))
|> return (Midi.NoteOff 0 (fromIntegral p) (fromIntegral v))
instance HasMidi Midi.Message where getMidi = return
instance HasMidi Int where getMidi = getMidi . toInteger
instance HasMidi Float where getMidi = getMidi . toInteger . round
instance HasMidi Double where getMidi = getMidi . toInteger . round
instance Integral a => HasMidi (Ratio a) where getMidi = getMidi . toInteger . round
instance HasMidi a => HasMidi (Maybe a) where getMidi = getMidiScore . mfromMaybe
instance HasMidi Integer where getMidi x = getMidi (x,100::Integer)
instance HasMidi a => HasMidi (PartT n a) where
getMidi (PartT (_,a)) = getMidi a
instance HasMidi a => HasMidi (ChordT a) where
getMidi = pcat . fmap getMidi . getChordT
instance HasMidi a => HasMidi (TieT a) where
getMidi (TieT (_,a)) = getMidi a
instance HasMidi a => HasMidi (DynamicT a) where
getMidi (DynamicT (_,a)) = getMidi a
instance HasMidi a => HasMidi (ArticulationT a) where
getMidi (ArticulationT (_,a)) = getMidi a
instance HasMidi a => HasMidi (TremoloT a) where
getMidi (TremoloT (_,a)) = getMidi a
instance HasMidi a => HasMidi (TextT a) where
getMidi (TextT (_,a)) = getMidi a
instance HasMidi a => HasMidi (HarmonicT a) where
getMidi (HarmonicT (_,a)) = getMidi a
instance HasMidi a => HasMidi (SlideT a) where
getMidi (SlideT (_,a)) = getMidi a
instance HasMidi a => HasMidi (Behavior a) where
getMidi = getMidi . (? 0)
-- |
-- Convert a score to a MIDI file representation.
--
toMidi :: forall a . (HasMidiPart a, HasMidi a) => Score a -> Midi.Midi
toMidi score = Midi.Midi fileType divisions' (controlTrack : eventTracks)
where
-- Each track needs TrackEnd
-- We place it long after last event just in case (necessary?)
endDelta = 10000
fileType = Midi.MultiTrack
divisions = 1024
divisions' = Midi.TicksPerBeat divisions
controlTrack = [(0, Midi.TempoChange 1000000), (endDelta, Midi.TrackEnd)]
eventTracks = fmap ((<> [(endDelta, Midi.TrackEnd)]) . uncurry setProgramChannel . second scoreToMTrack)
$ extractParts' score
setProgramChannel :: Part a -> Midi.Track Midi.Ticks -> Midi.Track Midi.Ticks
setProgramChannel p = ([(0, Midi.ProgramChange ch prg)] <>) . fmap (fmap (setChannel ch))
where
ch = getMidiChannel p
prg = getMidiProgram p
scoreToMTrack :: Score a -> Midi.Track Midi.Ticks
scoreToMTrack = fmap (\(t,_,x) -> (round ((t.-. origin) ^* divisions), x)) . toRelative . (^. events) . getMidiScore
-- TODO render voices separately
-- |
-- Convert a score to a track of MIDI messages.
--
toMidiTrack :: HasMidi a => Score a -> Track Message
toMidiTrack = (^. track) . fmap (\(t,_,m) -> (t, m)) . (^. events) . getMidiScore
-- |
-- Convert a score MIDI and write to a file.
--
writeMidi :: (HasMidiPart a, HasMidi a) => FilePath -> Score a -> IO ()
writeMidi path sc = Midi.exportFile path (toMidi sc)
playMidiIO :: HasMidi a => String -> Score a -> IO ()
playMidiIO = error "playMidiIO: Not implemented"
{-
-- |
-- Convert a score to a MIDI event.
--
playMidi :: HasMidi a => String -> Score a -> R.Event MidiMessage
playMidi dest x = midiOut midiDest $ playback trig (pure $ toTrack $ startAt 0.2 x)
where
-- trig = accumR 0 ((+ 0.005) <$ pulse 0.005)
trig = time
toTrack = fmap (\(t,_,m) -> (t .-. origin, m)) . (^. events) . getMidiScore
midiDest = fromJust $ unsafeGetReactive (findDestination $ pure dest)
-- |
-- Convert a score to a MIDI event and run it.
--
playMidiIO :: HasMidi a => String -> Score a -> IO ()
playMidiIO dest = runLoop . playMidi dest
-}
setChannel :: Midi.Channel -> Midi.Message -> Midi.Message
setChannel c = go
where
go (NoteOff _ k v) = NoteOff c k v
go (NoteOn _ k v) = NoteOn c k v
go (KeyPressure _ k v) = KeyPressure c k v
go (ControlChange _ n v) = ControlChange c n v
go (ProgramChange _ p) = ProgramChange c p
go (ChannelPressure _ p) = ChannelPressure c p
go (PitchWheel _ w) = PitchWheel c w
go (ChannelPrefix _) = ChannelPrefix c