diff --git a/Music/Typesetting/Literal.hs b/Music/Typesetting/Literal.hs new file mode 100644 --- /dev/null +++ b/Music/Typesetting/Literal.hs @@ -0,0 +1,163 @@ +module Music.Typesetting.Literal where + +import Data.List +import Data.Maybe +import Data.Ratio +import Music.Theory.Duration +import Music.Typesetting.Model +import Music.Typesetting.Query + +-- * Functions for writing music by hand. + +n_annotate :: N_Annotation -> Note -> Note +n_annotate a (Note d as) = Note d (a : as) + +(&) :: Note -> N_Annotation -> Note +(&) = flip n_annotate + +annotate_first :: (a -> x -> x) -> a -> [x] -> [x] +annotate_first fn a ns = + case ns of + [] -> [] + (n:ns') -> fn a n : ns' + +annotate_last :: (a -> x -> x) -> a -> [x] -> [x] +annotate_last fn a ns = + case ns of + [] -> [] + [n] -> [fn a n] + (n:ns') -> n : annotate_last fn a ns' + +annotate_bracket :: (a -> x -> x) -> (a,a) -> [x] -> [x] +annotate_bracket fn (a0,an) = annotate_last fn an . annotate_first fn a0 + +n_annotate_l :: [N_Annotation] -> Note -> Note +n_annotate_l as' (Note d as) = Note d (as ++ as') + +n_annotate_first :: [N_Annotation] -> [Note] -> [Note] +n_annotate_first = annotate_first n_annotate_l + +n_annotate_last :: [N_Annotation] -> [Note] -> [Note] +n_annotate_last = annotate_last n_annotate_l + +n_annotate_bracket :: (N_Annotation,N_Annotation) -> [Note] -> [Note] +n_annotate_bracket = annotate_bracket n_annotate + +-- | Apply annotations to the start and end points of each tied note. +n_annotate_tie_endpoints :: (N_Annotation,N_Annotation) -> Note -> Note +n_annotate_tie_endpoints (a0,an) n + | n_is_initial_tie n = n & a0 + | n_is_final_tie n = n &an + | otherwise = n + +n_edit_duration :: (Duration -> Duration) -> Note -> Note +n_edit_duration fn (Note d xs) = Note (fn d) xs + +-- note: ought to set Tuplet_T +tuplet :: (Integer,Integer) -> [Note] -> [Note] +tuplet (d,n) = + let fn x = x { multiplier = n%d } + ann = n_annotate_bracket (N_Begin_Tuplet Nothing,N_End_Tuplet) + in map (n_edit_duration fn) . ann + +m_annotate :: M_Annotation -> Measure -> Measure +m_annotate a (Measure as ns) = Measure (a : as) ns + +(&.) :: Measure -> M_Annotation -> Measure +(&.) = flip m_annotate + +m_annotate_l :: [M_Annotation] -> Measure -> Measure +m_annotate_l as' (Measure as ns) = Measure (as ++ as') ns + +m_annotate_first :: [M_Annotation] -> [Measure] -> [Measure] +m_annotate_first = annotate_first m_annotate_l + +m_annotate_last :: [M_Annotation] -> [Measure] -> [Measure] +m_annotate_last = annotate_last m_annotate_l + +m_annotate_bracket :: (M_Annotation,M_Annotation) -> [Measure] -> [Measure] +m_annotate_bracket = annotate_bracket m_annotate + +m_duration :: Measure -> [Duration] +m_duration (Measure _ ns) = mapMaybe n_duration_forward ns + +m_duration_rq :: Measure -> Rational +m_duration_rq = sum . map duration_to_rq . m_duration + +empty_measure :: (Integer,Integer) -> Measure +empty_measure n = Measure [M_Time_Signature n] [] + +stem_tremolo :: Integer -> Note -> Note +stem_tremolo n (Note d a) = + let x = duration_beam_count d + x' = max 0 (n - x) + in Note d (N_Stem_Tremolo x' : a) + +pppp,ppp,pp,p,mp,mf,f,ff,fff,ffff,fp,sfz :: N_Annotation +pppp = N_Dynamic_Mark PPPP +ppp = N_Dynamic_Mark PPP +pp = N_Dynamic_Mark PP +p = N_Dynamic_Mark P +mp = N_Dynamic_Mark MP +mf = N_Dynamic_Mark MF +f = N_Dynamic_Mark F +ff = N_Dynamic_Mark FF +fff = N_Dynamic_Mark FFF +ffff = N_Dynamic_Mark FFFF +fp = N_Dynamic_Mark FP +sfz = N_Dynamic_Mark SFZ + +cresc,dim :: N_Annotation +cresc = N_Crescendo +dim = N_Diminuendo + +bass_clef,tenor_clef,alto_clef,treble_clef,percussion_clef :: M_Annotation +bass_clef = M_Clef Bass 0 +tenor_clef = M_Clef Tenor 0 +alto_clef = M_Clef Alto 0 +treble_clef = M_Clef Treble 0 +percussion_clef = M_Clef Percussion 0 + +bass_8vb_clef,treble_8va_clef,treble_8vb_clef,treble_15ma_clef :: M_Annotation +bass_8vb_clef = M_Clef Bass (-1) +treble_8va_clef = M_Clef Treble 1 +treble_8vb_clef = M_Clef Treble (-1) +treble_15ma_clef = M_Clef Treble 2 + +accent :: N_Annotation +accent = N_Articulation Accent + +-- * Parts, groups etc. + +part :: Name -> [Measure] -> Part +part nm ms = Part Nothing [P_Name nm] ms + +group :: Name -> [Part] -> Part +group nm ps = Group Nothing [G_Name nm] ps + +-- merge parallel voices +voices :: [[Measure]] -> [Measure] +voices vs = + let vs' = transpose vs + vc_ann :: Integer -> Measure -> Measure + vc_ann i (Measure as ns) = Measure as (map (& (N_Voice i)) ns) + merge_m_ann :: [Measure] -> [M_Annotation] + merge_m_ann = foldl1 union . map m_annotations + fn ms = let (d:_) = map m_duration ms + bu = N_Backup d + ms' = zipWith vc_ann [1..] ms + ns = concatMap (n_annotate_last [bu] . m_notes) ms' + as = merge_m_ann ms + in Measure as ns + in map fn vs' + +-- * Interop + +-- note: ought to translate begin_tuplet correctly +from_d_annotation :: D_Annotation -> N_Annotation +from_d_annotation x = + case x of + Tie_Right -> N_Begin_Tied + Tie_Left -> N_End_Tied + Begin_Tuplet (n,d,i) -> N_Begin_Tuplet (Just (n,i,d,i)) + End_Tuplet -> N_End_Tuplet diff --git a/Music/Typesetting/Model.hs b/Music/Typesetting/Model.hs new file mode 100644 --- /dev/null +++ b/Music/Typesetting/Model.hs @@ -0,0 +1,82 @@ +module Music.Typesetting.Model where + +import Music.Theory.Duration +import Music.Theory.Key +import Music.Theory.Pitch + +data Dynamic_Mark_T = PPPPP | PPPP | PPP | PP | P | MP + | MF | F | FF | FFF | FFFF | FFFFF + | FP | SF | SFP | SFPP | SFZ | SFFZ + deriving (Eq,Ord,Bounded,Show) + +data Articulation_T = Accent + | Staccato + | Tenuto + deriving (Eq,Ord,Show) + +data Clef_T = Bass | Tenor | Alto | Treble | Percussion + deriving (Eq,Ord,Show) + +type Time_Signature_T = (Integer,Integer) + +data Placement_T = Above | Below + deriving (Eq,Ord,Show) + +type Tuplet_T = (Integer,Duration,Integer,Duration) + +type Tempo_Marking_T = (Duration,Integer) + +-- | Ordered to meet musicxml requirements. +data N_Annotation = N_Grace | N_Chord + | N_Pitch Pitch | N_Unpitched + | N_Rest + | N_Begin_Slur | N_End_Slur + | N_Begin_Tied | N_End_Tied + | N_Begin_Tuplet (Maybe Tuplet_T) | N_End_Tuplet + | N_Stem_Tremolo Integer + | N_Articulation Articulation_T + | N_Dynamic_Mark Dynamic_Mark_T + | N_Crescendo | N_Diminuendo | N_End_Hairpin + | N_Voice Integer + | N_Backup [Duration] + | N_Natural_Harmonic + deriving (Eq,Ord,Show) + +data Note = Note {n_duration :: Duration + ,n_annotations :: [N_Annotation]} + deriving (Eq,Show) + +data M_Annotation = M_Division Integer + | M_Key Note_T (Maybe Alteration_T) Mode_T + | M_Tempo_Marking Tempo_Marking_T + | M_Time_Signature Time_Signature_T + | M_Clef Clef_T Integer + deriving (Eq,Ord,Show) + +data Measure = Measure { m_annotations :: [M_Annotation] + , m_notes :: [Note] } + deriving (Eq,Show) + +type Name = (String,String) + +data Group_Symbol_T = None + | Brace + | Line + | Bracket + deriving (Eq,Show) + +data P_Annotation = P_Name Name + deriving (Eq,Show) + +data G_Annotation = G_Name Name + | G_Symbol Group_Symbol_T + deriving (Eq,Show) + +type ID = Integer + +data Part = Part (Maybe ID) [P_Annotation] [Measure] + | Group (Maybe ID) [G_Annotation] [Part] + deriving (Eq,Show) + +data Score = Score [Part] + deriving (Eq,Show) diff --git a/Music/Typesetting/Output/MusicXML.hs b/Music/Typesetting/Output/MusicXML.hs new file mode 100644 --- /dev/null +++ b/Music/Typesetting/Output/MusicXML.hs @@ -0,0 +1,388 @@ +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)] diff --git a/Music/Typesetting/Output/MusicXML/Binding.hs b/Music/Typesetting/Output/MusicXML/Binding.hs new file mode 100644 --- /dev/null +++ b/Music/Typesetting/Output/MusicXML/Binding.hs @@ -0,0 +1,197 @@ +module Music.Typesetting.Output.MusicXML.Binding where + +import qualified Text.XML.Light as X + +type ELEM = [X.Attr] -> [X.Content] -> X.Content +type EMPTY_ELEM = [X.Attr] -> X.Content +type ATTR = String -> X.Attr + +-- | Ordinary character data, subject to escaping. +cdata :: String -> X.Content +cdata s = X.Text (X.CData X.CDataText s Nothing) + +mk_elem :: String -> ELEM +mk_elem nm z e = X.Elem (X.Element (X.unqual nm) z e Nothing) + +mk_empty_elem :: String -> EMPTY_ELEM +mk_empty_elem nm z = X.Elem (X.Element (X.unqual nm) z [] Nothing) + +mk_empty_elem_no_attr :: String -> X.Content +mk_empty_elem_no_attr nm = X.Elem (X.Element (X.unqual nm) [] [] Nothing) + +mk_attr :: String -> ATTR +mk_attr nm = X.Attr (X.unqual nm) + +clef :: ELEM +clef = mk_elem "clef" + +type_A,id_A,number,spread,implicit,slash :: ATTR +type_A = mk_attr "type" +id_A = mk_attr "id" +number = mk_attr "number" +spread = mk_attr "spead" +implicit = mk_attr "implicit" +slash = mk_attr "slash" + +placement,bracket,show_number,show_type :: ATTR +placement = mk_attr "placement" +bracket = mk_attr "bracket" +show_number = mk_attr "show-number" +show_type = mk_attr "show-type" + +direction,direction_type,offset :: ELEM +direction = mk_elem "direction" +direction_type = mk_elem "direction-type" +offset = mk_elem "offset" + +wedge :: EMPTY_ELEM +wedge = mk_empty_elem "wedge" + +sign :: ELEM +sign = mk_elem "sign" + +line :: ELEM +line = mk_elem "line" + +clef_octave_change :: ELEM +clef_octave_change = mk_elem "clef-octave-change" + +score_partwise :: ELEM +score_partwise = mk_elem "score-partwise" + +work,work_number,work_title :: ELEM +work = mk_elem "work" +work_title = mk_elem "work-title" +work_number = mk_elem "work-number" + +identification,creator,rights :: ELEM +identification = mk_elem "identification" +creator = mk_elem "creator" +rights = mk_elem "rights" + +credit,credit_words :: ELEM +credit = mk_elem "credit" +credit_words = mk_elem "credit-words" + +part_list,part_group,score_part :: ELEM +part_list = mk_elem "part-list" +part_group = mk_elem "part-group" +score_part = mk_elem "score-part" + +part_name,part_abbreviation,score_instrument :: ELEM +part_name = mk_elem "part-name" +part_abbreviation = mk_elem "part-abbreviation" +score_instrument = mk_elem "score-instrument" + +group_name,group_abbreviation,group_symbol,group_barline :: ELEM +group_name = mk_elem "group-name" +group_abbreviation = mk_elem "group-abbreviation" +group_symbol = mk_elem "group-symbol" +group_barline = mk_elem "group-barline" + +instrument_name :: ELEM +instrument_name = mk_elem "instrument-name" + +part,measure,attributes,divisions :: ELEM +part = mk_elem "part" +measure = mk_elem "measure" +attributes = mk_elem "attributes" +divisions = mk_elem "divisions" + +key,fifths,mode :: ELEM +key = mk_elem "key" +fifths = mk_elem "fifths" +mode = mk_elem "mode" + +time,beats,beat_type :: ELEM +time = mk_elem "time" +beats = mk_elem "beats" +beat_type = mk_elem "beat-type" + +staves :: ELEM +staves = mk_elem "staves" + +note,pitch,step,alter,octave,rest,duration,voice,type_E,stem,staff,beam,accidental :: ELEM +note = mk_elem "note" +pitch = mk_elem "pitch" +step = mk_elem "step" +alter = mk_elem "alter" +octave = mk_elem "octave" +rest = mk_elem "rest" +duration = mk_elem "duration" +voice = mk_elem "voice" +type_E = mk_elem "type" +stem = mk_elem "stem" +staff = mk_elem "staff" +beam = mk_elem "beam" +accidental = mk_elem "accidental" + +notations,ornaments,technical,dynamics,tremolo :: ELEM +notations = mk_elem "notations" +ornaments = mk_elem "ornaments" +technical = mk_elem "technical" +dynamics = mk_elem "dynamics" +tremolo = mk_elem "tremolo" + +arpeggiate,tie,tied,slur :: EMPTY_ELEM +arpeggiate = mk_empty_elem "arpeggiate" +tie = mk_empty_elem "tie" +tied = mk_empty_elem "tied" +slur = mk_empty_elem "slur" + +harmonic :: ELEM +harmonic = mk_elem "harmonic" + +natural :: EMPTY_ELEM +natural = mk_empty_elem "natural" + +forward,backup :: ELEM +forward = mk_elem "forward" +backup = mk_elem "backup" + +chord,cue,grace,dot :: EMPTY_ELEM +chord = mk_empty_elem "chord" +cue = mk_empty_elem "cue" +grace = mk_empty_elem "grace" +dot = mk_empty_elem "dot" + +time_modification,actual_notes,normal_notes,normal_type,normal_dot :: ELEM +time_modification = mk_elem "time-modification" +actual_notes = mk_elem "actual-notes" +normal_notes = mk_elem "normal-notes" +normal_type = mk_elem "normal-type" +normal_dot = mk_elem "normal-dot" + +tuplet,tuplet_actual,tuplet_normal,tuplet_number,tuplet_type :: ELEM +tuplet = mk_elem "tuplet" +tuplet_actual = mk_elem "tuplet-actual" +tuplet_normal = mk_elem "tuplet-normal" +tuplet_number = mk_elem "tuplet-number" +tuplet_type = mk_elem "tuplet-type" + +tuplet_dot :: EMPTY_ELEM +tuplet_dot = mk_empty_elem "tuplet-dot" + +articulations :: ELEM +articulations = mk_elem "articulations" + +accent :: EMPTY_ELEM +accent = mk_empty_elem "accent" + +metronome,beat_unit,per_minute :: ELEM +metronome = mk_elem "metronome" +beat_unit = mk_elem "beat-unit" +per_minute = mk_elem "per-minute" + +beat_unit_dot :: EMPTY_ELEM +beat_unit_dot = mk_empty_elem "beat-unit-dot" + +-- * String constants + +musicxml_xml :: String +musicxml_xml = "" + +type DocType = String + +musicxml_partwise :: DocType +musicxml_partwise = "" diff --git a/Music/Typesetting/Process.hs b/Music/Typesetting/Process.hs new file mode 100644 --- /dev/null +++ b/Music/Typesetting/Process.hs @@ -0,0 +1,27 @@ +module Music.Typesetting.Process where + +import Data.List +import Music.Typesetting.Model +import Music.Typesetting.Query + +-- delete persistent annotations or like +prune :: (a -> a -> Bool) -> (b -> Maybe a) -> (a -> b -> b) -> [b] -> [b] +prune cmp get del = + let go _ [] = [] + go Nothing (x:xs) = x : go (get x) xs + go (Just st) (x:xs) = + case get x of + Nothing -> x : go (Just st) xs + Just y -> if cmp st y + then del y x : go (Just st) xs + else x : go (Just y) xs + in go Nothing + +m_delete_annotation :: M_Annotation -> Measure -> Measure +m_delete_annotation i (Measure a n) = Measure (delete i a) n + +m_remove_duplicate_ts :: [Measure] -> [Measure] +m_remove_duplicate_ts = + let get = m_time_signature' + del = m_delete_annotation + in prune (==) get del diff --git a/Music/Typesetting/Query.hs b/Music/Typesetting/Query.hs new file mode 100644 --- /dev/null +++ b/Music/Typesetting/Query.hs @@ -0,0 +1,181 @@ +module Music.Typesetting.Query where + +import Data.Function +import Data.List +import Data.Maybe +import Data.Ratio +import Music.Theory.Duration +import Music.Theory.Pitch +import Music.Typesetting.Model + +n_has_annotation :: N_Annotation -> Note -> Bool +n_has_annotation x (Note _ xs) = x `elem` xs + +n_is_rest :: Note -> Bool +n_is_rest = n_has_annotation N_Rest + +n_is_chord_elem :: Note -> Bool +n_is_chord_elem = n_has_annotation N_Chord + +n_is_untied :: Note -> Bool +n_is_untied n = not (n_has_annotation N_Begin_Tied n || + n_has_annotation N_End_Tied n) + +n_is_initial_tie :: Note -> Bool +n_is_initial_tie n = n_has_annotation N_Begin_Tied n && + not (n_has_annotation N_End_Tied n) + +n_is_final_tie :: Note -> Bool +n_is_final_tie n = n_has_annotation N_End_Tied n && + not (n_has_annotation N_Begin_Tied n) + +na_pitch :: N_Annotation -> Maybe Pitch +na_pitch a = + case a of + (N_Pitch x) -> Just x + _ -> Nothing + +n_pitch :: Note -> Maybe Pitch +n_pitch (Note _ as) = + case mapMaybe na_pitch as of + [] -> Nothing + [x] -> Just x + _ -> error "n_pitch" + +n_has_pitch :: Note -> Bool +n_has_pitch = isJust . n_pitch + +na_dynamic :: N_Annotation -> Maybe Dynamic_Mark_T +na_dynamic a = + case a of + (N_Dynamic_Mark x) -> Just x + _ -> Nothing + +n_dynamic :: Note -> Maybe Dynamic_Mark_T +n_dynamic (Note _ as) = + case mapMaybe na_dynamic as of + [] -> Nothing + [x] -> Just x + _ -> error "n_dynamic" + +n_has_dynamic :: Note -> Bool +n_has_dynamic = isJust . n_dynamic + +n_duration_forward :: Note -> Maybe Duration +n_duration_forward n = + let (Note d _) = n + in if n_is_chord_elem n + then Nothing + else Just d + +ma_time_signature_t :: M_Annotation -> Maybe Time_Signature_T +ma_time_signature_t m = + case m of + (M_Time_Signature x) -> Just x + _ -> Nothing + +m_time_signature :: Measure -> [M_Annotation] +m_time_signature = filter (isJust . ma_time_signature_t) . m_annotations + +m_time_signature' :: Measure -> Maybe M_Annotation +m_time_signature' m = + case m_time_signature m of + [x] -> Just x + _ -> Nothing + +m_time_signature_t :: Measure -> [Time_Signature_T] +m_time_signature_t = mapMaybe ma_time_signature_t . m_annotations + +ma_tempo_marking_t :: M_Annotation -> Maybe Tempo_Marking_T +ma_tempo_marking_t a = + case a of + (M_Tempo_Marking x) -> Just x + _ -> Nothing + +m_tempo_marking :: Measure -> [M_Annotation] +m_tempo_marking = filter (isJust . ma_tempo_marking_t) . m_annotations + +m_tempo_marking_t :: Measure -> [Tempo_Marking_T] +m_tempo_marking_t = mapMaybe ma_tempo_marking_t . m_annotations + +-- * Temporal map + +type SI_Map a = [(Integer,a)] +type Time_Signature_Map = SI_Map Time_Signature_T +type Tempo_Marking_Map = SI_Map Tempo_Marking_T +type Temporal_Map = (Integer,Time_Signature_Map,Tempo_Marking_Map) + +si_map_to_sequence :: Integer -> a -> SI_Map a -> [a] +si_map_to_sequence n df mp = + let mp' = (0,df) : mp ++ [(n,undefined)] + fn (i,x) (j,_) = genericReplicate (j - i) x + in concat (zipWith fn mp' (tail mp')) + +mm_time_signature_map :: [Measure] -> Time_Signature_Map +mm_time_signature_map = + let fn (i,m) = case m_time_signature_t m of + [] -> Nothing + [x] -> Just (i,x) + _ -> error "mm_time_signature_map" + in mapMaybe fn . zip [0..] + +mm_tempo_marking_map :: [Measure] -> Tempo_Marking_Map +mm_tempo_marking_map = + let fn (i,m) = case m_tempo_marking_t m of + [] -> Nothing + [x] -> Just (i,x) + _ -> error "mm_tempo_marking_map" + in mapMaybe fn . zip [0..] + +mm_temporal_map :: [Measure] -> Temporal_Map +mm_temporal_map xs = + let ts_m = mm_time_signature_map xs + tm_m = mm_tempo_marking_map xs + in (genericLength xs,ts_m,tm_m) + +-- | Duration, in RQ, of a measure of indicated time signature. +time_signature_to_rq :: Time_Signature_T -> Rational +time_signature_to_rq (n,d) = (4 * n) % d + +-- | Duration of a RQ value, in seconds, given indicated tempo. +rq_to_seconds :: Tempo_Marking_T -> Rational -> Double +rq_to_seconds (d,n) x = + let d' = duration_to_rq d + s = 60 / fromIntegral n + in (fromRational x * s) / fromRational d' + +-- | The duration, in seconds, of a measure at the indicated time +-- signaure and tempo marking. +time_signature_to_seconds :: Time_Signature_T -> Tempo_Marking_T -> Double +time_signature_to_seconds ts tm = + let i = time_signature_to_rq ts + in rq_to_seconds tm i + +-- | dx -> d +integrate :: (Num a) => [a] -> [a] +integrate [] = [] +integrate (x:xs) = + let fn i c = (i + c, i + c) + in x : snd (mapAccumL fn x xs) + +temporal_map_locate :: Temporal_Map -> [(Double,Double,Tempo_Marking_T)] +temporal_map_locate (n,ts_m,tm_m) = + let ts_s = si_map_to_sequence n (4,4) ts_m + tm_s = si_map_to_sequence n (quarter_note,60) tm_m + dd = zipWith time_signature_to_seconds ts_s tm_s + st = 0 : integrate dd + in zip3 st dd tm_s + +n_locate :: (Double,Double,Tempo_Marking_T) -> [Note] -> [(Double,Note)] +n_locate (st,_,tm) = + let fn i n = let j = maybe 0 duration_to_rq (n_duration_forward n) + j' = rq_to_seconds tm j + in (i + j', (i,n)) + in snd . mapAccumL fn st + +locate_notes :: [[Measure]] -> [(Double,Note)] +locate_notes mms = + let tm = mm_temporal_map (head mms) + lm = temporal_map_locate tm + mk_ns ms = concat (zipWith n_locate lm (map m_notes ms)) + in sortBy (compare `on` fst) (concatMap mk_ns mms) diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,10 @@ +hts - haskell music typesetting + +A music notation model with output to musicxml + + http://slavepianos.org/rd/?t=hts + http://haskell.org/ + http://lilypond.org/ + +(c) rohan drape, 2010-2011 + gpl, http://gnu.org/copyleft/ diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/hts.cabal b/hts.cabal new file mode 100644 --- /dev/null +++ b/hts.cabal @@ -0,0 +1,31 @@ +Name: hts +Version: 0.1 +Synopsis: Haskell Music Typesetting +Description: A simple music typesetting model in haskell +License: GPL +Category: Music +Copyright: (c) Rohan Drape, 2010-2011 +Author: Rohan Drape +Maintainer: rd@slavepianos.org +Stability: Experimental +Homepage: http://slavepianos.org/rd/?t=hts +Tested-With: GHC == 6.12.1 +Build-Type: Simple +Cabal-Version: >= 1.6 +Data-Files: README + +Library + Build-Depends: base == 4.*, + hmt, + xml + GHC-Options: -Wall -fwarn-tabs + Exposed-modules: Music.Typesetting.Model + Music.Typesetting.Literal + Music.Typesetting.Output.MusicXML + Music.Typesetting.Output.MusicXML.Binding + Music.Typesetting.Process + Music.Typesetting.Query + +Source-Repository head + Type: darcs + Location: http://slavepianos.org/rd/sw/hts