module Music.Typesetting.Output.MusicXML where
import Data.Char
import Data.List
import Data.Maybe
import Data.Ratio
import Music.Typesetting.Model
import Music.Typesetting.Output.MusicXML.Binding
import qualified Music.Theory.Duration as T
import qualified Music.Theory.Key as T
import qualified Music.Theory.Pitch as T
import qualified Text.XML.Light as X
x_clef_t :: Clef_T -> (String,Integer)
x_clef_t c =
case c of
Treble -> ("G",2)
Alto -> ("C",3)
Tenor -> ("C",4)
Bass -> ("F",4)
Percussion -> ("percussion",3)
x_clef :: (Clef_T,Integer) -> X.Content
x_clef (c,i) =
let (s,l) = x_clef_t c
a = []
in clef a [sign [] [cdata s]
,line [] [cdata (show l)]
,clef_octave_change [] [cdata (show i)]]
key_mode_t :: T.Mode_T -> String
key_mode_t md =
case md of
T.Major_Mode -> "major"
T.Minor_Mode -> "minor"
x_key :: (T.Note_T,Maybe T.Alteration_T,T.Mode_T) -> X.Content
x_key (n,a,m) =
let a' = maybe T.Natural id a
in key [] [fifths [] [cdata (show (T.key_fifths (n,a',m)))]
,mode [] [cdata (key_mode_t m)]]
x_time :: (Integer,Integer) -> X.Content
x_time (n,d) = time [] [beats [] [cdata (show n)]
,beat_type [] [cdata (show d)]]
x_pitch :: T.Pitch -> X.Content
x_pitch (T.Pitch n a o) =
pitch [] [step [] [cdata (show n)]
,alter [] [cdata (show (T.alteration_to_fdiff a))]
,octave [] [cdata (show o)]]
x_alteration_t :: T.Alteration_T -> String
x_alteration_t x =
case x of
T.DoubleFlat -> "double-flat"
T.ThreeQuarterToneFlat -> "three-quarters-flat"
T.Flat -> "flat"
T.QuarterToneFlat -> "quarter-flat"
T.Natural -> "natural"
T.QuarterToneSharp -> "quarter-sharp"
T.Sharp -> "sharp"
T.ThreeQuarterToneSharp -> "three-quarters-sharp"
T.DoubleSharp -> "double-sharp"
x_pitch_accidental :: T.Pitch -> X.Content
x_pitch_accidental (T.Pitch _ a _) =
accidental [] [cdata (x_alteration_t a)]
x_multiplier :: Rational -> X.Content
x_multiplier x =
let (n,d) = (numerator x,denominator x)
in time_modification [] [actual_notes [] [cdata (show d)]
,normal_notes [] [cdata (show n)]]
x_divisions :: Integer
x_divisions = 5 * 7 * 8 * 9 * 11 * 12
duration_rq_to_dv :: Rational -> Integer
duration_rq_to_dv x =
let n = x * toRational x_divisions
in if denominator n == 1
then numerator n
else error ("duration_rq_to_dv: non integer duration" ++ show n)
x_duration :: T.Duration -> (X.Content,[X.Content],Maybe X.Content)
x_duration d =
let (T.Duration dv dt m) = d
n = duration_rq_to_dv (T.duration_to_rq d)
ty = T.whole_note_division_to_musicxml_type dv
dt' = genericReplicate dt (dot [])
m' = if m == 1 then Nothing else Just (x_multiplier m)
in (duration [] [cdata (show n)]
,type_E [] [cdata ty] : dt'
,m')
x_tuplet_t_elem :: (Integer, T.Duration) -> [X.Content]
x_tuplet_t_elem (n,d) =
let (T.Duration dv dt _) = d
ty = T.whole_note_division_to_musicxml_type dv
dt' = genericReplicate dt (tuplet_dot [])
in [tuplet_number [] [cdata (show n)]
,tuplet_type [] [cdata ty]] ++ dt'
x_tuplet_t :: Maybe Tuplet_T -> [X.Content]
x_tuplet_t t =
case t of
Nothing -> []
Just (an,ad,nn,nd) ->
let a = x_tuplet_t_elem (an,ad)
n = x_tuplet_t_elem (nn,nd)
in [tuplet_actual [] a,tuplet_normal [] n]
x_ornament :: N_Annotation -> Maybe X.Content
x_ornament x =
case x of
N_Stem_Tremolo i -> Just (tremolo [type_A "single"] [cdata (show i)])
_ -> Nothing
x_ornaments :: [N_Annotation] -> Maybe X.Content
x_ornaments xs =
case mapMaybe x_ornament xs of
[] -> Nothing
xs' -> Just (ornaments [] xs')
x_technical_el :: N_Annotation -> Maybe X.Content
x_technical_el x =
case x of
N_Natural_Harmonic -> Just (harmonic [] [natural []])
_ -> Nothing
x_technical :: [N_Annotation] -> Maybe X.Content
x_technical xs =
case mapMaybe x_technical_el xs of
[] -> Nothing
xs' -> Just (technical [] xs')
x_placement_t :: Placement_T -> X.Attr
x_placement_t = placement . map toLower . show
x_articulation_t :: Articulation_T -> X.Content
x_articulation_t = mk_empty_elem_no_attr . map toLower . show
x_articulation :: N_Annotation -> Maybe X.Content
x_articulation x =
case x of
N_Articulation d -> Just (x_articulation_t d)
_ -> Nothing
x_articulations :: [N_Annotation] -> Maybe X.Content
x_articulations xs =
case mapMaybe x_articulation xs of
[] -> Nothing
xs' -> Just (articulations [] xs')
x_dynamic_mark_t :: Dynamic_Mark_T -> X.Content
x_dynamic_mark_t = mk_empty_elem_no_attr . map toLower . show
x_dynamic_mark :: N_Annotation -> Maybe X.Content
x_dynamic_mark x =
case x of
N_Dynamic_Mark d -> Just (x_dynamic_mark_t d)
_ -> Nothing
x_dynamics :: [N_Annotation] -> Maybe X.Content
x_dynamics xs =
case mapMaybe x_dynamic_mark xs of
[] -> Nothing
xs' -> Just (dynamics [x_placement_t Below] xs')
x_notation :: N_Annotation -> Maybe X.Content
x_notation x =
case x of
N_Begin_Slur -> Just (slur [type_A "start"])
N_End_Slur -> Just (slur [type_A "stop"])
N_Begin_Tied -> Just (tied [type_A "start"])
N_End_Tied -> Just (tied [type_A "stop"])
N_Begin_Tuplet t -> Just (tuplet [type_A "start"] (x_tuplet_t t))
N_End_Tuplet -> Just (tuplet [type_A "stop"] [])
_ -> Nothing
x_notations :: [N_Annotation] -> Maybe X.Content
x_notations xs =
let n = mapMaybe x_notation xs
o = catMaybes [x_ornaments xs
,x_technical xs
,x_articulations xs
,x_dynamics xs]
in case n ++ o of
[] -> Nothing
xs' -> Just (notations [] xs')
x_note_elem :: N_Annotation -> Maybe X.Content
x_note_elem x =
case x of
N_Pitch p -> Just (x_pitch p)
N_Rest -> Just (rest [] [])
N_Grace -> Just (grace [])
N_Chord -> Just (chord [])
_ -> Nothing
x_metronome :: Tempo_Marking_T -> X.Content
x_metronome (d,n) =
let (T.Duration dv dt _) = d
ty = T.whole_note_division_to_musicxml_type dv
dt' = genericReplicate dt (dot [])
n' = per_minute [] [cdata (show n)]
in metronome [] ((beat_unit [] [cdata ty] : dt') ++ [n'])
x_n_direction :: N_Annotation -> Maybe X.Content
x_n_direction x =
case x of
N_Crescendo ->
let ty = direction_type [] [wedge [type_A "crescendo"]]
in Just (direction [x_placement_t Below] [ty])
N_Diminuendo ->
let ty = direction_type [] [wedge [type_A "diminuendo"]]
in Just (direction [x_placement_t Below] [ty])
N_End_Hairpin ->
let ty = direction_type [] [wedge [type_A "stop"]]
in Just (direction [x_placement_t Below] [ty])
_ -> Nothing
x_m_direction :: M_Annotation -> Maybe X.Content
x_m_direction x =
case x of
M_Tempo_Marking m -> Just (x_metronome m)
_ -> Nothing
x_accidental :: [N_Annotation] -> [X.Content]
x_accidental =
let fn x = case x of
N_Pitch p -> Just (x_pitch_accidental p)
_ -> Nothing
in mapMaybe fn
x_voice :: [N_Annotation] -> [X.Content]
x_voice =
let fn x = case x of
N_Voice i -> Just (voice [] [cdata (show i)])
_ -> Nothing
in mapMaybe fn
x_note :: Note -> [X.Content]
x_note (Note d xs) =
let (d',ty_dt,m) = x_duration d
xs' = sort xs
es = mapMaybe x_note_elem xs'
nt = catMaybes [x_notations xs]
dr = mapMaybe x_n_direction xs
ac = x_accidental xs
vc = x_voice xs
m' = maybe [] return m
n = note [] (es ++ [d'] ++ vc ++ ty_dt ++ ac ++ m' ++ nt)
in dr ++ [n]
x_attribute :: M_Annotation -> Maybe X.Content
x_attribute x =
case x of
M_Division i -> Just (divisions [] [cdata (show i)])
M_Clef c i -> Just (x_clef (c,i))
M_Key n a m -> Just (x_key (n,a,m))
M_Time_Signature i -> Just (x_time i)
M_Tempo_Marking _ -> Nothing
x_attributes :: [M_Annotation] -> X.Content
x_attributes xs = attributes [] (mapMaybe x_attribute xs)
x_measure :: (Integer,Measure) -> X.Content
x_measure (i,Measure as ns) =
let as' = sort as
a = x_attributes as'
dr = mapMaybe x_m_direction as'
ns' = concatMap x_note ns
in measure [number (show i)] (a : dr ++ ns')
set_divisions :: [Measure] -> [Measure]
set_divisions xs =
case xs of
[] -> error "set_divisions"
Measure as ms : xs' -> Measure (M_Division x_divisions : as) ms : xs'
x_part_name :: Name -> [X.Content]
x_part_name (nm,ab) = [part_name [] [cdata nm]
,part_abbreviation [] [cdata ab]]
x_p_annotation :: P_Annotation -> [X.Content]
x_p_annotation x =
case x of
P_Name nm -> x_part_name nm
x_score_part :: Part -> X.Content
x_score_part p =
case p of
(Part (Just i) as _) ->
let as' = concatMap x_p_annotation as
i' = "P" ++ show i
in score_part [id_A i'] as'
_ -> error "x_score_part: no ID or GROUP"
x_group_name :: Name -> [X.Content]
x_group_name (nm,ab) = [group_name [] [cdata nm]
,group_abbreviation [] [cdata ab]]
x_group_symbol_t :: Group_Symbol_T -> X.Content
x_group_symbol_t x =
let x' = map toLower (show x)
in group_symbol [] [cdata x']
x_g_annotation :: G_Annotation -> [X.Content]
x_g_annotation x =
case x of
G_Name nm -> x_group_name nm
G_Symbol sy -> [x_group_symbol_t sy]
x_part_group :: Part -> [X.Content]
x_part_group g =
case g of
Group (Just i) as ps ->
let as' = concatMap x_g_annotation as
i' = show i
st = part_group [type_A "start",number i'] as'
en = part_group [type_A "stop",number i'] []
in [st] ++ map x_score_part ps ++ [en]
_ -> error "x_part_group: no ID or PART"
x_part_list :: [Part] -> X.Content
x_part_list =
let fn x = case x of
(Part _ _ _) -> [x_score_part x]
(Group _ _ _) -> x_part_group x
in part_list [] . concatMap fn
x_part :: Part -> X.Content
x_part p =
case p of
(Part (Just i) _ ms) ->
let i' = "P" ++ show i
ms' = set_divisions ms
in part [id_A i'] (map x_measure (zip [1..] ms'))
_ -> error "x_part: no ID or GROUP"
part_set_id :: (ID,Part) -> (ID,Part)
part_set_id (i,x) =
case x of
(Part Nothing pa vs) -> (i+1,Part (Just i) pa vs)
(Group Nothing ga ps) ->
let (i',ps') = mapAccumL (curry part_set_id) (i+1) ps
in (i',Group (Just i) ga ps')
_ -> error "part_set_id: has ID"
score_set_ids :: Score -> Score
score_set_ids (Score xs) =
let (_,xs') = mapAccumL (curry part_set_id) 0 xs
in Score xs'
x_score :: Score -> [X.Content]
x_score s =
let (Score xs) = score_set_ids s
pl = x_part_list xs
f x = case x of
(Part _ _ _) -> [x]
(Group _ _ ps) -> ps
pt = map x_part (concatMap f xs)
in pl : pt
x_header :: (String,String,String,String) -> [X.Content]
x_header (t,n,d,c) =
let t' = work_title [] [cdata t]
n' = work_number [] [cdata n]
c' = creator [type_A "composer"] [cdata c]
d' = credit_words [] [cdata d]
in [work [] [n',t']
,identification [] [c']
,credit [] [d']]
score_partwise' :: [X.Attr] -> [X.Content] -> X.Element
score_partwise' z e = X.Element (X.unqual "score-partwise") z e Nothing
renderMusicXML :: [X.Content] -> String
renderMusicXML xs =
concat [musicxml_xml
,musicxml_partwise
,X.showElement (score_partwise' [] xs)]