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 = [{-number "1"-}] 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) -- due to absurd ordering requirements the duration information -- is collected in three parts (duration,type+dots,multipler) 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 -- note: this requires '_' -> '-' translation 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 -- t = title, n = number, d = dedication, c = composer 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)]