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.Clef as T
import qualified Music.Theory.Duration as T
import qualified Music.Theory.Duration.RQ as T
import qualified Music.Theory.Dynamic_Mark as T
import qualified Music.Theory.Key as T
import qualified Music.Theory.Pitch as T
import qualified Music.Theory.Time_Signature as T
import qualified Music.Theory.Tempo_Marking as T
import qualified Text.XML.Light as X
x_clef_t :: T.Clef_T -> (String,Integer)
x_clef_t c =
case c of
T.Treble -> ("G",2)
T.Alto -> ("C",3)
T.Tenor -> ("C",4)
T.Bass -> ("F",4)
T.Percussion -> ("percussion",3)
x_clef :: T.Clef Integer -> Integer -> X.Content
x_clef (T.Clef c i) n =
let (s,l) = x_clef_t c
a = [number (show n)]
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' = fromMaybe T.Natural a
in key [] [fifths [] [cdata (show (T.key_fifths (n,a',m)))]
,mode [] [cdata (key_mode_t m)]]
x_time :: T.Time_Signature -> 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::Double))]
,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_t :: Ornament_T -> X.Content
x_ornament_t = mk_empty_elem_no_attr . map c_hs_to_xml . show
x_ornament :: N_Annotation -> Maybe X.Content
x_ornament x =
case x of
N_Ornament d -> Just (x_ornament_t d)
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_font_style :: Font_Style_T -> String
x_font_style st =
case st of
Font_Style_Normal -> "normal"
Font_Style_Italic -> "italic"
x_font_weight :: Font_Weight_T -> String
x_font_weight wh =
case wh of
Font_Weight_Normal -> "normal"
Font_Weight_Bold -> "bold"
x_font_attr :: Maybe Font_T -> [X.Attr]
x_font_attr =
let f (Font fm st sz wh) =
[font_family fm
,font_style (x_font_style st)
,font_size (show sz)
,font_weight (x_font_weight wh)]
in maybe [] f
x_technical_el :: N_Annotation -> Maybe X.Content
x_technical_el x =
case x of
N_Technical t ->
Just (case t of
Up_Bow -> up_bow []
Down_Bow -> down_bow []
Open_String -> open_string []
Stopped -> stopped []
Snap_Pizzicato -> snap_pizzicato []
Harmonic Artifical_Harmonic -> harmonic [] [artificial []]
Harmonic Natural_Harmonic -> harmonic [] [natural []]
Other_Technical f s -> other_technical (x_font_attr f) s
)
_ -> 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
c_underscore_to_hyphen :: Char -> Char
c_underscore_to_hyphen x = if x == '_' then '-' else x
c_hs_to_xml :: Char -> Char
c_hs_to_xml = toLower . c_underscore_to_hyphen
x_articulation_t :: Articulation_T -> X.Content
x_articulation_t = mk_empty_elem_no_attr . map c_hs_to_xml . 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 :: T.Dynamic_Mark_T -> X.Content
x_dynamic_mark_t = mk_empty_elem_no_attr . map toLower . show
x_notation :: N_Annotation -> Maybe X.Content
x_notation x =
case x of
N_Begin_Tied -> Just (tied [type_A "start"])
N_End_Tied -> Just (tied [type_A "stop"])
N_Begin_Slur -> Just (slur [type_A "start"])
N_End_Slur -> Just (slur [type_A "stop"])
N_Begin_Tuplet t -> Just (tuplet [type_A "start"] (x_tuplet_t t))
N_End_Tuplet -> Just (tuplet [type_A "stop"] [])
N_Begin_Glissando -> Just (glissando [type_A "start"] [])
N_End_Glissando -> Just (glissando [type_A "stop"] [])
N_Begin_Slide -> Just (slide [type_A "start"] [])
N_End_Slide -> Just (slide [type_A "stop"] [])
N_Fermata -> Just (fermata [] [])
N_Arpeggiate -> Just (arpeggiate [])
_ -> 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
]
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 :: T.Tempo_Marking -> 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_pedal_type :: Pedal_T -> X.Attr
x_pedal_type t =
let n = case t of
Pedal_Start -> "start"
Pedal_Stop -> "stop"
Pedal_Continue -> "continue"
Pedal_Change -> "change"
in type_A n
dynamic_mark_to_sound_value :: T.Dynamic_Mark_T -> Maybe Double
dynamic_mark_to_sound_value = fmap (* (10 / 9)) . T.dynamic_mark_midi
x_direction :: Direction_T -> Maybe X.Content
x_direction x =
case x of
D_Dynamic_Mark mk ->
let ty = direction_type [] [dynamics [] [x_dynamic_mark_t mk]]
sn = fmap (x_sound . Sound_Dynamics) (dynamic_mark_to_sound_value mk)
el = maybe [ty] ((ty :) . return) sn
in Just (direction [x_placement_t Below] el)
D_Hairpin T.Crescendo ->
let ty = direction_type [] [wedge [type_A "crescendo"]]
in Just (direction [x_placement_t Below] [ty])
D_Hairpin T.Diminuendo ->
let ty = direction_type [] [wedge [type_A "diminuendo"]]
in Just (direction [x_placement_t Below] [ty])
D_Hairpin T.End_Hairpin ->
let ty = direction_type [] [wedge [type_A "stop"]]
in Just (direction [x_placement_t Below] [ty])
D_Laissez_Vibrer ->
let ty = direction_type [] [words' [] [cdata "l.v."]]
in Just (direction [x_placement_t Above] [ty])
D_Pedal pt _ _ ->
let ty = direction_type [] [pedal [x_pedal_type pt]]
in Just (direction [x_placement_t Below] [ty])
D_Tempo_Marking m ->
let ty = direction_type [] [x_metronome m]
in Just (direction [x_placement_t Above] [ty])
x_n_direction :: N_Annotation -> Maybe X.Content
x_n_direction x =
case x of
N_Direction d -> x_direction d
_ -> Nothing
x_m_direction :: M_Annotation -> Maybe X.Content
x_m_direction x =
case x of
M_Direction d -> x_direction d
_ -> Nothing
x_sound :: Sound_T -> X.Content
x_sound s =
case s of
Sound_Tempo n -> sound [tempo (show n)] []
Sound_Dynamics n -> sound [dynamics' (show n)] []
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_notehead_t :: Notehead_T -> [X.Content]
x_notehead_t h =
let s = case h of
Notehead_Triangle -> "triangle"
Notehead_Diamond -> "diamond"
Notehead_Square -> "square"
Notehead_Cross -> "cross"
in [cdata s]
x_notehead :: [N_Annotation] -> [X.Content]
x_notehead =
let fn x = case x of
N_Notehead h -> Just (notehead [] (x_notehead_t h))
_ -> Nothing
in mapMaybe fn
x_staff :: [N_Annotation] -> [X.Content]
x_staff =
let fn x = case x of
N_Staff n -> Just (staff [] n)
_ -> Nothing
in mapMaybe fn
x_beam_t :: Beam_T -> [X.Content]
x_beam_t b =
let s = case b of
Beam_Begin -> "begin"
Beam_Continue -> "continue"
Beam_End -> "end"
in [cdata s]
x_beam :: [N_Annotation] -> [X.Content]
x_beam =
let fn x = case x of
N_Beam i j -> Just (beam [number (show i)] (x_beam_t j))
_ -> 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
bm = x_beam xs
nh = x_notehead xs
st = x_staff xs
n = note [] (concat [es,[d'],vc,ty_dt,ac,m',nh,st,bm,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 n -> Just (x_clef c n)
M_Key n a m -> Just (x_key (n,a,m))
M_Time_Signature i -> Just (x_time i)
M_Staves n -> Just (staves [] n)
M_Direction _ -> 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 "hts: set_divisions: no measures?"
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'] (zipWith (curry x_measure) [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 =
unlines [musicxml_xml
,musicxml_partwise
,X.ppElement (score_partwise' [] xs)]