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,8 @@ import Data.List import Data.Maybe import Data.Ratio -import Music.Theory.Duration +import Music.Theory.Duration {- hmt -} +import Music.Theory.Duration.RQ import Music.Typesetting.Model import Music.Typesetting.Query @@ -15,12 +16,18 @@ (&) :: Note -> N_Annotation -> Note (&) = flip n_annotate +-- | Apply function to first element of list. +-- +-- > annotate_first (+) 9 [1,2,3] == [10,2,3] annotate_first :: (a -> x -> x) -> a -> [x] -> [x] annotate_first fn a ns = case ns of [] -> [] (n:ns') -> fn a n : ns' +-- | Apply function to last element of list. +-- +-- > annotate_last (+) 7 [1,2,3] == [1,2,10] annotate_last :: (a -> x -> x) -> a -> [x] -> [x] annotate_last fn a ns = case ns of @@ -28,6 +35,9 @@ [n] -> [fn a n] (n:ns') -> n : annotate_last fn a ns' +-- | Apply function to first and last elements of list. +-- +-- > annotate_bracket (+) (9,7) [1,2,3] == [10,2,10] annotate_bracket :: (a -> x -> x) -> (a,a) -> [x] -> [x] annotate_bracket fn (a0,an) = annotate_last fn an . annotate_first fn a0 @@ -44,10 +54,10 @@ n_annotate_bracket = annotate_bracket n_annotate -- | Apply annotations to the start and end points of each tied note. -n_annotate_tie_endpoints :: (N_Annotation,N_Annotation) -> Note -> Note +n_annotate_tie_endpoints :: ([N_Annotation],[N_Annotation]) -> Note -> Note n_annotate_tie_endpoints (a0,an) n - | n_is_initial_tie n = n & a0 - | n_is_final_tie n = n &an + | n_is_initial_tie n = n_annotate_l a0 n + | n_is_final_tie n = n_annotate_l an n | otherwise = n n_edit_duration :: (Duration -> Duration) -> Note -> Note @@ -63,6 +73,7 @@ m_annotate :: M_Annotation -> Measure -> Measure m_annotate a (Measure as ns) = Measure (a : as) ns +-- | Infix variant of 'm_annotate' with reverse argument order. (&.) :: Measure -> M_Annotation -> Measure (&.) = flip m_annotate @@ -130,17 +141,17 @@ -- * Parts, groups etc. part :: Name -> [Measure] -> Part -part nm ms = Part Nothing [P_Name nm] ms +part nm = Part Nothing [P_Name nm] group :: Name -> [Part] -> Part -group nm ps = Group Nothing [G_Name nm] ps +group nm = Group Nothing [G_Name nm] --- merge parallel voices +-- | Merge parallel voices voices :: [[Measure]] -> [Measure] voices vs = let vs' = transpose vs vc_ann :: Integer -> Measure -> Measure - vc_ann i (Measure as ns) = Measure as (map (& (N_Voice i)) ns) + vc_ann i (Measure as ns) = Measure as (map (& N_Voice i) ns) merge_m_ann :: [Measure] -> [M_Annotation] merge_m_ann = foldl1 union . map m_annotations fn ms = let (d:_) = map m_duration ms @@ -153,7 +164,8 @@ -- * Interop --- note: ought to translate begin_tuplet correctly +-- | Translate from 'D_Annotation' to 'N_Annotation'. Note: does not +-- necessarily translate 'Begin_Tuplet' correctly. from_d_annotation :: D_Annotation -> N_Annotation from_d_annotation x = case x of diff --git a/Music/Typesetting/Model.hs b/Music/Typesetting/Model.hs --- a/Music/Typesetting/Model.hs +++ b/Music/Typesetting/Model.hs @@ -7,20 +7,21 @@ data Dynamic_Mark_T = PPPPP | PPPP | PPP | PP | P | MP | MF | F | FF | FFF | FFFF | FFFFF | FP | SF | SFP | SFPP | SFZ | SFFZ - deriving (Eq,Ord,Bounded,Show) + deriving (Eq,Ord,Enum,Bounded,Show) data Articulation_T = Accent | Staccato + | Strong_Accent | Tenuto - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Enum,Show) data Clef_T = Bass | Tenor | Alto | Treble | Percussion - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Enum,Show) type Time_Signature_T = (Integer,Integer) data Placement_T = Above | Below - deriving (Eq,Ord,Show) + deriving (Eq,Ord,Enum,Show) type Tuplet_T = (Integer,Duration,Integer,Duration) @@ -37,6 +38,7 @@ | N_Articulation Articulation_T | N_Dynamic_Mark Dynamic_Mark_T | N_Crescendo | N_Diminuendo | N_End_Hairpin + | N_Laissez_Vibrer | N_Voice Integer | N_Backup [Duration] | N_Natural_Harmonic 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,10 +6,11 @@ import Data.Ratio import Music.Typesetting.Model import Music.Typesetting.Output.MusicXML.Binding -import qualified Music.Theory.Duration as T +import qualified Music.Theory.Duration as T {- hmt -} +import qualified Music.Theory.Duration.RQ as T import qualified Music.Theory.Key as T import qualified Music.Theory.Pitch as T -import qualified Text.XML.Light as X +import qualified Text.XML.Light as X {- xml -} x_clef_t :: Clef_T -> (String,Integer) x_clef_t c = @@ -36,7 +37,7 @@ x_key :: (T.Note_T,Maybe T.Alteration_T,T.Mode_T) -> X.Content x_key (n,a,m) = - let a' = maybe T.Natural id a + let a' = fromMaybe T.Natural a in key [] [fifths [] [cdata (show (T.key_fifths (n,a',m)))] ,mode [] [cdata (key_mode_t m)]] @@ -140,9 +141,14 @@ x_placement_t :: Placement_T -> X.Attr x_placement_t = placement . map toLower . show --- note: this requires '_' -> '-' translation +c_underscore_to_hyphen :: Char -> Char +c_underscore_to_hyphen x = if x == '_' then '-' else x + +c_hs_to_xml :: Char -> Char +c_hs_to_xml = toLower . c_underscore_to_hyphen + x_articulation_t :: Articulation_T -> X.Content -x_articulation_t = mk_empty_elem_no_attr . map toLower . show +x_articulation_t = mk_empty_elem_no_attr . map c_hs_to_xml . show x_articulation :: N_Annotation -> Maybe X.Content x_articulation x = @@ -222,6 +228,9 @@ N_End_Hairpin -> let ty = direction_type [] [wedge [type_A "stop"]] in Just (direction [x_placement_t Below] [ty]) + N_Laissez_Vibrer -> + let ty = direction_type [] [words' [] [cdata "l.v."]] + in Just (direction [x_placement_t Above] [ty]) _ -> Nothing x_m_direction :: M_Annotation -> Maybe X.Content @@ -297,7 +306,7 @@ case p of (Part (Just i) as _) -> let as' = concatMap x_p_annotation as - i' = "P" ++ show i + i' = 'P' : show i in score_part [id_A i'] as' _ -> error "x_score_part: no ID or GROUP" @@ -338,9 +347,9 @@ x_part p = case p of (Part (Just i) _ ms) -> - let i' = "P" ++ show i + let i' = 'P' : show i ms' = set_divisions ms - in part [id_A i'] (map x_measure (zip [1..] ms')) + in part [id_A i'] (zipWith (curry x_measure) [1..] ms') _ -> error "x_part: no ID or GROUP" part_set_id :: (ID,Part) -> (ID,Part) @@ -367,7 +376,8 @@ pt = map x_part (concatMap f xs) in pl : pt --- t = title, n = number, d = dedication, c = composer +-- | Make header from tuple of /title/, /number/, /dedication/ and +-- /composer/. x_header :: (String,String,String,String) -> [X.Content] x_header (t,n,d,c) = let t' = work_title [] [cdata t] @@ -383,6 +393,6 @@ renderMusicXML :: [X.Content] -> String renderMusicXML xs = - concat [musicxml_xml - ,musicxml_partwise - ,X.showElement (score_partwise' [] xs)] + unlines [musicxml_xml + ,musicxml_partwise + ,X.ppElement (score_partwise' [] xs)] 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 @@ -47,6 +47,9 @@ wedge :: EMPTY_ELEM wedge = mk_empty_elem "wedge" +words' :: ELEM +words' = mk_elem "words" + sign :: ELEM sign = mk_elem "sign" diff --git a/Music/Typesetting/Process.hs b/Music/Typesetting/Process.hs --- a/Music/Typesetting/Process.hs +++ b/Music/Typesetting/Process.hs @@ -4,7 +4,7 @@ import Music.Typesetting.Model import Music.Typesetting.Query --- delete persistent annotations or like +-- | Delete persistent annotations or like. prune :: (a -> a -> Bool) -> (b -> Maybe a) -> (a -> b -> b) -> [b] -> [b] prune cmp get del = let go _ [] = [] diff --git a/Music/Typesetting/Query.hs b/Music/Typesetting/Query.hs --- a/Music/Typesetting/Query.hs +++ b/Music/Typesetting/Query.hs @@ -4,7 +4,9 @@ import Data.List import Data.Maybe import Data.Ratio -import Music.Theory.Duration +import Music.Theory.Duration {- hmt -} +import Music.Theory.Duration.Name +import Music.Theory.Duration.RQ import Music.Theory.Pitch import Music.Typesetting.Model @@ -134,10 +136,14 @@ 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 @@ -146,17 +152,18 @@ -- | 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 [] = [] -integrate (x:xs) = - let fn i c = (i + c, i + c) - in x : snd (mapAccumL fn x xs) +integrate = scanl1 (+) temporal_map_locate :: Temporal_Map -> [(Double,Double,Tempo_Marking_T)] temporal_map_locate (n,ts_m,tm_m) = diff --git a/hts.cabal b/hts.cabal --- a/hts.cabal +++ b/hts.cabal @@ -1,5 +1,5 @@ Name: hts -Version: 0.1 +Version: 0.11 Synopsis: Haskell Music Typesetting Description: A simple music typesetting model in haskell License: GPL @@ -9,14 +9,14 @@ Maintainer: rd@slavepianos.org Stability: Experimental Homepage: http://slavepianos.org/rd/?t=hts -Tested-With: GHC == 6.12.1 +Tested-With: GHC == 7.2.2 Build-Type: Simple -Cabal-Version: >= 1.6 +Cabal-Version: >= 1.8 Data-Files: README Library Build-Depends: base == 4.*, - hmt, + hmt==0.11.*, xml GHC-Options: -Wall -fwarn-tabs Exposed-modules: Music.Typesetting.Model