module Music.Score.Export.MusicXml (
XmlScore,
XmlMusic,
HasMusicXml(..),
toXml,
writeXml,
openXml,
toXmlVoice,
toXmlSingle,
writeXmlSingle,
openXmlSingle,
) where
import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)
import Data.Semigroup
import Data.Ratio
import Data.String
import Control.Applicative
import Control.Monad hiding (mapM)
import Control.Monad.Plus
import Data.Maybe
import Data.Either
import Data.Foldable
import Data.Typeable
import Data.Traversable
import Data.Function (on)
import Data.Ord (comparing)
import Data.VectorSpace
import Data.AffineSpace
import Data.Basis
import Music.Time
import Music.Pitch.Literal
import Music.Dynamics.Literal
import Music.Score.Rhythm
import Music.Score.Track
import Music.Score.Voice
import Music.Score.Score
import Music.Score.Combinators
import Music.Score.Zip
import Music.Score.Pitch
import Music.Score.Ties
import Music.Score.Part
import Music.Score.Articulation
import Music.Score.Dynamics
import Music.Score.Ornaments
import Music.Score.Instances
import Music.Score.Export.Util
import qualified Codec.Midi as Midi
import qualified Music.MusicXml.Simple as Xml
import qualified Music.Lilypond as Lilypond
import qualified Text.Pretty as Pretty
import qualified Data.Map as Map
import qualified Data.List as List
type XmlScore = Xml.Score
type XmlMusic = Xml.Music
class Tiable a => HasMusicXml a where
getMusicXml :: DurationT -> a -> XmlMusic
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 p = Xml.note (spellXml (fromIntegral p)) . fromDurationT $ d
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 (ta,x,tb)) = 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 (ec,ed,l,a,bc,bd)) = 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 lvl -> Xml.dynamic (fromDynamics (DynamicsL (Just lvl, Nothing)))
instance HasMusicXml a => HasMusicXml (ArticulationT a) where
getMusicXml d (ArticulationT (es,us,al,sl,a,bs)) = 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 (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 (n,x)) = notate $ getMusicXml d x
where
notate | n /= 0 = Xml.setNoteHead Xml.DiamondNoteHead
|otherwise = id
instance HasMusicXml a => HasMusicXml (SlideT a) where
getMusicXml d (SlideT (eg,es,a,bg,bs)) = notate $getMusicXml d a
where
notate = neg . nes . nbg . nbs
neg = if es then Xml.endGliss else id
nes = if es then Xml.endSlide else id
nbg = if es then Xml.beginGliss else id
nbs = if es then Xml.beginSlide else id
writeXml :: (HasMusicXml a, HasPart' a, Show (Part a)) => FilePath -> Score a -> IO ()
writeXml path sc = writeFile path (Xml.showXml $ toXml sc)
openXml :: (HasMusicXml a, HasPart' a, Show (Part a)) => Score a -> IO ()
openXml sc = do
writeXml "test.xml" sc
execute "open" ["-a", "/Applications/Sibelius 6.app/Contents/MacOS/Sibelius 6", "test.xml"]
writeXmlSingle :: HasMusicXml a => FilePath -> Score a -> IO ()
writeXmlSingle path sc = writeFile path (Xml.showXml $ toXmlSingle sc)
openXmlSingle :: HasMusicXml a => Score a -> IO ()
openXmlSingle sc = do
writeXmlSingle "test.xml" sc
execute "open" ["-a", "/Applications/Sibelius 6.app/Contents/MacOS/Sibelius 6", "test.xml"]
toXml :: (HasMusicXml a, HasPart' a, Show (Part a)) => Score a -> XmlScore
toXml sc = Xml.fromParts "Title" "Composer" pl . fmap (toXmlVoice' . scoreToVoice) . extract $ sc
where
pl = Xml.partList (fmap show $ getParts sc)
toXmlSingle :: HasMusicXml a => Score a -> XmlScore
toXmlSingle = toXmlVoice . scoreToVoice
toXmlVoice :: HasMusicXml a => Voice (Maybe a) -> XmlScore
toXmlVoice = Xml.fromPart "Title" "Composer" "Voice" . toXmlVoice'
toXmlVoice' :: HasMusicXml a => Voice (Maybe a) -> [XmlMusic]
toXmlVoice' =
addDefaultSignatures . fmap barToXml . voiceToBars
where
addDefaultSignatures [] = []
addDefaultSignatures (x:xs) = (defaultSignatures <> x):xs
defaultSignatures = mempty
<> Xml.defaultKey
<> Xml.defaultDivisions
<> Xml.metronome (1/4) 60
<> Xml.commonTime
barToXml :: HasMusicXml a => [(DurationT, Maybe a)] -> Xml.Music
barToXml bar = case quantize bar of
Left e -> error $ "barToXml: Could not quantize this bar: " ++ show e
Right rh -> rhythmToXml rh
rhythmToXml :: HasMusicXml a => Rhythm (Maybe a) -> Xml.Music
rhythmToXml (Beat d x) = noteRestToXml d x
rhythmToXml (Group rs) = mconcat $ map rhythmToXml rs
rhythmToXml (Dotted n (Beat d x)) = noteRestToXml (dotMod n * d) x
rhythmToXml (Tuplet m r) = Xml.tuplet b a (rhythmToXml r)
where (a,b) = both fromIntegral fromIntegral $ unRatio $ fromDurationT m
noteRestToXml :: HasMusicXml a => DurationT -> Maybe a -> Xml.Music
noteRestToXml d Nothing = setDefaultVoice $ Xml.rest $ fromDurationT d
noteRestToXml d (Just p) = setDefaultVoice $ getMusicXml d p
setDefaultVoice :: Xml.Music -> Xml.Music
setDefaultVoice = Xml.setVoice 1
spellXml :: Integer -> Xml.Pitch
spellXml p = (
toEnum $ fromIntegral pc,
if alt == 0 then Nothing else Just (fromIntegral alt),
fromIntegral oct
)
where (pc,alt,oct) = spellPitch p