musicxml2-1.4: src/Music/MusicXml/Simple.hs
{-# LANGUAGE ScopedTypeVariables, NoMonomorphismRestriction #-}
-------------------------------------------------------------------------------------
-- |
-- Copyright : (c) Hans Hoglund 2012
--
-- License : BSD-style
--
-- Maintainer : hans@hanshoglund.se
-- Stability : experimental
-- Portability : portable
--
-- Provides smart constructors for the MusicXML representation.
--
-------------------------------------------------------------------------------------
module Music.MusicXml.Simple (
module Music.MusicXml,
-----------------------------------------------------------------------------
-- * Score and parts
-----------------------------------------------------------------------------
-- ** Basic constructors
fromPart,
fromParts,
-- ** Part lists
partList,
partListAbbr,
bracket,
brace,
-- ** Measures
measure,
bar,
-- -- ** Others
-- partIds,
-- header,
-- setHeader,
-- setTitle,
-- setMvmTitle,
-----------------------------------------------------------------------------
-- * Top-level attributes
-----------------------------------------------------------------------------
-- ** Pitch
trebleClef,
altoClef,
bassClef,
defaultClef,
clef,
defaultKey,
key,
-- ** Time
defaultDivisions,
divisions,
commonTime,
cutTime,
time,
-- ** Tempo
-- TODO #15 tempo
metronome,
metronome',
-----------------------------------------------------------------------------
-- * Notes
-----------------------------------------------------------------------------
-- ** Basic constructors
rest,
note,
chord,
-- ** Voice
setVoice,
-- ** Duration
dot,
tuplet,
setNoteVal,
-- setTimeMod,
-- beginTuplet,
-- endTuplet,
separateDots,
-- ** Beams
beam,
beginBeam,
continueBeam,
endBeam,
-- ** Ties
beginTie,
endTie,
-- ** Note heads
setNoteHead,
-- ** Notations
addNotation,
-----------------------------------------------------------------------------
-- * Pitch transformations
-----------------------------------------------------------------------------
-- ** Glissando
beginGliss,
endGliss,
-- ** Slides
beginSlide,
endSlide,
-----------------------------------------------------------------------------
-- * Time transformations
-----------------------------------------------------------------------------
-- ** Accelerando and ritardando
-- TODO #16 accelerando,
-- TODO #16 ritardando,
-- ** Fermatas and breaks
fermata,
breathMark,
caesura,
-----------------------------------------------------------------------------
-- * Articulation
-----------------------------------------------------------------------------
-- ** Slurs
slur,
beginSlur,
endSlur,
-- ** Staccato and tenuto
staccato,
tenuto,
spiccato,
staccatissimo,
-- ** Accents
accent,
strongAccent,
-- ** Miscellaneous
scoop,
plop,
doit,
falloff,
stress,
unstress,
-- ** Ornaments
trill,
turn,
shake,
mordent,
tremolo,
-----------------------------------------------------------------------------
-- * Dynamics
-----------------------------------------------------------------------------
-- ** Crescendo and diminuendo
cresc,
dim,
beginCresc,
endCresc,
beginDim,
endDim,
-- ** Dynamic levels
dynamic,
-- ** Both
crescFrom,
crescTo,
crescFromTo,
dimFrom,
dimTo,
dimFromTo,
-----------------------------------------------------------------------------
-- * Text
-----------------------------------------------------------------------------
text,
rehearsal,
segno,
coda,
)
where
import Data.Default
import Data.Ratio
import Data.Monoid
import Music.MusicXml
import Music.MusicXml.Score
import Music.MusicXml.Time
import Music.MusicXml.Pitch
import Music.MusicXml.Dynamics
import Music.MusicXml.Read
import Music.MusicXml.Write
import qualified Data.List as List
-- ----------------------------------------------------------------------------------
-- Score and parts
-- ----------------------------------------------------------------------------------
-- |
-- Create a single-part score.
--
-- > fromPart title composer partName measures
--
-- Example:
--
-- @ 'fromPart' \"Suite\" \"Bach\" \"Cello solo\" [] @
--
fromPart :: String -> String -> String -> [Music] -> Score
fromPart title composer partName music =
fromParts title composer (partList [partName]) [music]
-- |
-- Create a multi-part score.
--
-- > fromParts title composer partList parts
--
-- Example:
--
-- @ 'fromParts' \"4'33\" \"Cage\" ('partList' [\"Violin\", \"Viola\", \"Cello\"]) [[]] @
--
fromParts :: String -> String -> PartList -> [[Music]] -> Score
fromParts title composer partList music
= Partwise
(def)
(header title composer partList)
(parts music)
partIds :: [String]
partIds = [ "P" ++ show n | n <- [1..] ]
-- |
-- Create a part list from instrument names.
--
partList :: [String] -> PartList
partList = PartList . zipWith (\partId name -> Part partId name Nothing) partIds
-- |
-- 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
-- |
-- Enclose the given parts in a bracket.
--
bracket :: PartList -> PartList
bracket ps = PartList $ mempty
<> [Group 1 Start "" Nothing (Just GroupBracket) (Just GroupBarLines) False]
<> getPartList ps
<> [Group 1 Stop "" Nothing Nothing Nothing False]
-- |
-- Enclose the given parts in a brace.
--
brace :: PartList -> PartList
brace ps = PartList $ mempty
<> [Group 1 Start "" Nothing (Just GroupBrace) (Just GroupBarLines) False]
<> getPartList ps
<> [Group 1 Stop "" Nothing Nothing Nothing False]
-- |
-- Convenient synonym for 'mconcat', allowing us to write things like
--
-- > measure [
-- > beam [
-- > note c (1/8),
-- > note d (1/8),
-- > note e (1/8),
-- > note f (1/8)
-- > ],
-- > tuplet 3 2 [
-- > note g (1/4),
-- > note a (1/4),
-- > note b (1/4)
-- > ]
-- > ]
--
measure :: [Music] -> Music
measure = mconcat
-- |
-- Convenient synonym for 'mconcat'.
--
bar :: [Music] -> Music
bar = measure
header :: String -> String -> PartList -> ScoreHeader
header title composer partList = ScoreHeader Nothing (Just title) (Just (Identification [Creator "composer" composer])) partList
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
parts :: [[Music]] -> [(PartAttrs, [(MeasureAttrs, Music)])]
parts = zipWith (\ids mus -> (PartAttrs ids, zipWith (\ids mus -> (MeasureAttrs ids, mus)) barIds mus)) partIds'
where
partIds' = partIds
barIds = [1..]
-- ----------------------------------------------------------------------------------
-- Top-level attributes
-- ----------------------------------------------------------------------------------
trebleClef, altoClef, bassClef :: Music
trebleClef = clef GClef 2
altoClef = clef CClef 3
bassClef = clef FClef 4
defaultClef :: Music
defaultClef = trebleClef
-- |
-- Create a clef.
--
clef :: ClefSign -> Line -> Music
clef symbol line = Music . single $ MusicAttributes $ Clef symbol line
defaultKey :: Music
defaultKey = key 0 Major
-- |
-- Create a key signature.
--
key :: Fifths -> Mode -> Music
key n m = Music . single $ MusicAttributes $ Key n m
-- Number of ticks per whole note (we use 768 per quarter like Sibelius).
defaultDivisionsVal :: Divs
defaultDivisionsVal = 768 * 4
-- |
-- Set the tick division to the default value.
--
defaultDivisions :: Music
defaultDivisions = Music $ single $ MusicAttributes $ Divisions $ defaultDivisionsVal `div` 4
-- |
-- Define the number of ticks per quarter note.
--
divisions :: Divs -> Music
divisions n = Music . single $ MusicAttributes $ Divisions $ n
commonTime, cutTime :: Music
commonTime = Music . single $ MusicAttributes $ Time CommonTime
cutTime = Music . single $ MusicAttributes $ Time CutTime
-- |
-- Create a time signature.
--
time :: Beat -> BeatType -> Music
time a b = Music . single $ MusicAttributes $ Time $ DivTime a b
-- |
-- Create a metronome mark.
--
metronome :: NoteVal -> Tempo -> Music
metronome nv tempo = case dots of
0 -> metronome' nv' False tempo
1 -> metronome' nv' True tempo
_ -> error "Metronome mark requires a maximum of one dot."
where
(nv', dots) = separateDots nv
-- |
-- Create a metronome mark.
--
metronome' :: NoteVal -> Bool -> Tempo -> Music
metronome' nv dot tempo = Music . single $ MusicDirection (Metronome nv dot tempo)
-- TODO #15 tempo
-- ----------------------------------------------------------------------------------
-- Notes
-- ----------------------------------------------------------------------------------
-- |
-- Create a rest.
--
-- > rest (1/4)
-- > rest (3/8)
-- > rest quarter
-- > rest (dotted eight)
--
rest :: NoteVal -> Music
rest dur = case dots of
0 -> rest' dur'
1 -> rest' dur' <> rest' (dur' / 2)
_ -> error "Music.MusicXml.Simple.rest: to many dots"
where
(dur', dots) = separateDots dur
rest' :: NoteVal -> Music
rest' dur = Music . single $ MusicNote (Note def (defaultDivisionsVal `div` denom) noTies (setNoteValP val def))
where
num = fromIntegral $ numerator $ toRational $ dur
denom = fromIntegral $ denominator $ toRational $ dur
val = NoteVal $ toRational $ dur
-- |
-- Create a single note.
--
-- > note c (1/4)
-- > note fs_ (3/8)
-- > note c quarter
-- > note (c + pure fifth) (dotted eight)
--
note :: Pitch -> NoteVal -> Music
note pitch dur = note' False pitch dur' dots
where
(dur', dots) = separateDots dur
chordNote :: Pitch -> NoteVal -> Music
chordNote pitch dur = note' True pitch dur' dots
where
(dur', dots) = separateDots dur
-- |
-- Create a chord.
--
-- > chord [c,eb,fs_] (3/8)
-- > chord [c,d,e] quarter
-- > chord [c,d,e] (dotted eight)
--
chord :: [Pitch] -> NoteVal -> Music
chord [] d = rest d
chord (p:ps) d = note p d <> Music (concatMap (\p -> getMusic $ chordNote p d) ps)
note' :: Bool -> Pitch -> NoteVal -> Int -> Music
note' isChord pitch dur dots
= Music . single $ MusicNote $
Note
(Pitched isChord $ pitch)
(defaultDivisionsVal `div` denom)
noTies
(setNoteValP val $ addDots $ def)
where
addDots = foldl (.) id (replicate dots dotP)
num = fromIntegral $ numerator $ toRational $ dur
denom = fromIntegral $ denominator $ toRational $ dur
val = NoteVal $ toRational $ dur
separateDots :: NoteVal -> (NoteVal, Int)
separateDots = separateDots' [2/3, 6/7, 14/15, 30/31, 62/63]
separateDots' :: [NoteVal] -> NoteVal -> (NoteVal, Int)
separateDots' [] nv = errorNoteValue
separateDots' (div:divs) nv
| isDivisibleBy 2 nv = (nv, 0)
| otherwise = (nv', dots' + 1)
where
(nv', dots') = separateDots' divs (nv*div)
errorNoteValue = error "Music.MusicXml.Simple.separateDots: Note value must be a multiple of two or dotted"
setVoice :: Int -> Music -> Music
setVoice n = Music . fmap (mapNoteProps2 (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
addNotation :: Notation -> Music -> Music
addNotation x = Music . fmap (mapNoteProps2 (addNotationP x)) . getMusic
setNoteHead :: NoteHead -> Music -> Music
setNoteHead x = Music . fmap (mapNoteProps2 (mapNoteHeadP (const $ Just (x,False,False)))) . getMusic
-- TODO clean up, skip empty notation groups etc
mergeNotations :: [Notation] -> [Notation]
mergeNotations notations = mempty
<> [foldOrnaments ornaments]
<> [foldTechnical technical]
<> [foldArticulations articulations]
<> others
where
(ornaments,notations') = List.partition isOrnaments notations
(technical,notations'') = List.partition isTechnical notations'
(articulations,others) = List.partition isArticulations notations'
isOrnaments (Ornaments _) = True
isOrnaments _ = False
isTechnical (Technical _) = True
isTechnical _ = False
isArticulations (Articulations _) = True
isArticulations _ = False
foldOrnaments = foldr mergeN (Ornaments [])
foldTechnical = foldr mergeN (Technical [])
foldArticulations = foldr mergeN (Articulations [])
(Ornaments xs) `mergeN` (Ornaments ys) = Ornaments (xs <> ys)
(Technical xs) `mergeN` (Technical ys) = Technical (xs <> ys)
(Articulations xs) `mergeN` (Articulations ys) = Articulations (xs <> ys)
beginTuplet :: Music -> Music
endTuplet :: Music -> Music
beginTuplet = addNotation (Tuplet 1 Start)
endTuplet = addNotation (Tuplet 1 Stop)
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
beginTie :: Music -> Music
endTie :: Music -> Music
beginTie = beginTie' . addNotation (Tied Start)
endTie = endTie' . addNotation (Tied Stop)
beginTie' = Music . fmap beginTie'' . getMusic
endTie' = Music . fmap endTie'' . getMusic
beginTie'' (MusicNote (Note full dur ties props)) = (MusicNote (Note full dur (ties++[Start]) props))
beginTie'' x = x
endTie'' (MusicNote (Note full dur ties props)) = (MusicNote (Note full dur ([Stop]++ties) props))
endTie'' x = x
setNoteValP v x = x { noteType = Just (v, Nothing) }
setVoiceP n x = x { noteVoice = Just (fromIntegral n) }
setTimeModP m n x = x { noteTimeMod = Just (fromIntegral m, fromIntegral n) }
beginBeamP n x = x { noteBeam = Just (fromIntegral n, BeginBeam) }
continueBeamP n x = x { noteBeam = Just (fromIntegral n, ContinueBeam) }
endBeamP n x = x { noteBeam = Just (fromIntegral n, EndBeam) }
dotP x@(NoteProps { noteDots = n@_ }) = x { noteDots = succ n }
addNotationP n x@(NoteProps { noteNotations = ns@_ }) = x { noteNotations = (mergeNotations $ ns++[n]) }
mapNotationsP f x@(NoteProps { noteNotations = ns@_ }) = x { noteNotations = (f ns) }
mapStemP f x@(NoteProps { noteStem = a@_ }) = x { noteNotations = (f a) }
mapNoteHeadP f x@(NoteProps { noteNoteHead = a@_ }) = x { noteNoteHead = (f a) }
-- ----------------------------------------------------------------------------------
beginGliss :: Music -> Music
endGliss :: Music -> Music
beginSlide :: Music -> Music
endSlide :: Music -> Music
beginGliss = addNotation (Glissando 1 Start Solid Nothing)
endGliss = addNotation (Glissando 1 Stop Solid Nothing)
beginSlide = addNotation (Slide 1 Start Solid Nothing)
endSlide = addNotation (Slide 1 Stop Solid Nothing)
arpeggiate :: Music -> Music
nonArpeggiate :: Music -> Music
arpeggiate = addNotation Arpeggiate
nonArpeggiate = addNotation NonArpeggiate
-- ----------------------------------------------------------------------------------
fermata :: FermataSign -> Music -> Music
breathMark :: Music -> Music
caesura :: Music -> Music
fermata = addNotation . Fermata
breathMark = addNotation (Articulations [BreathMark])
caesura = addNotation (Articulations [Caesura])
-- ----------------------------------------------------------------------------------
beginSlur :: Music -> Music
endSlur :: Music -> Music
beginSlur = addNotation (Slur 1 Start)
endSlur = addNotation (Slur 1 Stop)
staccato :: Music -> Music
tenuto :: Music -> Music
accent = addNotation (Articulations [Accent])
strongAccent = addNotation (Articulations [StrongAccent])
staccato = addNotation (Articulations [Staccato])
tenuto = addNotation (Articulations [Tenuto])
detachedLegato = addNotation (Articulations [DetachedLegato])
staccatissimo = addNotation (Articulations [Staccatissimo])
spiccato = addNotation (Articulations [Spiccato])
scoop = addNotation (Articulations [Scoop])
plop = addNotation (Articulations [Plop])
doit = addNotation (Articulations [Doit])
falloff = addNotation (Articulations [Falloff])
stress = addNotation (Articulations [Stress])
unstress = addNotation (Articulations [Unstress])
-- ----------------------------------------------------------------------------------
cresc, dim :: Music -> Music
crescFrom, crescTo, dimFrom, dimTo :: Dynamics -> Music -> Music
crescFromTo, dimFromTo :: Dynamics -> Dynamics -> Music -> Music
cresc = \m -> beginCresc <> m <> endCresc
dim = \m -> beginDim <> m <> endDim
crescFrom x = \m -> dynamic x <> cresc m
crescTo x = \m -> cresc m <> dynamic x
crescFromTo x y = \m -> dynamic x <> cresc m <> dynamic y
dimFrom x = \m -> dynamic x <> dim m
dimTo x = \m -> dim m <> dynamic x
dimFromTo x y = \m -> dynamic x <> dim m <> dynamic y
beginCresc, endCresc, beginDim, endDim :: Music
beginCresc = Music $ [MusicDirection $ Crescendo Start]
endCresc = Music $ [MusicDirection $ Crescendo Stop]
beginDim = Music $ [MusicDirection $ Diminuendo Start]
endDim = Music $ [MusicDirection $ Diminuendo Stop]
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
as = beginTuplet $ Music [head xs]
bs = Music $ init (tail xs)
cs = endTuplet $ Music [last (tail xs)]
beam :: Music -> Music
beam (Music []) = Music []
beam (Music [xs]) = Music [xs]
beam (Music xs) = (as <> bs <> cs)
where
as = beginBeam $ Music [head xs]
bs = continueBeam $ Music (init (tail xs))
cs = endBeam $ Music [last (tail xs)]
slur :: Music -> Music
slur (Music []) = Music []
slur (Music [xs]) = Music [xs]
slur (Music xs) = (as <> bs <> cs)
where
as = beginSlur $ Music [head xs]
bs = Music $ init (tail xs)
cs = endSlur $ Music [last (tail xs)]
-- TODO combine tuplet, beam, slur etc
-----------------------------------------------------------------------------
-- * Ornaments
-----------------------------------------------------------------------------
tremolo :: Int -> Music -> Music
tremolo n = addNotation (Ornaments [(Tremolo $ fromIntegral n, [])])
trill :: Music -> Music
turn :: Bool -> Bool -> Music -> Music
shake :: Music -> Music
mordent :: Bool -> Music -> Music
trill = addOrnament TrillMark
turn delay invert = case (delay,invert) of
(False,False) -> addOrnament Turn
(True, False) -> addOrnament DelayedTurn
(False,True) -> addOrnament InvertedTurn
(True, True) -> addOrnament DelayedInvertedTurn
shake = addOrnament Shake
mordent invert = case invert of
False -> addOrnament Mordent
True -> addOrnament InvertedMordent
addOrnament a = addNotation (Ornaments [(a, [])])
-- ----------------------------------------------------------------------------------
-- Text
-- ----------------------------------------------------------------------------------
text :: String -> Music
rehearsal :: String -> Music
text = Music . single . MusicDirection . Words
rehearsal = Music . single . MusicDirection . Rehearsal
segno, coda :: Music
segno = Music . single . MusicDirection $ Segno
coda = Music . single . MusicDirection $ Coda
-- ----------------------------------------------------------------------------------
instance Default ScoreAttrs where
def = ScoreAttrs []
instance Default ScoreHeader where
def = ScoreHeader Nothing Nothing Nothing mempty
instance Default Note where
def = Note def def [] def
instance Default Divs where
def = defaultDivisionsVal
instance Default FullNote where
def = Rest noChord Nothing
instance Default NoteProps where
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
-------------------------------------------------------------------------------------
logBaseR :: forall a . (RealFloat a, Floating a) => Rational -> Rational -> a
logBaseR k n
| isInfinite (fromRational n :: a) = logBaseR k (n/k) + 1
logBaseR k n
| isDenormalized (fromRational n :: a) = logBaseR k (n*k) - 1
logBaseR k n = logBase (fromRational k) (fromRational n)
isDivisibleBy :: (Real a, Real b) => a -> b -> Bool
isDivisibleBy n = (equalTo 0.0) . snd . properFraction . logBaseR (toRational n) . toRational
single x = [x]
equalTo = (==)