hts (empty) → 0.1
raw patch · 9 files changed
+1082/−0 lines, 9 filesdep +basedep +hmtdep +xmlsetup-changed
Dependencies added: base, hmt, xml
Files
- Music/Typesetting/Literal.hs +163/−0
- Music/Typesetting/Model.hs +82/−0
- Music/Typesetting/Output/MusicXML.hs +388/−0
- Music/Typesetting/Output/MusicXML/Binding.hs +197/−0
- Music/Typesetting/Process.hs +27/−0
- Music/Typesetting/Query.hs +181/−0
- README +10/−0
- Setup.hs +3/−0
- hts.cabal +31/−0
+ Music/Typesetting/Literal.hs view
@@ -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
+ Music/Typesetting/Model.hs view
@@ -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)
+ Music/Typesetting/Output/MusicXML.hs view
@@ -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)]
+ Music/Typesetting/Output/MusicXML/Binding.hs view
@@ -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 = "<?xml version=\"1.0\" standalone=\"no\"?>"++type DocType = String++musicxml_partwise :: DocType+musicxml_partwise = "<!DOCTYPE score-partwise PUBLIC \"-//Recordare//DTD MusicXML 1.0 Partwise//EN\" \"http://www.musicxml.org/dtds/partwise.dtd\">"
+ Music/Typesetting/Process.hs view
@@ -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
+ Music/Typesetting/Query.hs view
@@ -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)
+ README view
@@ -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/
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain
+ hts.cabal view
@@ -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