diff --git a/COPYING b/COPYING --- a/COPYING +++ b/COPYING @@ -9,14 +9,14 @@ * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of the nor the + * Neither the name of the Music Suite nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,4 @@ +#! /usr/bin/env runhaskell + import Distribution.Simple main = defaultMain diff --git a/musicxml2.cabal b/musicxml2.cabal --- a/musicxml2.cabal +++ b/musicxml2.cabal @@ -1,7 +1,7 @@ name: musicxml2 -version: 1.4.1 -cabal-version: >= 1.2 +version: 1.6 +cabal-version: >= 1.10 author: Hans Hoglund maintainer: Hans Hoglund license: BSD3 @@ -14,15 +14,24 @@ description: A representation of the MusicXML format. +source-repository head + type: git + location: git://github.com/music-suite/musicxml2.git + library build-depends: - base >= 4 && < 5, - semigroups, nats, data-default, type-unary, reverse-apply, + base >= 4 && < 5, + semigroups, + nats, + data-default, + type-unary, + reverse-apply, xml, - music-pitch-literal, - music-dynamics-literal + music-pitch-literal == 1.6, + music-dynamics-literal == 1.6 hs-source-dirs: src + default-language: Haskell2010 exposed-modules: Music.MusicXml Music.MusicXml.Time diff --git a/src/Music/MusicXml.hs b/src/Music/MusicXml.hs --- a/src/Music/MusicXml.hs +++ b/src/Music/MusicXml.hs @@ -10,8 +10,9 @@ -- Portability : portable -- -- A Haskell representation of MusicXML. +-- You may want to use the "Music.MusicXml.Simple" module to generate the representation. -- --- For an introduction, see . +-- For an introduction to MusicXML, see . -- ------------------------------------------------------------------------------------- @@ -28,11 +29,11 @@ MeasureAttrs(..), -- ** Part list - PartList, + PartList(..), PartListElem(..), -- * Music - Music, + Music(..), MusicElem(..), -- ** Attributes @@ -48,10 +49,7 @@ Tie(..), noTies, NoteProps(..), - - -- TODO rewrite these - mapNoteProps, - mapNoteProps2, + HasNoteProps(..), -- ** Notations Notation(..), diff --git a/src/Music/MusicXml/Dynamics.hs b/src/Music/MusicXml/Dynamics.hs --- a/src/Music/MusicXml/Dynamics.hs +++ b/src/Music/MusicXml/Dynamics.hs @@ -22,13 +22,29 @@ import Music.Dynamics.Literal data Dynamics - = PPPPPP | PPPPP | PPPP | PPP | PP | P - | MP | MF - | F | FF | FFF | FFFF | FFFFF | FFFFFF - | SF | SFP | SFPP - | FP | RF + = PPPPPP + | PPPPP + | PPPP + | PPP + | PP + | P + | MP + | MF + | F + | FF + | FFF + | FFFF + | FFFFF + | FFFFFF + | SF + | SFP + | SFPP + | FP + | RF | RFZ - | SFZ | SFFZ | FZ + | SFZ + | SFFZ + | FZ deriving (Eq, Ord, Show, Enum, Bounded) instance IsDynamics Dynamics where diff --git a/src/Music/MusicXml/Pitch.hs b/src/Music/MusicXml/Pitch.hs --- a/src/Music/MusicXml/Pitch.hs +++ b/src/Music/MusicXml/Pitch.hs @@ -1,5 +1,9 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE + GeneralizedNewtypeDeriving, + StandaloneDeriving, + TypeSynonymInstances, + FlexibleInstances #-} ------------------------------------------------------------------------------------- -- | diff --git a/src/Music/MusicXml/Score.hs b/src/Music/MusicXml/Score.hs --- a/src/Music/MusicXml/Score.hs +++ b/src/Music/MusicXml/Score.hs @@ -58,8 +58,7 @@ noTies, Tie, NoteProps(..), - mapNoteProps, - mapNoteProps2, + HasNoteProps(..), ----------------------------------------------------------------------------- -- ** Notations @@ -255,8 +254,10 @@ data MusicElem = MusicAttributes Attributes - | MusicBackup -- TODO - | MusicForward -- TODO + | MusicBackup + Duration + | MusicForward + Duration | MusicNote Note | MusicDirection @@ -368,14 +369,19 @@ noTies :: [Tie] noTies = [] -mapNoteProps :: (NoteProps -> NoteProps) -> Note -> Note -mapNoteProps f (Note x d t p) = Note x d t (f p) -mapNoteProps f (CueNote x d p) = CueNote x d (f p) -mapNoteProps f (GraceNote x t p) = GraceNote x t (f p) -mapNoteProps2 :: (NoteProps -> NoteProps) -> MusicElem -> MusicElem -mapNoteProps2 f (MusicNote n) = MusicNote (mapNoteProps f n) -mapNoteProps2 f x = x +class HasNoteProps a where + modifyNoteProps :: (NoteProps -> NoteProps) -> a -> a + + +instance HasNoteProps Note where + modifyNoteProps f (Note x d t p) = Note x d t (f p) + modifyNoteProps f (CueNote x d p) = CueNote x d (f p) + modifyNoteProps f (GraceNote x t p) = GraceNote x t (f p) + +instance HasNoteProps MusicElem where + modifyNoteProps f (MusicNote n) = MusicNote (modifyNoteProps f n) + modifyNoteProps f x = x diff --git a/src/Music/MusicXml/Simple.hs b/src/Music/MusicXml/Simple.hs --- a/src/Music/MusicXml/Simple.hs +++ b/src/Music/MusicXml/Simple.hs @@ -39,11 +39,11 @@ bar, -- -- ** Others - -- partIds, + -- standardPartAttributes, -- header, -- setHeader, -- setTitle, - -- setMvmTitle, + -- setMovementTitle, ----------------------------------------------------------------------------- -- * Top-level attributes @@ -71,6 +71,13 @@ metronome', ----------------------------------------------------------------------------- + -- * Backup and forward + ----------------------------------------------------------------------------- + + backup, + forward, + + ----------------------------------------------------------------------------- -- * Notes ----------------------------------------------------------------------------- @@ -135,7 +142,16 @@ ----------------------------------------------------------------------------- -- * Articulation ----------------------------------------------------------------------------- + + addTechnical, + addArticulation, + -- ** Technical + upbow, + downbow, + harmonic, + openString, + -- ** Slurs slur, beginSlur, @@ -198,12 +214,21 @@ segno, coda, + ----------------------------------------------------------------------------- + -- * Folds and maps + ----------------------------------------------------------------------------- + + -- mapNote, + mapMusic, + foldMusic, + ) where import Data.Default import Data.Ratio import Data.Monoid +import Control.Arrow import Music.MusicXml import Music.MusicXml.Score @@ -246,23 +271,19 @@ = Partwise (def) (header title composer partList) - (parts music) - - -partIds :: [String] -partIds = [ "P" ++ show n | n <- [1..] ] + (addPartwiseAttributes music) -- |  -- Create a part list from instrument names. -- partList :: [String] -> PartList -partList = PartList . zipWith (\partId name -> Part partId name Nothing) partIds +partList = PartList . zipWith (\partId name -> Part partId name Nothing) standardPartAttributes -- |  -- Create a part list from instrument names and abbreviations. -- partListAbbr :: [(String, String)] -> PartList -partListAbbr = PartList . zipWith (\partId (name,abbr) -> Part partId name (Just abbr)) partIds +partListAbbr = PartList . zipWith (\partId (name,abbr) -> Part partId name (Just abbr)) standardPartAttributes -- | -- Enclose the given parts in a bracket. @@ -313,20 +334,30 @@ header :: String -> String -> PartList -> ScoreHeader header title composer partList = ScoreHeader Nothing (Just title) (Just (Identification [Creator "composer" composer])) partList +setHeader :: ScoreHeader -> Score -> Score setHeader header (Partwise attrs _ music) = Partwise attrs header music setHeader header (Timewise attrs _ music) = Timewise attrs header music -setTitle title (ScoreHeader _ mvmTitle ident partList) = ScoreHeader title mvmTitle ident partList -setMvmTitle mvmTitle (ScoreHeader title _ ident partList) = ScoreHeader title (Just mvmTitle) ident partList --- addIdent ident (ScoreHeader title mvmTitle idents partList) = ScoreHeader title mvmTitle (ident:idents) partList +setTitle :: String -> ScoreHeader -> ScoreHeader +setTitle title (ScoreHeader _ mvmTitle ident partList) = ScoreHeader (Just title) mvmTitle ident partList -parts :: [[Music]] -> [(PartAttrs, [(MeasureAttrs, Music)])] -parts = zipWith (\ids mus -> (PartAttrs ids, zipWith (\ids mus -> (MeasureAttrs ids, mus)) barIds mus)) partIds' +setMovementTitle :: String -> ScoreHeader -> ScoreHeader +setMovementTitle mvmTitle (ScoreHeader title _ ident partList) = ScoreHeader title (Just mvmTitle) ident partList + +-- | The values P1, P2... which are conventionally used to identify parts in MusicXML. +standardPartAttributes :: [String] +standardPartAttributes = [ "P" ++ show n | n <- [1..] ] + +-- | Given a partwise score (list of parts, which are lists of measures), add part and measure attributes (numbers). +addPartwiseAttributes :: [[Music]] -> [(PartAttrs, [(MeasureAttrs, Music)])] +addPartwiseAttributes = deepZip partIds barIds where - partIds' = partIds - barIds = [1..] - + partIds = fmap PartAttrs standardPartAttributes + barIds = fmap MeasureAttrs [1..] + deepZip :: [a] -> [b] -> [[c]] -> [(a, [(b, c)])] + deepZip xs ys = zipWith (curry $ second (zip ys)) xs + -- ---------------------------------------------------------------------------------- -- Top-level attributes -- ---------------------------------------------------------------------------------- @@ -400,7 +431,12 @@ -- TODO #15 tempo +backup :: Duration -> Music +backup d = Music . single $ MusicBackup d +forward :: Duration -> Music +forward d = Music . single $ MusicForward d + -- ---------------------------------------------------------------------------------- -- Notes -- ---------------------------------------------------------------------------------- @@ -417,7 +453,9 @@ rest dur = case dots of 0 -> rest' dur' 1 -> rest' dur' <> rest' (dur' / 2) - _ -> error "Music.MusicXml.Simple.rest: to many dots" + 2 -> rest' dur' <> rest' (dur' / 2) <> rest' (dur' / 4) + 3 -> rest' dur' <> rest' (dur' / 2) <> rest' (dur' / 4) <> rest' (dur' / 8) + _ -> error "Music.MusicXml.Simple.rest: too many dots" where (dur', dots) = separateDots dur @@ -488,20 +526,20 @@ setVoice :: Int -> Music -> Music -setVoice n = Music . fmap (mapNoteProps2 (setVoiceP n)) . getMusic +setVoice n = Music . fmap (modifyNoteProps (setVoiceP n)) . getMusic dot :: Music -> Music setNoteVal :: NoteVal -> Music -> Music setTimeMod :: Int -> Int -> Music -> Music -dot = Music . fmap (mapNoteProps2 dotP) . getMusic -setNoteVal x = Music . fmap (mapNoteProps2 (setNoteValP x)) . getMusic -setTimeMod m n = Music . fmap (mapNoteProps2 (setTimeModP m n)) . getMusic +dot = Music . fmap (modifyNoteProps dotP) . getMusic +setNoteVal x = Music . fmap (modifyNoteProps (setNoteValP x)) . getMusic +setTimeMod m n = Music . fmap (modifyNoteProps (setTimeModP m n)) . getMusic addNotation :: Notation -> Music -> Music -addNotation x = Music . fmap (mapNoteProps2 (addNotationP x)) . getMusic +addNotation x = Music . fmap (modifyNoteProps (addNotationP x)) . getMusic setNoteHead :: NoteHead -> Music -> Music -setNoteHead x = Music . fmap (mapNoteProps2 (mapNoteHeadP (const $ Just (x,False,False)))) . getMusic +setNoteHead x = Music . fmap (modifyNoteProps (mapNoteHeadP (const $ Just (x,False,False)))) . getMusic -- TODO clean up, skip empty notation groups etc mergeNotations :: [Notation] -> [Notation] @@ -538,9 +576,9 @@ beginBeam :: Music -> Music continueBeam :: Music -> Music endBeam :: Music -> Music -beginBeam = Music . fmap (mapNoteProps2 (beginBeamP 1)) . getMusic -continueBeam = Music . fmap (mapNoteProps2 (continueBeamP 1)) . getMusic -endBeam = Music . fmap (mapNoteProps2 (endBeamP 1)) . getMusic +beginBeam = Music . fmap (modifyNoteProps (beginBeamP 1)) . getMusic +continueBeam = Music . fmap (modifyNoteProps (continueBeamP 1)) . getMusic +endBeam = Music . fmap (modifyNoteProps (endBeamP 1)) . getMusic beginTie :: Music -> Music endTie :: Music -> Music @@ -595,13 +633,36 @@ -- ---------------------------------------------------------------------------------- +addTechnical :: Technical -> Music -> Music +addTechnical x = addNotation (Technical [x]) + +addArticulation :: Articulation -> Music -> Music +addArticulation x = addNotation (Articulations [x]) + +upbow = addTechnical UpBow +downbow = addTechnical DownBow +harmonic = addTechnical Harmonic +openString = addTechnical OpenString + + beginSlur :: Music -> Music endSlur :: Music -> Music beginSlur = addNotation (Slur 1 Start) endSlur = addNotation (Slur 1 Stop) +accent :: Music -> Music +strongAccent :: Music -> Music staccato :: Music -> Music tenuto :: Music -> Music +detachedLegato :: Music -> Music +staccatissimo :: Music -> Music +spiccato :: Music -> Music +scoop :: Music -> Music +plop :: Music -> Music +doit :: Music -> Music +falloff :: Music -> Music +stress :: Music -> Music +unstress :: Music -> Music accent = addNotation (Articulations [Accent]) strongAccent = addNotation (Articulations [StrongAccent]) staccato = addNotation (Articulations [Staccato]) @@ -643,17 +704,20 @@ dynamic :: Dynamics -> Music dynamic level = Music $ [MusicDirection $ Dynamics level] - --- FIXME should scale duration by inverse, see #1 tuplet :: Int -> Int -> Music -> Music -tuplet m n (Music []) = Music [] -tuplet m n (Music [xs]) = Music [xs] -tuplet m n (Music xs) = setTimeMod m n $ (as <> bs <> cs) - where +tuplet m n (Music []) = scaleDur (fromIntegral n/fromIntegral m :: Rational) $ Music [] +tuplet m n (Music [xs]) = scaleDur (fromIntegral n/fromIntegral m :: Rational) $ Music [xs] +tuplet m n (Music xs) = scaleDur (fromIntegral n/fromIntegral m :: Rational) $ setTimeMod m n $ (as <> bs <> cs) + where as = beginTuplet $ Music [head xs] bs = Music $ init (tail xs) cs = endTuplet $ Music [last (tail xs)] +scaleDur x = mapMusic id (mapNote + (\f d t p -> (f,round $ fromIntegral d*x,t,p)) + (\f d p -> (f,round $ fromIntegral d*x,p)) + (\f t p -> (f,t,p))) id + beam :: Music -> Music beam (Music []) = Music [] beam (Music [xs]) = Music [xs] @@ -716,7 +780,29 @@ segno = Music . single . MusicDirection $ Segno coda = Music . single . MusicDirection $ Coda +-- ---------------------------------------------------------------------------------- +mapNote fn fc fg = go + where + go (Note f d t p) = let (f',d',t',p') = fn f d t p in Note f' d' t' p' + go (CueNote f d p) = let (f',d',p') = fc f d p in CueNote f' d' p' + go (GraceNote f t p) = let (f',t',p') = fg f t p in GraceNote f' t' p' + +mapMusic :: (Attributes -> Attributes) -> (Note -> Note) -> (Direction -> Direction) -> Music -> Music +mapMusic fa fn fd = foldMusic (MusicAttributes . fa) (MusicNote . fn) (MusicDirection . fd) (Music . return) + +foldMusic :: Monoid m => (Attributes -> r) -> (Note -> r) -> (Direction -> r) -> (r -> m) -> Music -> m +foldMusic fa fn fd f = mconcat . fmap f . (foldMusic' $ fmap (foldMusicElem fa fn fd)) + +foldMusic' :: ([MusicElem] -> r) -> Music -> r +foldMusic' f (Music x) = f x + +foldMusicElem :: (Attributes -> r) -> (Note -> r) -> (Direction -> r) -> MusicElem -> r +foldMusicElem = go + where go fa fn fd (MusicAttributes x) = fa x + go fa fn fd (MusicNote x) = fn x + go fa fn fd (MusicDirection x) = fd x + -- ---------------------------------------------------------------------------------- instance Default ScoreAttrs where @@ -738,21 +824,7 @@ def = NoteProps Nothing Nothing (Just (1/4, Nothing)) 0 Nothing Nothing Nothing Nothing Nothing Nothing Nothing [] [] --- class HasDyn a where --- mapLevel :: (Level -> Level) -> (a -> a) --- --- class HasPitch a where --- mapPitch :: (Pitch -> Pitch) -> (a -> a) --- --- class HasPitch a => HasAcc a where --- flatten :: a -> a --- sharpen :: a -> a --- mapAcc :: (Semitones -> Semitones) -> a -> a --- flatten = mapAcc pred --- sharpen = mapAcc succ - - ------------------------------------------------------------------------------------- @@ -768,3 +840,5 @@ single x = [x] equalTo = (==) + + diff --git a/src/Music/MusicXml/Write/Score.hs b/src/Music/MusicXml/Write/Score.hs --- a/src/Music/MusicXml/Write/Score.hs +++ b/src/Music/MusicXml/Write/Score.hs @@ -148,6 +148,8 @@ write (MusicAttributes x) = single $ unode "attributes" $ write x write (MusicNote x) = single $ unode "note" $ write x write (MusicDirection x) = single $ unode "direction" (unode "direction-type" $ write x) + write (MusicBackup d) = single $ unode "backup" (unode "duration" $ show $ getDivs $ d) + write (MusicForward d) = single $ unode "forward" (unode "duration" $ show $ getDivs $ d) -- ---------------------------------------------------------------------------------- -- Attributes