music-score-1.6: src/Music/Score/Export/MusicXml.hs
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
-------------------------------------------------------------------------------------
-- |
-- Copyright : (c) Hans Hoglund 2012
--
-- License : BSD-style
--
-- Maintainer : hans@hanshoglund.se
-- Stability : experimental
-- Portability : non-portable (TF,GNTD)
--
-------------------------------------------------------------------------------------
module Music.Score.Export.MusicXml (
XmlScore,
XmlMusic,
HasMusicXml(..),
toMusicXml,
toMusicXmlString,
showMusicXml,
openMusicXml,
writeMusicXml,
) where
import Prelude hiding (concat, concatMap, foldl,
foldr, mapM, maximum, minimum,
sum)
import Control.Applicative
import Control.Arrow
import Control.Lens hiding (rewrite)
import Control.Monad hiding (mapM)
import Data.Function (on)
import Data.Maybe
import Data.Monoid.WithSemigroup
import Data.Ord (comparing)
import Data.Ratio
import Data.Semigroup
import Data.String
import System.Process
import Music.Dynamics.Literal
import Music.Pitch.Literal
import Music.Score.Articulation
import Music.Score.Chord
import Music.Score.Clef
import Music.Score.Combinators
import Music.Score.Convert
import Music.Score.Convert
import Music.Score.Dynamics
import Music.Score.Export.Common
import Music.Score.Instances
import Music.Score.Meta
import Music.Score.Meta.Attribution
import Music.Score.Meta.Clef
import Music.Score.Meta.Time
import Music.Score.Meta.Title
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.Util
import Music.Score.Voice
import Music.Time
import Music.Time.Reactive (Reactive, initial)
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
type XmlScore = Xml.Score
type XmlMusic = Xml.Music
-- |
-- Class of types that can be converted to MusicXML.
--
class Tiable a => HasMusicXml a where
-- |
-- Convert a value to MusicXML.
--
-- Typically, generates a 'XmlMusic' value using 'Xml.note' or 'Xml.chord', and transforms it
-- to add beams, slurs, dynamics, articulation etc.
--
getMusicXml :: Duration -> a -> XmlMusic
getMusicXmlChord :: Duration -> [a] -> XmlMusic
getMusicXmlChord d = error "getMusicXmlChord: Not implemented"
instance HasMusicXml Int where getMusicXml d = getMusicXml d . toInteger
instance HasMusicXml Float where getMusicXml d = getMusicXml d . toInteger . round
instance HasMusicXml Double where getMusicXml d = getMusicXml d . toInteger . round
instance Integral a => HasMusicXml (Ratio a) where getMusicXml d = getMusicXml d . toInteger . round
instance HasMusicXml Integer where
getMusicXml d = (`Xml.note` realToFrac d) . spellMusicXml . fromIntegral
getMusicXmlChord d = (`Xml.chord` realToFrac d) . fmap (spellMusicXml . fromIntegral)
instance HasMusicXml a => HasMusicXml (ChordT a) where
getMusicXml d = getMusicXmlChord d . getChordT
instance HasMusicXml a => HasMusicXml (PartT n a) where
getMusicXml d (PartT (_,x)) = getMusicXml d x
instance HasMusicXml a => HasMusicXml (TieT a) where
getMusicXml d (TieT ((Any ta,Any tb),x)) = addTies $ getMusicXml d x
where
addTies | ta && tb = Xml.endTie . Xml.beginTie
| tb = Xml.beginTie
| ta = Xml.endTie
| otherwise = id
instance HasMusicXml a => HasMusicXml (DynamicT a) where
getMusicXml d (DynamicT (((Any ec,Any ed),Option l,(Any bc,Any bd)), a)) = notate $ getMusicXml d a
where
notate x = nec <> ned <> nl <> nbc <> nbd <> x
nec = if ec then Xml.endCresc else mempty
ned = if ed then Xml.endDim else mempty
nbc = if bc then Xml.beginCresc else mempty
nbd = if bd then Xml.beginDim else mempty
nl = case l of
Nothing -> mempty
Just (First lvl) -> Xml.dynamic (fromDynamics (DynamicsL (Just lvl, Nothing)))
instance HasMusicXml a => HasMusicXml (ArticulationT a) where
getMusicXml d (ArticulationT (((Any es, Any us, Any bs), (Sum al, Sum sl)), a)) = notate $ getMusicXml d a
where
notate = nes . nal . nsl . nbs
nes = if es then Xml.endSlur else id
nal = case al of
0 -> id
1 -> Xml.accent
2 -> Xml.strongAccent
nsl = case sl of
(-2) -> Xml.tenuto
(-1) -> Xml.tenuto . Xml.staccato
0 -> id
1 -> Xml.staccato
2 -> Xml.staccatissimo
nbs = if bs then Xml.beginSlur else id
instance HasMusicXml a => HasMusicXml (TremoloT a) where
getMusicXml d (TremoloT (Sum n,x)) = notate $ getMusicXml d x
where
notate = case n of
0 -> id
_ -> Xml.tremolo n
instance HasMusicXml a => HasMusicXml (TextT a) where
getMusicXml d (TextT (s,x)) = notate s $ getMusicXml d x
where
notate ts a = mconcat (fmap Xml.text ts) <> a
instance HasMusicXml a => HasMusicXml (HarmonicT a) where
getMusicXml d (HarmonicT ((view _Wrapped' -> isNat, view _Wrapped' -> n),x)) = notate isNat n $ getMusicXml d x
where
notate _ 0 = id
notate True n = notateNatural n
notate False n = notateArtificial n
-- notateNatural n = Xml.harmonic -- openString?
notateNatural n = Xml.setNoteHead Xml.DiamondNoteHead
-- Most programs do not recognize the harmonic tag
-- We set a single diamond notehead instead, which can be manually replaced
notateArtificial n = id -- TODO
-- notate | n /= 0 = Xml.setNoteHead Xml.DiamondNoteHead
-- TODO adjust pitch etc
instance HasMusicXml a => HasMusicXml (SlideT a) where
getMusicXml d (SlideT (((eg,es),(bg,bs)),a)) = notate $ getMusicXml d a
where
notate = neg . nes . nbg . nbs
neg = if view _Wrapped' eg then Xml.endGliss else id
nes = if view _Wrapped' es then Xml.endSlide else id
nbg = if view _Wrapped' bg then Xml.beginGliss else id
nbs = if view _Wrapped' bs then Xml.beginSlide else id
instance HasMusicXml a => HasMusicXml (ClefT a) where
getMusicXml d (ClefT (c, a)) = notate $ getMusicXml d a
where
notate = case fmap getLast $ getOption c of
Nothing -> id
Just GClef -> (Xml.trebleClef <>)
Just CClef -> (Xml.altoClef <>)
Just FClef -> (Xml.bassClef <>)
instance HasMusicXml a => HasMusicXml (Behavior a) where
getMusicXml d = getMusicXml d . (? 0)
-- |
-- Convert a score to MusicXML and write to a file.
--
writeMusicXml :: (HasMusicXml a, HasPart' a, Semigroup a) => FilePath -> Score a -> IO ()
writeMusicXml path sc = writeFile path (Xml.showXml $ toMusicXml sc)
-- |
-- Convert a score to MusicXML and open it.
--
openMusicXml :: (HasMusicXml a, HasPart' a, Semigroup a) => Score a -> IO ()
openMusicXml sc = do
writeMusicXml "test.xml" sc
-- FIXME find out which program to use...
void $ rawSystem "open" ["-a", "Sibelius 7", "test.xml"]
-- -- |
-- -- Convert a score to MusicXML and write to a file.
-- --
-- writeXmlSingle :: HasMusicXml a => FilePath -> Score a -> IO ()
-- writeXmlSingle path sc = writeFile path (Xml.showXml $ toXmlSingle sc)
-- -- |
-- -- Convert a score to MusicXML and open it.
-- --
-- openXmlSingle :: HasMusicXml a => Score a -> IO ()
-- openXmlSingle sc = do
-- writeXmlSingle "test.xml" sc
-- void $ rawSystem "open" ["-a", "/Applications/Sibelius 6.app/Contents/MacOS/Sibelius 6", "test.xml"]
-- |
-- Convert a score to MusicXML and print it on the standard output.
--
showMusicXml :: (HasMusicXml a, HasPart' a, Semigroup a) => Score a -> IO ()
showMusicXml = putStrLn . toMusicXmlString
-- |
-- Convert a score to a MusicXML string.
--
toMusicXmlString :: (HasMusicXml a, HasPart' a, Semigroup a) => Score a -> String
toMusicXmlString = Xml.showXml . toMusicXml
-- |
-- Convert a score to a MusicXML representation.
--
toMusicXml :: (HasMusicXml a, HasPart' a, Semigroup a) => Score a -> XmlScore
toMusicXml sc =
-- Score structure
Xml.fromParts title composer pl
-- Main notation pipeline
. fmap (voiceToMusicXml' barTimeSigs barDurations . scoreToVoice . simultaneous
-- Meta-event expansion
. addClefs
)
. extractParts $ sc
where
addClefT :: a -> ClefT a
addClefT = return
addClefs = setClef . fmap addClefT
setClef = withClef def $ \c x -> applyClef c x where def = GClef -- TODO use part default
timeSigs = getTimeSignatures (time 4 4) sc -- 4/4 is default
timeSigsV = fmap swap $ (^. from voice) $ mergeEqual $ reactiveToVoice' (start <-> offset sc) timeSigs
-- Despite mergeEqual above we need retainUpdates here to prevent redundant repetition of time signatures
barTimeSigs = retainUpdates $ getBarTimeSignatures $ timeSigsV
barDurations = getBarDurations $ timeSigsV
title = fromMaybe "" $ flip getTitleAt 0 $ metaAtStart sc
composer = fromMaybe "" $ flip getAttribution "composer" $ metaAtStart sc
pl = Xml.partList (fmap show $ getParts sc)
mergeBars :: [XmlMusic] -> XmlMusic
mergeBars [x] = x
mergeBars _ = error "mergeBars: Not supported"
-- |
-- Convert a voice score to a list of bars.
--
voiceToMusicXml' :: HasMusicXml a => [Maybe TimeSignature] -> [Duration] -> Voice (Maybe a) -> [XmlMusic]
voiceToMusicXml' barTimeSigs barDurations = addStartInfo . zipWith setBarTimeSig barTimeSigs . fmap barToMusicXml . voiceToBars' barDurations
-- TODO attach key signatures in each bar (basically zip)
--
-- This is where notation of a single voice takes place
-- * voiceToBars is generic for most notations outputs: it handles bar splitting and ties
-- * barToMusicXml is specific: it handles quantization and notation
--
where
-- FIXME compounds
setBarTimeSig Nothing x = x
setBarTimeSig (Just (getTimeSignature -> (m:_, n))) x = Xml.time (fromInteger m) (fromInteger n) <> x
addStartInfo [] = []
addStartInfo (x:xs) = (startInfo <> x):xs
startInfo = mempty
<> Xml.defaultKey
<> Xml.defaultDivisions
<> Xml.metronome (1/4) 60
-- <> Xml.commonTime
-- TODO explicit time sig
barToMusicXml :: HasMusicXml a => [(Duration, Maybe a)] -> XmlMusic
barToMusicXml bar = case (fmap rewrite . quantize) bar of
Left e -> error $ "barToMusicXml: Could not quantize this bar: " ++ show e
Right rh -> rhythmToMusicXml rh
rhythmToMusicXml :: HasMusicXml a => Rhythm (Maybe a) -> XmlMusic
rhythmToMusicXml (Beat d x) = noteRestToMusicXml d x
rhythmToMusicXml (Group rs) = mconcat $ map rhythmToMusicXml rs
rhythmToMusicXml (Dotted n (Beat d x)) = noteRestToMusicXml (dotMod n * d) x
rhythmToMusicXml (Tuplet m r) = Xml.tuplet b a (rhythmToMusicXml r)
where (a,b) = fromIntegral *** fromIntegral $ unRatio $ realToFrac m
noteRestToMusicXml :: HasMusicXml a => Duration -> Maybe a -> XmlMusic
noteRestToMusicXml d Nothing = setDefaultVoice $ Xml.rest $ realToFrac d
noteRestToMusicXml d (Just p) = setDefaultVoice $ getMusicXml d p
setDefaultVoice :: XmlMusic -> XmlMusic
setDefaultVoice = Xml.setVoice 1
spellMusicXml :: Integer -> Xml.Pitch
spellMusicXml p = (
toEnum $ fromIntegral pc,
if alt == 0 then Nothing else Just (fromIntegral alt),
fromIntegral oct
)
where (pc,alt,oct) = spellPitch p