hts 0.11 → 0.12
raw patch · 11 files changed
+1023/−164 lines, 11 filesdep ~hmt
Dependency ranges changed: hmt
Files
- Music/Typesetting/Ascribe.hs +33/−0
- Music/Typesetting/Literal.hs +69/−31
- Music/Typesetting/Literal/Dynamic.hs +29/−0
- Music/Typesetting/Model.hs +73/−16
- Music/Typesetting/Note/Name.hs +416/−0
- Music/Typesetting/Output/MusicXML.hs +165/−33
- Music/Typesetting/Output/MusicXML/Binding.hs +53/−7
- Music/Typesetting/Process.hs +40/−0
- Music/Typesetting/Query.hs +127/−64
- README +8/−6
- hts.cabal +10/−7
+ Music/Typesetting/Ascribe.hs view
@@ -0,0 +1,33 @@+module Music.Typesetting.Ascribe where++import qualified Music.Theory.Duration.Annotation as T {- hmt -}+import qualified Music.Theory.Duration.Sequence.Notate as T++import Music.Typesetting.Literal+import Music.Typesetting.Model+import Music.Typesetting.Query++-- | Predicate /or/.+p_or :: (t -> Bool) -> (t -> Bool) -> t -> Bool+p_or f1 f2 x = f1 x || f2 x++-- | Drop annotation on repeated notes.+set_note_duration :: (T.Duration_A,Note) -> Note+set_note_duration (d,n) =+ let (da_d,da_a) = d+ Note _ a = n+ a' = map from_d_annotation da_a+ in case T.duration_a_tied_lr d of+ (False,False) -> Note da_d (a ++ a')+ (False,True) -> let fn = not . na_annotation_at_end_tied_only+ in Note da_d (filter fn a ++ a')+ (True,True) -> Note da_d (filter na_annotation_at_tied_either a ++ a')+ (True,False) -> let fn = na_annotation_at_tied_either `p_or`+ na_annotation_at_end_tied_only+ in Note da_d (filter fn a ++ a')++-- | Variant of 'T.mm_ascribe_chd' post-processed by 'set_note_duration'.+mm_ascribe :: [[T.Duration_A]] -> [Note] -> [[Note]]+mm_ascribe n =+ map (map set_note_duration) .+ T.mm_ascribe_chd n_is_chord_elem n
Music/Typesetting/Literal.hs view
@@ -3,7 +3,9 @@ import Data.List import Data.Maybe import Data.Ratio-import Music.Theory.Duration {- hmt -}+import Music.Theory.Clef {- hmt -}+import Music.Theory.Duration+import Music.Theory.Duration.Annotation import Music.Theory.Duration.RQ import Music.Typesetting.Model import Music.Typesetting.Query@@ -16,6 +18,9 @@ (&) :: Note -> N_Annotation -> Note (&) = flip n_annotate +n_annotate_l :: [N_Annotation] -> Note -> Note+n_annotate_l a' (Note d a) = Note d (a ++ a')+ -- | Apply function to first element of list. -- -- > annotate_first (+) 9 [1,2,3] == [10,2,3]@@ -25,6 +30,26 @@ [] -> [] (n:ns') -> fn a n : ns' +-- | Apply function to all but the last element of list.+--+-- > annotate_except_last (+) 7 [1,2,3] == [8,9,3]+annotate_except_last :: (a -> x -> x) -> a -> [x] -> [x]+annotate_except_last fn a ns =+ case ns of+ [] -> []+ [n] -> [n]+ n:ns' -> fn a n : annotate_except_last fn a ns'++-- | Apply function to middle elements of list.+--+-- > annotate_middle (+) 9 [1,2,3,4] == [1,11,12,4]+-- > annotate_middle (+) 9 [1,4] == [1,4]+annotate_middle :: (a -> x -> x) -> a -> [x] -> [x]+annotate_middle fn a ns =+ case ns of+ [] -> []+ n:ns' -> n : annotate_except_last fn a ns'+ -- | Apply function to last element of list. -- -- > annotate_last (+) 7 [1,2,3] == [1,2,10]@@ -41,9 +66,6 @@ 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 @@ -104,39 +126,55 @@ 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_clef = M_Clef (Clef Bass 0) 1+tenor_clef = M_Clef (Clef Tenor 0) 1+alto_clef = M_Clef (Clef Alto 0) 1+treble_clef = M_Clef (Clef Treble 0) 1+percussion_clef = M_Clef (Clef Percussion 0) 1 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+bass_8vb_clef = M_Clef (Clef Bass (-1)) 1+treble_8va_clef = M_Clef (Clef Treble 1) 1+treble_8vb_clef = M_Clef (Clef Treble (-1)) 1+treble_15ma_clef = M_Clef (Clef Treble 2) 1 accent :: N_Annotation accent = N_Articulation Accent++trill_mark :: N_Annotation+trill_mark = N_Ornament Trill_Mark++begin_slur :: N_Annotation+begin_slur = N_Begin_Slur++end_slur :: N_Annotation+end_slur = N_End_Slur++begin_slide :: N_Annotation+begin_slide = N_Begin_Slide++end_slide :: N_Annotation+end_slide = N_End_Slide++laissez_vibrer :: N_Annotation+laissez_vibrer = N_Direction D_Laissez_Vibrer++fermata :: N_Annotation+fermata = N_Fermata++arpeggiate :: N_Annotation+arpeggiate = N_Arpeggiate++pedal_down_mark,pedal_up_mark :: N_Annotation+pedal_down_mark = N_Direction (D_Pedal Pedal_Start False True)+pedal_up_mark = N_Direction (D_Pedal Pedal_Stop False True)++pedal_down,pedal_up,pedal_change,pedal_continue :: N_Annotation+pedal_down = N_Direction (D_Pedal Pedal_Start True False)+pedal_up = N_Direction (D_Pedal Pedal_Stop True False)+pedal_change = N_Direction (D_Pedal Pedal_Change True False)+pedal_continue = N_Direction (D_Pedal Pedal_Continue True False) -- * Parts, groups etc.
+ Music/Typesetting/Literal/Dynamic.hs view
@@ -0,0 +1,29 @@+-- | Dynamic mark literals.+module Music.Typesetting.Literal.Dynamic where++import Music.Theory.Dynamic_Mark {- hmt -}+import Music.Typesetting.Model++dynamic_mark :: Dynamic_Mark_T -> N_Annotation+dynamic_mark = N_Direction . D_Dynamic_Mark -- N_Dynamic_Mark++niente,pppp,ppp,pp,p,mp,mf,f,ff,fff,ffff,fp,sfz :: N_Annotation+niente = dynamic_mark Niente+pppp = dynamic_mark PPPP+ppp = dynamic_mark PPP+pp = dynamic_mark PP+p = dynamic_mark P+mp = dynamic_mark MP+mf = dynamic_mark MF+f = dynamic_mark F+ff = dynamic_mark FF+fff = dynamic_mark FFF+ffff = dynamic_mark FFFF+fp = dynamic_mark FP+sfz = dynamic_mark SFZ++cresc,dim,end_hairpin :: N_Annotation+cresc = N_Direction (D_Hairpin Crescendo)+dim = N_Direction (D_Hairpin Diminuendo)+end_hairpin = N_Direction (D_Hairpin End_Hairpin)+
Music/Typesetting/Model.hs view
@@ -1,47 +1,103 @@ module Music.Typesetting.Model where +import Music.Theory.Clef import Music.Theory.Duration+import Music.Theory.Dynamic_Mark import Music.Theory.Key import Music.Theory.Pitch+import Music.Theory.Tempo_Marking+import Music.Theory.Time_Signature -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,Enum,Bounded,Show)+type Font_Family_T = String +data Font_Style_T = Font_Style_Normal+ | Font_Style_Italic+ deriving (Eq,Ord,Enum,Show)++type Font_Size_T = Int++data Font_Weight_T = Font_Weight_Normal+ | Font_Weight_Bold+ deriving (Eq,Ord,Enum,Show)++data Font_T = Font Font_Family_T Font_Style_T Font_Size_T Font_Weight_T+ deriving (Eq,Ord,Show)+ data Articulation_T = Accent | Staccato | Strong_Accent | Tenuto deriving (Eq,Ord,Enum,Show) -data Clef_T = Bass | Tenor | Alto | Treble | Percussion- deriving (Eq,Ord,Enum,Show)+data Ornament_T = Trill_Mark+ deriving (Eq,Ord,Enum,Show) -type Time_Signature_T = (Integer,Integer)+data Harmonic_T = Natural_Harmonic+ | Artifical_Harmonic+ deriving (Eq,Ord,Enum,Show) +data Technical_T = Up_Bow+ | Down_Bow+ | Harmonic Harmonic_T+ | Open_String+ | Stopped+ | Snap_Pizzicato+ | Other_Technical (Maybe Font_T) String+ deriving (Eq,Ord,Show)+ data Placement_T = Above | Below deriving (Eq,Ord,Enum,Show) type Tuplet_T = (Integer,Duration,Integer,Duration) -type Tempo_Marking_T = (Duration,Integer)+data Pedal_T = Pedal_Start | Pedal_Stop | Pedal_Continue | Pedal_Change+ deriving (Eq,Ord,Enum,Show) +data Sound_T = Sound_Tempo Double -- q = mm+ | Sound_Dynamics Double -- % of F (where F=90)+ deriving (Eq,Ord,Show)++data Direction_T = D_Dynamic_Mark Dynamic_Mark_T+ | D_Hairpin Hairpin_T+ | D_Laissez_Vibrer+ | D_Tempo_Marking Tempo_Marking+ | D_Pedal {pedal_type :: Pedal_T+ ,pedal_line :: Bool+ ,pedal_sign :: Bool}+ deriving (Eq,Ord,Show)++data Beam_T = Beam_Begin | Beam_Continue | Beam_End+ deriving (Eq,Ord,Enum,Show)++data Notehead_T = Notehead_Triangle+ | Notehead_Diamond+ | Notehead_Square+ | Notehead_Cross+ deriving (Eq,Ord,Enum,Show)+ -- | 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_Notehead Notehead_T+ | N_Staff Integer+ | N_Beam Integer Beam_T+ -- BEGIN NOTATIONS | N_Begin_Tied | N_End_Tied+ | N_Begin_Slur | N_End_Slur | N_Begin_Tuplet (Maybe Tuplet_T) | N_End_Tuplet+ | N_Begin_Glissando | N_End_Glissando+ | N_Begin_Slide | N_End_Slide | N_Stem_Tremolo Integer+ | N_Ornament Ornament_T+ | N_Technical Technical_T | N_Articulation Articulation_T- | N_Dynamic_Mark Dynamic_Mark_T- | N_Crescendo | N_Diminuendo | N_End_Hairpin- | N_Laissez_Vibrer+ | N_Fermata+ | N_Arpeggiate+ -- END NOTATIONS+ | N_Direction Direction_T | N_Voice Integer | N_Backup [Duration]- | N_Natural_Harmonic deriving (Eq,Ord,Show) data Note = Note {n_duration :: Duration@@ -50,9 +106,10 @@ 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+ | M_Time_Signature Time_Signature+ | M_Staves Integer+ | M_Clef (Clef Integer) Integer+ | M_Direction Direction_T deriving (Eq,Ord,Show) data Measure = Measure { m_annotations :: [M_Annotation]
+ Music/Typesetting/Note/Name.hs view
@@ -0,0 +1,416 @@+-- | 'Pitch' names lifted to 'Note' values.+module Music.Typesetting.Note.Name where++import qualified Music.Theory.Duration.Name as T {- hmt -}+import qualified Music.Theory.Pitch as T+import qualified Music.Theory.Pitch.Name as T++import Music.Typesetting.Model++-- * Notes++pitch_to_note :: T.Pitch -> Note+pitch_to_note p = Note T.quarter_note [N_Pitch p]++a0,b0 :: Note+a0 = pitch_to_note T.a0+b0 = pitch_to_note T.b0++bes0 :: Note+bes0 = pitch_to_note T.bes0++ais0,bis0 :: Note+ais0 = pitch_to_note T.ais0+bis0 = pitch_to_note T.bis0++c1,d1,e1,f1,g1,a1,b1 :: Note+c1 = pitch_to_note T.c1+d1 = pitch_to_note T.d1+e1 = pitch_to_note T.e1+f1 = pitch_to_note T.f1+g1 = pitch_to_note T.g1+a1 = pitch_to_note T.a1+b1 = pitch_to_note T.b1++ces1,des1,ees1,fes1,ges1,aes1,bes1 :: Note+ces1 = pitch_to_note T.ces1+des1 = pitch_to_note T.des1+ees1 = pitch_to_note T.ees1+fes1 = pitch_to_note T.fes1+ges1 = pitch_to_note T.ges1+aes1 = pitch_to_note T.aes1+bes1 = pitch_to_note T.bes1++cis1,dis1,eis1,fis1,gis1,ais1,bis1 :: Note+cis1 = pitch_to_note T.cis1+dis1 = pitch_to_note T.dis1+eis1 = pitch_to_note T.eis1+fis1 = pitch_to_note T.fis1+gis1 = pitch_to_note T.gis1+ais1 = pitch_to_note T.ais1+bis1 = pitch_to_note T.bis1++c2,d2,e2,f2,g2,a2,b2 :: Note+c2 = pitch_to_note T.c2+d2 = pitch_to_note T.d2+e2 = pitch_to_note T.e2+f2 = pitch_to_note T.f2+g2 = pitch_to_note T.g2+a2 = pitch_to_note T.a2+b2 = pitch_to_note T.b2++ces2,des2,ees2,fes2,ges2,aes2,bes2 :: Note+ces2 = pitch_to_note T.ces2+des2 = pitch_to_note T.des2+ees2 = pitch_to_note T.ees2+fes2 = pitch_to_note T.fes2+ges2 = pitch_to_note T.ges2+aes2 = pitch_to_note T.aes2+bes2 = pitch_to_note T.bes2++cis2,dis2,eis2,fis2,gis2,ais2,bis2 :: Note+cis2 = pitch_to_note T.cis2+dis2 = pitch_to_note T.dis2+eis2 = pitch_to_note T.eis2+fis2 = pitch_to_note T.fis2+gis2 = pitch_to_note T.gis2+ais2 = pitch_to_note T.ais2+bis2 = pitch_to_note T.bis2++cisis2,disis2,eisis2,fisis2,gisis2,aisis2,bisis2 :: Note+cisis2 = pitch_to_note T.cisis2+disis2 = pitch_to_note T.disis2+eisis2 = pitch_to_note T.eisis2+fisis2 = pitch_to_note T.fisis2+gisis2 = pitch_to_note T.gisis2+aisis2 = pitch_to_note T.aisis2+bisis2 = pitch_to_note T.bisis2++c3,d3,e3,f3,g3,a3,b3 :: Note+c3 = pitch_to_note T.c3+d3 = pitch_to_note T.d3+e3 = pitch_to_note T.e3+f3 = pitch_to_note T.f3+g3 = pitch_to_note T.g3+a3 = pitch_to_note T.a3+b3 = pitch_to_note T.b3++ces3,des3,ees3,fes3,ges3,aes3,bes3 :: Note+ces3 = pitch_to_note T.ces3+des3 = pitch_to_note T.des3+ees3 = pitch_to_note T.ees3+fes3 = pitch_to_note T.fes3+ges3 = pitch_to_note T.ges3+aes3 = pitch_to_note T.aes3+bes3 = pitch_to_note T.bes3++cis3,dis3,eis3,fis3,gis3,ais3,bis3 :: Note+cis3 = pitch_to_note T.cis3+dis3 = pitch_to_note T.dis3+eis3 = pitch_to_note T.eis3+fis3 = pitch_to_note T.fis3+gis3 = pitch_to_note T.gis3+ais3 = pitch_to_note T.ais3+bis3 = pitch_to_note T.bis3++cisis3,disis3,eisis3,fisis3,gisis3,aisis3,bisis3 :: Note+cisis3 = pitch_to_note T.cisis3+disis3 = pitch_to_note T.disis3+eisis3 = pitch_to_note T.eisis3+fisis3 = pitch_to_note T.fisis3+gisis3 = pitch_to_note T.gisis3+aisis3 = pitch_to_note T.aisis3+bisis3 = pitch_to_note T.bisis3++ceseh3,deseh3,eeseh3,feseh3,geseh3,aeseh3,beseh3 :: Note+ceseh3 = pitch_to_note T.ceseh3+deseh3 = pitch_to_note T.deseh3+eeseh3 = pitch_to_note T.eeseh3+feseh3 = pitch_to_note T.feseh3+geseh3 = pitch_to_note T.geseh3+aeseh3 = pitch_to_note T.aeseh3+beseh3 = pitch_to_note T.beseh3++ceh3,deh3,eeh3,feh3,geh3,aeh3,beh3 :: Note+ceh3 = pitch_to_note T.ceh3+deh3 = pitch_to_note T.deh3+eeh3 = pitch_to_note T.eeh3+feh3 = pitch_to_note T.feh3+geh3 = pitch_to_note T.geh3+aeh3 = pitch_to_note T.aeh3+beh3 = pitch_to_note T.beh3++cih3,dih3,eih3,fih3,gih3,aih3,bih3 :: Note+cih3 = pitch_to_note T.cih3+dih3 = pitch_to_note T.dih3+eih3 = pitch_to_note T.eih3+fih3 = pitch_to_note T.fih3+gih3 = pitch_to_note T.gih3+aih3 = pitch_to_note T.aih3+bih3 = pitch_to_note T.bih3++cisih3,disih3,eisih3,fisih3,gisih3,aisih3,bisih3 :: Note+cisih3 = pitch_to_note T.cisih3+disih3 = pitch_to_note T.disih3+eisih3 = pitch_to_note T.eisih3+fisih3 = pitch_to_note T.fisih3+gisih3 = pitch_to_note T.gisih3+aisih3 = pitch_to_note T.aisih3+bisih3 = pitch_to_note T.bisih3++c4,d4,e4,f4,g4,a4,b4 :: Note+c4 = pitch_to_note T.c4+d4 = pitch_to_note T.d4+e4 = pitch_to_note T.e4+f4 = pitch_to_note T.f4+g4 = pitch_to_note T.g4+a4 = pitch_to_note T.a4+b4 = pitch_to_note T.b4++ces4,des4,ees4,fes4,ges4,aes4,bes4 :: Note+ces4 = pitch_to_note T.ces4+des4 = pitch_to_note T.des4+ees4 = pitch_to_note T.ees4+fes4 = pitch_to_note T.fes4+ges4 = pitch_to_note T.ges4+aes4 = pitch_to_note T.aes4+bes4 = pitch_to_note T.bes4++cis4,dis4,eis4,fis4,gis4,ais4,bis4 :: Note+cis4 = pitch_to_note T.cis4+dis4 = pitch_to_note T.dis4+eis4 = pitch_to_note T.eis4+fis4 = pitch_to_note T.fis4+gis4 = pitch_to_note T.gis4+ais4 = pitch_to_note T.ais4+bis4 = pitch_to_note T.bis4++ceses4,deses4,eeses4,feses4,geses4,aeses4,beses4 :: Note+ceses4 = pitch_to_note T.ceses4+deses4 = pitch_to_note T.deses4+eeses4 = pitch_to_note T.eeses4+feses4 = pitch_to_note T.feses4+geses4 = pitch_to_note T.geses4+aeses4 = pitch_to_note T.aeses4+beses4 = pitch_to_note T.beses4++cisis4,disis4,eisis4,fisis4,gisis4,aisis4,bisis4 :: Note+cisis4 = pitch_to_note T.cisis4+disis4 = pitch_to_note T.disis4+eisis4 = pitch_to_note T.eisis4+fisis4 = pitch_to_note T.fisis4+gisis4 = pitch_to_note T.gisis4+aisis4 = pitch_to_note T.aisis4+bisis4 = pitch_to_note T.bisis4++ceseh4,deseh4,eeseh4,feseh4,geseh4,aeseh4,beseh4 :: Note+ceseh4 = pitch_to_note T.ceseh4+deseh4 = pitch_to_note T.deseh4+eeseh4 = pitch_to_note T.eeseh4+feseh4 = pitch_to_note T.feseh4+geseh4 = pitch_to_note T.geseh4+aeseh4 = pitch_to_note T.aeseh4+beseh4 = pitch_to_note T.beseh4++ceh4,deh4,eeh4,feh4,geh4,aeh4,beh4 :: Note+ceh4 = pitch_to_note T.ceh4+deh4 = pitch_to_note T.deh4+eeh4 = pitch_to_note T.eeh4+feh4 = pitch_to_note T.feh4+geh4 = pitch_to_note T.geh4+aeh4 = pitch_to_note T.aeh4+beh4 = pitch_to_note T.beh4++cih4,dih4,eih4,fih4,gih4,aih4,bih4 :: Note+cih4 = pitch_to_note T.cih4+dih4 = pitch_to_note T.dih4+eih4 = pitch_to_note T.eih4+fih4 = pitch_to_note T.fih4+gih4 = pitch_to_note T.gih4+aih4 = pitch_to_note T.aih4+bih4 = pitch_to_note T.bih4++cisih4,disih4,eisih4,fisih4,gisih4,aisih4,bisih4 :: Note+cisih4 = pitch_to_note T.cisih4+disih4 = pitch_to_note T.disih4+eisih4 = pitch_to_note T.eisih4+fisih4 = pitch_to_note T.fisih4+gisih4 = pitch_to_note T.gisih4+aisih4 = pitch_to_note T.aisih4+bisih4 = pitch_to_note T.bisih4++c5,d5,e5,f5,g5,a5,b5 :: Note+c5 = pitch_to_note T.c5+d5 = pitch_to_note T.d5+e5 = pitch_to_note T.e5+f5 = pitch_to_note T.f5+g5 = pitch_to_note T.g5+a5 = pitch_to_note T.a5+b5 = pitch_to_note T.b5++ces5,des5,ees5,fes5,ges5,aes5,bes5 :: Note+ces5 = pitch_to_note T.ces5+des5 = pitch_to_note T.des5+ees5 = pitch_to_note T.ees5+fes5 = pitch_to_note T.fes5+ges5 = pitch_to_note T.ges5+aes5 = pitch_to_note T.aes5+bes5 = pitch_to_note T.bes5++cis5,dis5,eis5,fis5,gis5,ais5,bis5 :: Note+cis5 = pitch_to_note T.cis5+dis5 = pitch_to_note T.dis5+eis5 = pitch_to_note T.eis5+fis5 = pitch_to_note T.fis5+gis5 = pitch_to_note T.gis5+ais5 = pitch_to_note T.ais5+bis5 = pitch_to_note T.bis5++ceses5,deses5,eeses5,feses5,geses5,aeses5,beses5 :: Note+ceses5 = pitch_to_note T.ceses5+deses5 = pitch_to_note T.deses5+eeses5 = pitch_to_note T.eeses5+feses5 = pitch_to_note T.feses5+geses5 = pitch_to_note T.geses5+aeses5 = pitch_to_note T.aeses5+beses5 = pitch_to_note T.beses5++cisis5,disis5,eisis5,fisis5,gisis5,aisis5,bisis5 :: Note+cisis5 = pitch_to_note T.cisis5+disis5 = pitch_to_note T.disis5+eisis5 = pitch_to_note T.eisis5+fisis5 = pitch_to_note T.fisis5+gisis5 = pitch_to_note T.gisis5+aisis5 = pitch_to_note T.aisis5+bisis5 = pitch_to_note T.bisis5++ceseh5,deseh5,eeseh5,feseh5,geseh5,aeseh5,beseh5 :: Note+ceseh5 = pitch_to_note T.ceseh5+deseh5 = pitch_to_note T.deseh5+eeseh5 = pitch_to_note T.eeseh5+feseh5 = pitch_to_note T.feseh5+geseh5 = pitch_to_note T.geseh5+aeseh5 = pitch_to_note T.aeseh5+beseh5 = pitch_to_note T.beseh5++ceh5,deh5,eeh5,feh5,geh5,aeh5,beh5 :: Note+ceh5 = pitch_to_note T.ceh5+deh5 = pitch_to_note T.deh5+eeh5 = pitch_to_note T.eeh5+feh5 = pitch_to_note T.feh5+geh5 = pitch_to_note T.geh5+aeh5 = pitch_to_note T.aeh5+beh5 = pitch_to_note T.beh5++cih5,dih5,eih5,fih5,gih5,aih5,bih5 :: Note+cih5 = pitch_to_note T.cih5+dih5 = pitch_to_note T.dih5+eih5 = pitch_to_note T.eih5+fih5 = pitch_to_note T.fih5+gih5 = pitch_to_note T.gih5+aih5 = pitch_to_note T.aih5+bih5 = pitch_to_note T.bih5++cisih5,disih5,eisih5,fisih5,gisih5,aisih5,bisih5 :: Note+cisih5 = pitch_to_note T.cisih5+disih5 = pitch_to_note T.disih5+eisih5 = pitch_to_note T.eisih5+fisih5 = pitch_to_note T.fisih5+gisih5 = pitch_to_note T.gisih5+aisih5 = pitch_to_note T.aisih5+bisih5 = pitch_to_note T.bisih5++c6,d6,e6,f6,g6,a6,b6 :: Note+c6 = pitch_to_note T.c6+d6 = pitch_to_note T.d6+e6 = pitch_to_note T.e6+f6 = pitch_to_note T.f6+g6 = pitch_to_note T.g6+a6 = pitch_to_note T.a6+b6 = pitch_to_note T.b6++ces6,des6,ees6,fes6,ges6,aes6,bes6 :: Note+ces6 = pitch_to_note T.ces6+des6 = pitch_to_note T.des6+ees6 = pitch_to_note T.ees6+fes6 = pitch_to_note T.fes6+ges6 = pitch_to_note T.ges6+aes6 = pitch_to_note T.aes6+bes6 = pitch_to_note T.bes6++cis6,dis6,eis6,fis6,gis6,ais6,bis6 :: Note+cis6 = pitch_to_note T.cis6+dis6 = pitch_to_note T.dis6+eis6 = pitch_to_note T.eis6+fis6 = pitch_to_note T.fis6+gis6 = pitch_to_note T.gis6+ais6 = pitch_to_note T.ais6+bis6 = pitch_to_note T.bis6++ceseh6,deseh6,eeseh6,feseh6,geseh6,aeseh6,beseh6 :: Note+ceseh6 = pitch_to_note T.ceseh6+deseh6 = pitch_to_note T.deseh6+eeseh6 = pitch_to_note T.eeseh6+feseh6 = pitch_to_note T.feseh6+geseh6 = pitch_to_note T.geseh6+aeseh6 = pitch_to_note T.aeseh6+beseh6 = pitch_to_note T.beseh6++ceh6,deh6,eeh6,feh6,geh6,aeh6,beh6 :: Note+ceh6 = pitch_to_note T.ceh6+deh6 = pitch_to_note T.deh6+eeh6 = pitch_to_note T.eeh6+feh6 = pitch_to_note T.feh6+geh6 = pitch_to_note T.geh6+aeh6 = pitch_to_note T.aeh6+beh6 = pitch_to_note T.beh6++cih6,dih6,eih6,fih6,gih6,aih6,bih6 :: Note+cih6 = pitch_to_note T.cih6+dih6 = pitch_to_note T.dih6+eih6 = pitch_to_note T.eih6+fih6 = pitch_to_note T.fih6+gih6 = pitch_to_note T.gih6+aih6 = pitch_to_note T.aih6+bih6 = pitch_to_note T.bih6++cisih6,disih6,eisih6,fisih6,gisih6,aisih6,bisih6 :: Note+cisih6 = pitch_to_note T.cisih6+disih6 = pitch_to_note T.disih6+eisih6 = pitch_to_note T.eisih6+fisih6 = pitch_to_note T.fisih6+gisih6 = pitch_to_note T.gisih6+aisih6 = pitch_to_note T.aisih6+bisih6 = pitch_to_note T.bisih6++c7,d7,e7,f7,g7,a7,b7 :: Note+c7 = pitch_to_note T.c7+d7 = pitch_to_note T.d7+e7 = pitch_to_note T.e7+f7 = pitch_to_note T.f7+g7 = pitch_to_note T.g7+a7 = pitch_to_note T.a7+b7 = pitch_to_note T.b7++ces7,des7,ees7,fes7,ges7,aes7,bes7 :: Note+ces7 = pitch_to_note T.ces7+des7 = pitch_to_note T.des7+ees7 = pitch_to_note T.ees7+fes7 = pitch_to_note T.fes7+ges7 = pitch_to_note T.ges7+aes7 = pitch_to_note T.aes7+bes7 = pitch_to_note T.bes7++cis7,dis7,eis7,fis7,gis7,ais7,bis7 :: Note+cis7 = pitch_to_note T.cis7+dis7 = pitch_to_note T.dis7+eis7 = pitch_to_note T.eis7+fis7 = pitch_to_note T.fis7+gis7 = pitch_to_note T.gis7+ais7 = pitch_to_note T.ais7+bis7 = pitch_to_note T.bis7++c8,cis8,d8 :: Note+c8 = pitch_to_note T.c8+cis8 = pitch_to_note T.cis8+d8 = pitch_to_note T.d8
Music/Typesetting/Output/MusicXML.hs view
@@ -6,25 +6,29 @@ import Data.Ratio import Music.Typesetting.Model import Music.Typesetting.Output.MusicXML.Binding-import qualified Music.Theory.Duration as T {- hmt -}+import qualified Music.Theory.Clef as T {- hmt -}+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 {- xml -} -x_clef_t :: Clef_T -> (String,Integer)+x_clef_t :: 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)+ T.Treble -> ("G",2)+ T.Alto -> ("C",3)+ T.Tenor -> ("C",4)+ T.Bass -> ("F",4)+ T.Percussion -> ("percussion",3) -x_clef :: (Clef_T,Integer) -> X.Content-x_clef (c,i) =+x_clef :: T.Clef Integer -> Integer -> X.Content+x_clef (T.Clef c i) n = let (s,l) = x_clef_t c- a = [{-number "1"-}]+ a = [number (show n)] in clef a [sign [] [cdata s] ,line [] [cdata (show l)] ,clef_octave_change [] [cdata (show i)]]@@ -41,14 +45,14 @@ 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 :: 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))]+ ,alter [] [cdata (show (T.alteration_to_fdiff a::Double))] ,octave [] [cdata (show o)]] x_alteration_t :: T.Alteration_T -> String@@ -114,9 +118,13 @@ 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 @@ -126,10 +134,41 @@ [] -> 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_Natural_Harmonic -> Just (harmonic [] [natural []])+ 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@@ -162,9 +201,10 @@ [] -> Nothing xs' -> Just (articulations [] xs') -x_dynamic_mark_t :: Dynamic_Mark_T -> X.Content+x_dynamic_mark_t :: 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@@ -176,16 +216,23 @@ 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_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@@ -194,7 +241,7 @@ o = catMaybes [x_ornaments xs ,x_technical xs ,x_articulations xs- ,x_dynamics xs]+ {-,x_dynamics xs-}] in case n ++ o of [] -> Nothing xs' -> Just (notations [] xs')@@ -208,7 +255,7 @@ N_Chord -> Just (chord []) _ -> Nothing -x_metronome :: Tempo_Marking_T -> X.Content+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@@ -216,29 +263,71 @@ 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 =+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- N_Crescendo ->+ 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])- N_Diminuendo ->+ D_Hairpin T.Diminuendo -> let ty = direction_type [] [wedge [type_A "diminuendo"]] in Just (direction [x_placement_t Below] [ty])- N_End_Hairpin ->+ D_Hairpin T.End_Hairpin -> let ty = direction_type [] [wedge [type_A "stop"]] in Just (direction [x_placement_t Below] [ty])- N_Laissez_Vibrer ->+ 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_Tempo_Marking m -> Just (x_metronome m)+ 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_n_sound :: N_Annotation -> Maybe X.Content+x_n_sound x =+ case x of+ N_Sound s -> Just (x_sound s)+ _ -> Nothing+-}+ x_accidental :: [N_Annotation] -> [X.Content] x_accidental = let fn x = case x of@@ -253,6 +342,44 @@ _ -> 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@@ -260,20 +387,25 @@ es = mapMaybe x_note_elem xs' nt = catMaybes [x_notations xs] dr = mapMaybe x_n_direction xs+ --sn = mapMaybe x_n_sound 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]+ 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 ++ {- sn ++ -} [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_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_Tempo_Marking _ -> Nothing+ M_Staves n -> Just (staves [] n)+ M_Direction _ -> Nothing x_attributes :: [M_Annotation] -> X.Content x_attributes xs = attributes [] (mapMaybe x_attribute xs)@@ -289,7 +421,7 @@ set_divisions :: [Measure] -> [Measure] set_divisions xs = case xs of- [] -> error "set_divisions"+ [] -> error "hts: set_divisions: no measures?" Measure as ms : xs' -> Measure (M_Division x_divisions : as) ms : xs' x_part_name :: Name -> [X.Content]@@ -339,8 +471,8 @@ 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+ (Part {}) -> [x_score_part x]+ (Group {}) -> x_part_group x in part_list [] . concatMap fn x_part :: Part -> X.Content@@ -371,7 +503,7 @@ let (Score xs) = score_set_ids s pl = x_part_list xs f x = case x of- (Part _ _ _) -> [x]+ (Part {}) -> [x] (Group _ _ ps) -> ps pt = map x_part (concatMap f xs) in pl : pt
Music/Typesetting/Output/MusicXML/Binding.hs view
@@ -1,9 +1,12 @@+{-# Language Rank2Types #-} 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 PCDATA_ELEM = [X.Attr] -> String -> X.Content+type NUMERICAL_ELEM = (Num n,Show n) => [X.Attr] -> n -> X.Content type ATTR = String -> X.Attr -- | Ordinary character data, subject to escaping.@@ -13,6 +16,12 @@ mk_elem :: String -> ELEM mk_elem nm z e = X.Elem (X.Element (X.unqual nm) z e Nothing) +mk_pcdata_elem :: String -> PCDATA_ELEM+mk_pcdata_elem nm z s = mk_elem nm z [cdata s]++mk_numerical_elem :: String -> NUMERICAL_ELEM+mk_numerical_elem nm z n = mk_elem nm z [cdata (show n)]+ mk_empty_elem :: String -> EMPTY_ELEM mk_empty_elem nm z = X.Elem (X.Element (X.unqual nm) z [] Nothing) @@ -39,6 +48,12 @@ show_number = mk_attr "show-number" show_type = mk_attr "show-type" +font_family,font_style,font_size,font_weight :: ATTR+font_family = mk_attr "font-family"+font_style = mk_attr "font-style"+font_size = mk_attr "font-size"+font_weight = mk_attr "font-weight"+ direction,direction_type,offset :: ELEM direction = mk_elem "direction" direction_type = mk_elem "direction-type"@@ -50,6 +65,9 @@ words' :: ELEM words' = mk_elem "words" +pedal :: EMPTY_ELEM+pedal = mk_empty_elem "pedal"+ sign :: ELEM sign = mk_elem "sign" @@ -111,10 +129,7 @@ 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,pitch,step,alter,octave,rest,duration,voice,type_E,stem,beam,notehead,accidental :: ELEM note = mk_elem "note" pitch = mk_elem "pitch" step = mk_elem "step"@@ -125,10 +140,14 @@ voice = mk_elem "voice" type_E = mk_elem "type" stem = mk_elem "stem"-staff = mk_elem "staff" beam = mk_elem "beam"+notehead = mk_elem "notehead" accidental = mk_elem "accidental" +staves,staff :: NUMERICAL_ELEM+staves = mk_numerical_elem "staves"+staff = mk_numerical_elem "staff"+ notations,ornaments,technical,dynamics,tremolo :: ELEM notations = mk_elem "notations" ornaments = mk_elem "ornaments"@@ -136,17 +155,44 @@ dynamics = mk_elem "dynamics" tremolo = mk_elem "tremolo" +sound :: ELEM+sound = mk_elem "sound"++tempo,dynamics' :: ATTR+tempo = mk_attr "tempo"+dynamics' = mk_attr "dynamics"+ arpeggiate,tie,tied,slur :: EMPTY_ELEM-arpeggiate = mk_empty_elem "arpeggiate"+arpeggiate = mk_empty_elem "arpeggiate" -- up/down tie = mk_empty_elem "tie" tied = mk_empty_elem "tied" slur = mk_empty_elem "slur" +slide,glissando :: ELEM+slide = mk_elem "slide"+glissando = mk_elem "glissando"++fermata :: ELEM+fermata = mk_elem "fermata"+ harmonic :: ELEM harmonic = mk_elem "harmonic" -natural :: EMPTY_ELEM+natural,artificial :: EMPTY_ELEM natural = mk_empty_elem "natural"+artificial = mk_empty_elem "artificial"++up_bow,down_bow :: EMPTY_ELEM+up_bow = mk_empty_elem "up-bow"+down_bow = mk_empty_elem "down-bow"++open_string,stopped,snap_pizzicato :: EMPTY_ELEM+open_string = mk_empty_elem "open-string"+stopped = mk_empty_elem "stopped"+snap_pizzicato = mk_empty_elem "snap-pizzicato"++other_technical :: PCDATA_ELEM+other_technical = mk_pcdata_elem "other-technical" forward,backup :: ELEM forward = mk_elem "forward"
Music/Typesetting/Process.hs view
@@ -1,9 +1,43 @@ module Music.Typesetting.Process where import Data.List+import qualified Music.Typesetting.Literal.Dynamic as M import Music.Typesetting.Model import Music.Typesetting.Query +-- * Clef++-- | If 'M_Annotation' is a 'M_Clef' set the staff number.+m_clef_set_staff :: Integer -> M_Annotation -> Maybe M_Annotation+m_clef_set_staff n a =+ case a of+ M_Clef c _ -> Just (M_Clef c n)+ _ -> Nothing++-- * Note++-- | Process a 'Note' sequence adding 'D_End_Hairpin' annotations as+-- required, ie. where there is an open hairpin annotation and a+-- 'Note' has a dyamic annotation without a close hairpin annotation.+n_add_end_hairpins :: [Note] -> [Note]+n_add_end_hairpins =+ let f st n =+ case n of+ [] -> []+ [Note d a] -> [Note d (if st then M.end_hairpin : a else a)]+ Note d a : n' ->+ let (a',st') = if st &&+ any na_is_begin_dynamic a &&+ M.end_hairpin `notElem` a+ then (M.end_hairpin : a+ ,any na_is_begin_hairpin a)+ else (a+ ,st || any na_is_begin_hairpin a)+ in Note d a' : f st' n'+ in f False++-- * Measure+ -- | Delete persistent annotations or like. prune :: (a -> a -> Bool) -> (b -> Maybe a) -> (a -> b -> b) -> [b] -> [b] prune cmp get del =@@ -23,5 +57,11 @@ m_remove_duplicate_ts :: [Measure] -> [Measure] m_remove_duplicate_ts = let get = m_time_signature'+ del = m_delete_annotation+ in prune (==) get del++m_remove_duplicate_tempo_marking :: [Measure] -> [Measure]+m_remove_duplicate_tempo_marking =+ let get = m_tempo_marking' del = m_delete_annotation in prune (==) get del
Music/Typesetting/Query.hs view
@@ -3,13 +3,101 @@ import Data.Function import Data.List import Data.Maybe-import Data.Ratio-import Music.Theory.Duration {- hmt -}+import Music.Theory.Dynamic_Mark {- hmt -}+import Music.Theory.Duration import Music.Theory.Duration.Name import Music.Theory.Duration.RQ import Music.Theory.Pitch+import Music.Theory.Tempo_Marking+import Music.Theory.Time_Signature import Music.Typesetting.Model +-- * Note annotation++na_pitch :: N_Annotation -> Maybe Pitch+na_pitch a =+ case a of+ N_Pitch x -> Just x+ _ -> Nothing++na_dynamic_mark :: N_Annotation -> Maybe Dynamic_Mark_T+na_dynamic_mark a =+ case a of+ N_Direction (D_Dynamic_Mark x) -> Just x+ _ -> Nothing++na_is_dynamic_mark :: N_Annotation -> Bool+na_is_dynamic_mark = isJust . na_dynamic_mark++na_is_dynamic_annotation :: N_Annotation -> Bool+na_is_dynamic_annotation a =+ case a of+ N_Direction (D_Dynamic_Mark _) -> True+ N_Direction (D_Hairpin _) -> True+ _ -> False++na_is_begin_hairpin :: N_Annotation -> Bool+na_is_begin_hairpin a =+ case a of+ N_Direction (D_Hairpin Crescendo) -> True+ N_Direction (D_Hairpin Diminuendo) -> True+ _ -> False++na_is_begin_dynamic :: N_Annotation -> Bool+na_is_begin_dynamic a = na_is_dynamic_mark a || na_is_begin_hairpin a++na_annotated_tied_lr :: [N_Annotation] -> (Bool,Bool)+na_annotated_tied_lr a = (N_End_Tied `elem` a,N_Begin_Tied `elem` a)++data At_Tied = At_End_Tied | At_Either_Tied | At_Begin_Tied+ deriving (Eq,Enum,Ord,Show)++na_annotation_at_tied :: N_Annotation -> At_Tied+na_annotation_at_tied a =+ let err = error (show ("na_annotation_at_tied",a))+ in case a of+ N_Grace -> At_Begin_Tied+ N_Chord -> At_Either_Tied+ N_Pitch _ -> At_Either_Tied+ N_Unpitched -> At_Either_Tied+ N_Rest -> At_Either_Tied+ N_Notehead _ -> At_Either_Tied+ N_Staff _ -> At_Either_Tied+ N_Beam _ _ -> At_Either_Tied+ N_Begin_Tied -> err+ N_End_Tied -> err+ N_Begin_Slur -> At_Begin_Tied+ N_End_Slur -> At_End_Tied+ N_Begin_Tuplet _ -> err+ N_End_Tuplet -> err+ N_Begin_Glissando -> At_End_Tied+ N_End_Glissando -> At_Begin_Tied+ N_Begin_Slide -> At_End_Tied+ N_End_Slide -> At_Begin_Tied+ N_Stem_Tremolo _ -> At_Either_Tied+ N_Ornament Trill_Mark -> At_Begin_Tied+ N_Technical _ -> At_Begin_Tied+ N_Articulation _ -> At_Begin_Tied+ N_Fermata -> At_End_Tied+ N_Arpeggiate -> At_Begin_Tied+ N_Direction (D_Dynamic_Mark _) -> At_Begin_Tied+ N_Direction (D_Hairpin Crescendo) -> At_Begin_Tied+ N_Direction (D_Hairpin Diminuendo) -> At_Begin_Tied+ N_Direction (D_Hairpin End_Hairpin) -> At_End_Tied+ N_Direction D_Laissez_Vibrer -> At_End_Tied+ N_Direction (D_Tempo_Marking _) -> At_Begin_Tied+ N_Direction (D_Pedal {}) -> At_Begin_Tied+ N_Voice _ -> At_Either_Tied+ N_Backup _ -> err++na_annotation_at_end_tied_only :: N_Annotation -> Bool+na_annotation_at_end_tied_only = (== At_End_Tied) . na_annotation_at_tied++na_annotation_at_tied_either :: N_Annotation -> Bool+na_annotation_at_tied_either = (== At_Either_Tied) . na_annotation_at_tied++-- * Note+ n_has_annotation :: N_Annotation -> Note -> Bool n_has_annotation x (Note _ xs) = x `elem` xs @@ -31,12 +119,6 @@ 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@@ -47,21 +129,15 @@ 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+n_dynamic_mark :: Note -> Maybe Dynamic_Mark_T+n_dynamic_mark (Note _ as) =+ case mapMaybe na_dynamic_mark as of [] -> Nothing [x] -> Just x- _ -> error "n_dynamic"+ _ -> error "n_dynamic_mark: multiple marks" -n_has_dynamic :: Note -> Bool-n_has_dynamic = isJust . n_dynamic+n_has_dynamic_mark :: Note -> Bool+n_has_dynamic_mark = isJust . n_dynamic_mark n_duration_forward :: Note -> Maybe Duration n_duration_forward n =@@ -70,41 +146,52 @@ then Nothing else Just d -ma_time_signature_t :: M_Annotation -> Maybe Time_Signature_T+-- * Measure annotation++ma_time_signature_t :: M_Annotation -> Maybe Time_Signature ma_time_signature_t m = case m of- (M_Time_Signature x) -> Just x+ M_Time_Signature x -> Just x _ -> Nothing +ma_tempo_marking_t:: M_Annotation -> Maybe Tempo_Marking+ma_tempo_marking_t a =+ case a of+ M_Direction (D_Tempo_Marking x) -> Just x+ _ -> Nothing++-- * Measure++-- | 'Just' /a/ for singleton list, else 'Nothing'.+list_to_maybe :: [a] -> Maybe a+list_to_maybe l =+ case l of+ [e] -> Just e+ _ -> 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' = list_to_maybe . m_time_signature -m_time_signature_t :: Measure -> [Time_Signature_T]+m_time_signature_t :: Measure -> [Time_Signature] 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' :: Measure -> Maybe M_Annotation+m_tempo_marking' = list_to_maybe . m_tempo_marking++m_tempo_marking_t :: Measure -> [Tempo_Marking] 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 Time_Signature_Map = SI_Map Time_Signature+type Tempo_Marking_Map = SI_Map Tempo_Marking type Temporal_Map = (Integer,Time_Signature_Map,Tempo_Marking_Map) si_map_to_sequence :: Integer -> a -> SI_Map a -> [a]@@ -135,52 +222,28 @@ tm_m = mm_tempo_marking_map xs in (genericLength xs,ts_m,tm_m) --- | Duration, in RQ, of a measure of indicated time signature.------ > map time_signature_to_rq [(3,4),(5,8)] == [3,5/2]-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 (quarter_note,90) 1 == 60/90-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 (3,4) (quarter_note,90) == 2-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 [1,3,6,10] == [1,4,10,20] integrate :: (Num a) => [a] -> [a] integrate = scanl1 (+) -temporal_map_locate :: Temporal_Map -> [(Double,Double,Tempo_Marking_T)]+temporal_map_locate :: Temporal_Map -> [(Rational,Rational,Tempo_Marking)] 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+ dd = zipWith measure_duration 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 :: (Rational,Rational,Tempo_Marking) -> [Note] -> [(Rational,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 :: [[Measure]] -> [(Rational,Note)] locate_notes mms = let tm = mm_temporal_map (head mms) lm = temporal_map_locate tm
README view
@@ -1,10 +1,12 @@ hts - haskell music typesetting+------------------------------- -A music notation model with output to musicxml+A [haskell][hs] music notation model with output to+[musicxml][music-xml]. - http://slavepianos.org/rd/?t=hts- http://haskell.org/- http://lilypond.org/+© [rohan drape][rd], 2010-2012, [gpl][gpl]. -(c) rohan drape, 2010-2011- gpl, http://gnu.org/copyleft/+[hs]: http://haskell.org/+[music-xml]: http://www.makemusic.com/musicxml/+[rd]: http://rd.slavepianos.org/+[gpl]: http://gnu.org/copyleft/
hts.cabal view
@@ -1,26 +1,29 @@ Name: hts-Version: 0.11+Version: 0.12 Synopsis: Haskell Music Typesetting Description: A simple music typesetting model in haskell License: GPL Category: Music-Copyright: (c) Rohan Drape, 2010-2011+Copyright: (c) Rohan Drape, 2010-2012 Author: Rohan Drape Maintainer: rd@slavepianos.org Stability: Experimental-Homepage: http://slavepianos.org/rd/?t=hts-Tested-With: GHC == 7.2.2+Homepage: http://rd.slavepianos.org/?t=hts+Tested-With: GHC == 7.6.1 Build-Type: Simple Cabal-Version: >= 1.8 Data-Files: README Library Build-Depends: base == 4.*,- hmt==0.11.*,+ hmt==0.12.*, xml GHC-Options: -Wall -fwarn-tabs- Exposed-modules: Music.Typesetting.Model+ Exposed-modules: Music.Typesetting.Ascribe Music.Typesetting.Literal+ Music.Typesetting.Literal.Dynamic+ Music.Typesetting.Model+ Music.Typesetting.Note.Name Music.Typesetting.Output.MusicXML Music.Typesetting.Output.MusicXML.Binding Music.Typesetting.Process@@ -28,4 +31,4 @@ Source-Repository head Type: darcs- Location: http://slavepianos.org/rd/sw/hts+ Location: http://rd.slavepianos.org/sw/hts