diff --git a/Music/Typesetting/Ascribe.hs b/Music/Typesetting/Ascribe.hs new file mode 100644 --- /dev/null +++ b/Music/Typesetting/Ascribe.hs @@ -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 diff --git a/Music/Typesetting/Literal.hs b/Music/Typesetting/Literal.hs --- a/Music/Typesetting/Literal.hs +++ b/Music/Typesetting/Literal.hs @@ -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. diff --git a/Music/Typesetting/Literal/Dynamic.hs b/Music/Typesetting/Literal/Dynamic.hs new file mode 100644 --- /dev/null +++ b/Music/Typesetting/Literal/Dynamic.hs @@ -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) + diff --git a/Music/Typesetting/Model.hs b/Music/Typesetting/Model.hs --- a/Music/Typesetting/Model.hs +++ b/Music/Typesetting/Model.hs @@ -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] diff --git a/Music/Typesetting/Note/Name.hs b/Music/Typesetting/Note/Name.hs new file mode 100644 --- /dev/null +++ b/Music/Typesetting/Note/Name.hs @@ -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 diff --git a/Music/Typesetting/Output/MusicXML.hs b/Music/Typesetting/Output/MusicXML.hs --- a/Music/Typesetting/Output/MusicXML.hs +++ b/Music/Typesetting/Output/MusicXML.hs @@ -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 diff --git a/Music/Typesetting/Output/MusicXML/Binding.hs b/Music/Typesetting/Output/MusicXML/Binding.hs --- a/Music/Typesetting/Output/MusicXML/Binding.hs +++ b/Music/Typesetting/Output/MusicXML/Binding.hs @@ -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" diff --git a/Music/Typesetting/Process.hs b/Music/Typesetting/Process.hs --- a/Music/Typesetting/Process.hs +++ b/Music/Typesetting/Process.hs @@ -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 diff --git a/Music/Typesetting/Query.hs b/Music/Typesetting/Query.hs --- a/Music/Typesetting/Query.hs +++ b/Music/Typesetting/Query.hs @@ -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 diff --git a/README b/README --- a/README +++ b/README @@ -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/ diff --git a/hts.cabal b/hts.cabal --- a/hts.cabal +++ b/hts.cabal @@ -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