diff --git a/musicxml2.cabal b/musicxml2.cabal --- a/musicxml2.cabal +++ b/musicxml2.cabal @@ -1,6 +1,6 @@ name: musicxml2 -version: 1.8.1 +version: 1.9.0 synopsis: A representation of the MusicXML format. author: Hans Hoglund maintainer: Hans Hoglund @@ -26,16 +26,16 @@ type-unary >= 0.2.16 && < 1.0, reverse-apply, xml, - music-pitch-literal == 1.8.1, - music-dynamics-literal == 1.8.1 - exposed-modules: Music.MusicXml - Music.MusicXml.Time - Music.MusicXml.Pitch - Music.MusicXml.Dynamics - Music.MusicXml.Read - Music.MusicXml.Score - Music.MusicXml.Write - Music.MusicXml.Simple - other-modules: Music.MusicXml.Write.Score + music-pitch-literal == 1.9.0, + music-dynamics-literal == 1.9.0 + exposed-modules: Data.Music.MusicXml + Data.Music.MusicXml.Time + Data.Music.MusicXml.Pitch + Data.Music.MusicXml.Dynamics + Data.Music.MusicXml.Read + Data.Music.MusicXml.Score + Data.Music.MusicXml.Write + Data.Music.MusicXml.Simple + other-modules: Data.Music.MusicXml.Write.Score hs-source-dirs: src default-language: Haskell2010 diff --git a/src/Data/Music/MusicXml.hs b/src/Data/Music/MusicXml.hs new file mode 100644 --- /dev/null +++ b/src/Data/Music/MusicXml.hs @@ -0,0 +1,155 @@ + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : portable +-- +-- A Haskell representation of MusicXML. +-- You may want to use the "Data.Music.MusicXml.Simple" module to generate the representation. +-- +-- For an introduction to MusicXML, see . +-- +------------------------------------------------------------------------------------- + +module Data.Music.MusicXml ( + + -- * Score + Score(..), + ScoreHeader(..), + Identification(..), + Creator(..), + Defaults(..), + ScoreAttrs(..), + PartAttrs(..), + MeasureAttrs(..), + + -- ** Part list + PartList(..), + PartListElem(..), + + -- * Music + Music(..), + MusicElem(..), + + -- ** Attributes + Attributes(..), + TimeSignature(..), + ClefSign(..), + + -- ** Notes + Note(..), + FullNote(..), + IsChord, + noChord, + Tie(..), + noTies, + NoteProps(..), + HasNoteProps(..), + + -- ** Notations + Notation(..), + Articulation(..), + Ornament(..), + Technical(..), + + -- ** Directions + Direction(..), + + -- ** Lyrics + Lyric(..), + + + + + -- * Basic types + + -- ** Pitch + Pitch(..), + DisplayPitch(..), + PitchClass, + Semitones(..), + noSemitones, + + Octaves(..), + Fifths(..), + Line(..), + + Mode(..), + Accidental(..), + + -- ** Time + Duration(..), + NoteType(..), + + Divs(..), + NoteVal(..), + NoteSize(..), + + Beat(..), + BeatType(..), + + + -- ** Dynamics + Dynamics, + + + ----------------------------------------------------------------------------- + -- ** Misc + + StemDirection(..), + NoteHead(..), + LineType(..), + + Level(..), + BeamType(..), + StartStop(..), + StartStopChange(..), + StartStopContinue(..), + StartStopContinueChange(..), + + + ----------------------------------------------------------------------------- + -- * Import and export functions + ----------------------------------------------------------------------------- + + toXml, + showXml + + ) where + +import Text.XML.Light hiding (Line) + +import Data.Music.MusicXml.Score +import Data.Music.MusicXml.Time +import Data.Music.MusicXml.Pitch +import Data.Music.MusicXml.Dynamics +import Data.Music.MusicXml.Read +import Data.Music.MusicXml.Write + +import Data.Music.MusicXml.Write.Score + +-- -------------------------------------------------------------------------------- +-- Import and export functions +-- -------------------------------------------------------------------------------- + +-- | +-- Render a score as a MusicXML string. +showXml :: Score -> String +showXml = ppTopElement . toXml + +-- | +-- Render a score as MusicXML. +toXml :: Score -> Element +toXml = fromSingle . write + +-- -------------------------------------------------------------------------------- + +fromSingle :: [a] -> a +fromSingle [x] = x +fromSingle _ = error "fromSingle: non-single list" + diff --git a/src/Data/Music/MusicXml/Dynamics.hs b/src/Data/Music/MusicXml/Dynamics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Music/MusicXml/Dynamics.hs @@ -0,0 +1,67 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : portable +-- +------------------------------------------------------------------------------------- + +module Data.Music.MusicXml.Dynamics ( + + Dynamics(..) + + ) where + +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 + | RFZ + | SFZ + | SFFZ + | FZ + deriving (Eq, Ord, Show, Enum, Bounded) + +instance IsDynamics Dynamics where + fromDynamics (DynamicsL (Just x, Nothing)) = case x of + (-6.5) -> PPPPPP + (-5.5) -> PPPPP + (-4.5) -> PPPP + (-3.5) -> PPP + (-2.5) -> PP + (-1.5) -> P + (-0.5) -> MP + 0.5 -> MF + 1.5 -> F + 2.5 -> FF + 3.5 -> FFF + 4.5 -> FFFF + 5.5 -> FFFFF + 6.5 -> FFFFFF + fromDynamics _ = error "fromDynamics: Unsupported literal for MusicXml.Dynamics" + diff --git a/src/Data/Music/MusicXml/Pitch.hs b/src/Data/Music/MusicXml/Pitch.hs new file mode 100644 --- /dev/null +++ b/src/Data/Music/MusicXml/Pitch.hs @@ -0,0 +1,119 @@ + +{-# LANGUAGE + GeneralizedNewtypeDeriving, + StandaloneDeriving, + TypeSynonymInstances, + FlexibleInstances #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : portable +-- +------------------------------------------------------------------------------------- + +module Data.Music.MusicXml.Pitch ( + + Pitch(..), + DisplayPitch(..), + PitchClass(..), + Semitones(..), + noSemitones, + + Octaves(..), + Fifths(..), + Line(..), + + Mode(..), + Accidental(..) + + ) where + +import Music.Pitch.Literal + +type Pitch = (PitchClass, Maybe Semitones, Octaves) +type DisplayPitch = (PitchClass, Octaves) + +data Mode = Major | Minor + | Dorian | Phrygian | Lydian | Mixolydian + | Aeolian | Ionian | Locrian | NoMode + +data Accidental = DoubleFlat | Flat | Natural | Sharp | DoubleSharp + +data PitchClass = C | D | E | F | G | A | B + +newtype Semitones = Semitones { getSemitones :: Double } -- ^ Semitones, i.e 100 cent +newtype Octaves = Octaves { getOctaves :: Int } -- ^ Octaves, i.e. 1200 cent +newtype Fifths = Fifths { getFifths :: Int } -- ^ Number of fifths upwards relative to C (i.e. F is -1, G is 1) +newtype Line = Line { getLine :: Int } -- ^ Line number, from bottom (i.e. 1-5) + + +noSemitones :: Maybe Semitones +noSemitones = Nothing + +deriving instance Eq PitchClass +deriving instance Ord PitchClass +deriving instance Enum PitchClass +deriving instance Show PitchClass + +deriving instance Eq Accidental +deriving instance Ord Accidental +deriving instance Enum Accidental + +deriving instance Eq Mode +deriving instance Ord Mode +deriving instance Enum Mode +deriving instance Show Mode + +deriving instance Eq Semitones +deriving instance Ord Semitones +deriving instance Num Semitones +deriving instance Enum Semitones +deriving instance Fractional Semitones + +deriving instance Eq Octaves +deriving instance Ord Octaves +deriving instance Num Octaves +deriving instance Enum Octaves +deriving instance Real Octaves +deriving instance Integral Octaves + +deriving instance Eq Fifths +deriving instance Ord Fifths +deriving instance Num Fifths +deriving instance Enum Fifths + +deriving instance Eq Line +deriving instance Ord Line +deriving instance Num Line +deriving instance Enum Line + +instance IsPitch Pitch where + fromPitch (PitchL (pc, Nothing, oct)) = (toEnum pc, Nothing, fromIntegral oct) + fromPitch (PitchL (pc, Just st, oct)) = (toEnum pc, Just $ fromRational $ toRational $ st, fromIntegral oct) + +instance IsPitch DisplayPitch where + fromPitch (PitchL (pc, _, oct)) = (toEnum pc, fromIntegral oct) + +instance IsPitch Fifths where + fromPitch (PitchL (pc, Nothing, _)) = pitchToFifths pc 0 + fromPitch (PitchL (pc, Just ac, _)) = pitchToFifths pc (round ac) + +pitchToFifths 1 (-1) = (-4) +pitchToFifths 2 (-1) = (-3) +pitchToFifths 4 (-1) = (-6) +pitchToFifths 5 (-1) = (-5) +pitchToFifths 6 (-1) = (-2) +pitchToFifths 0 0 = 0 +pitchToFifths 1 0 = 2 +pitchToFifths 2 0 = 4 +pitchToFifths 3 0 = (-1) +pitchToFifths 4 0 = 1 +pitchToFifths 5 0 = 3 +pitchToFifths 6 0 = 5 +pitchToFifths 3 1 = 6 diff --git a/src/Data/Music/MusicXml/Read.hs b/src/Data/Music/MusicXml/Read.hs new file mode 100644 --- /dev/null +++ b/src/Data/Music/MusicXml/Read.hs @@ -0,0 +1,17 @@ + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : portable +-- +------------------------------------------------------------------------------------- + +module Data.Music.MusicXml.Read ( + ) where + + diff --git a/src/Data/Music/MusicXml/Score.hs b/src/Data/Music/MusicXml/Score.hs new file mode 100644 --- /dev/null +++ b/src/Data/Music/MusicXml/Score.hs @@ -0,0 +1,607 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : portable +-- +------------------------------------------------------------------------------------- + +module Data.Music.MusicXml.Score ( + + ----------------------------------------------------------------------------- + -- * Score + ----------------------------------------------------------------------------- + + Score(..), + ScoreHeader(..), + Identification(..), + Creator(..), + Defaults(..), + ScoreAttrs(..), + PartAttrs(..), + MeasureAttrs(..), + + -- ** Part list + PartList(..), + PartListElem(..), + GroupSymbol(..), + GroupBarlines(..), + + ----------------------------------------------------------------------------- + -- * Music + ----------------------------------------------------------------------------- + + Music(..), + MusicElem(..), + + ----------------------------------------------------------------------------- + + -- ** Attributes + Attributes(..), + TimeSignature(..), + ClefSign(..), + + ----------------------------------------------------------------------------- + -- ** Notes + + Note(..), + FullNote(..), + IsChord, + noChord, + noTies, + Tie, + NoteProps(..), + HasNoteProps(..), + + ----------------------------------------------------------------------------- + -- ** Notations + + Notation(..), + FermataSign(..), + Articulation(..), + Ornament(..), + Technical(..), + + ----------------------------------------------------------------------------- + -- ** Directions + + Direction(..), + + ----------------------------------------------------------------------------- + -- ** Lyrics + + Lyric(..), + + + ----------------------------------------------------------------------------- + -- * Basic types + ----------------------------------------------------------------------------- + + ----------------------------------------------------------------------------- + -- ** Pitch + + Pitch(..), + DisplayPitch(..), + PitchClass, + Semitones(..), + noSemitones, + + Octaves(..), + Fifths(..), + Line(..), + + Mode(..), + Accidental(..), + + ----------------------------------------------------------------------------- + -- ** Time + + Duration(..), + NoteType(..), + + Divs(..), + NoteVal(..), + NoteSize(..), + + Beat(..), + BeatType(..), + + ----------------------------------------------------------------------------- + -- ** Dynamics + + Dynamics(..), + + ----------------------------------------------------------------------------- + -- ** Misc + + StemDirection(..), + NoteHead(..), + LineType(..), + + Level(..), + BeamType(..), + StartStop(..), + StartStopChange(..), + StartStopContinue(..), + StartStopContinueChange(..), + + ) where + +import Prelude hiding (getLine) + +import Data.Default +import Data.Semigroup +import Data.Foldable +import Numeric.Natural +import TypeUnary.Nat + +import Data.Music.MusicXml.Time +import Data.Music.MusicXml.Pitch +import Data.Music.MusicXml.Dynamics + +import qualified Data.List as List + +-- ---------------------------------------------------------------------------------- +-- Score +-- ---------------------------------------------------------------------------------- + +data Score + = Partwise + ScoreAttrs + ScoreHeader + [(PartAttrs, + [(MeasureAttrs, Music)])] -- music by part and time + | Timewise + ScoreAttrs + ScoreHeader + [(MeasureAttrs, + [(PartAttrs, Music)])] -- music by time and part + +data ScoreHeader + = ScoreHeader + (Maybe String) -- title + (Maybe String) -- movement title + (Maybe Identification) -- identification? + -- defaults? + -- credit* + PartList -- partlist? + + +data Identification + = Identification + [Creator] -- creator + +data Creator + = Creator + String -- type (composer, lyricist, arranger etc) + String -- name + +data Defaults + = Defaults + -- page layout (marigins, distance etc) + -- system layout + -- staff layout + -- scaling + -- appearance (line width etc) + +data ScoreAttrs + = ScoreAttrs + [Int] -- score version + +data PartAttrs + = PartAttrs + String -- part id + +data MeasureAttrs + = MeasureAttrs + Int -- measure number + + +-- ---------------------------------------------------------------------------------- +-- Part list +-- ---------------------------------------------------------------------------------- + +newtype PartList = PartList { getPartList :: [PartListElem] } + +instance Default PartList where + def = PartList [] + +instance Semigroup PartList where + PartList xs <> PartList ys = PartList (setIds $ xs <> ys) + where + setIds = snd . List.mapAccumL setId partIds + setId id (Part _ name abbr dname dabbrev) = (tail id, Part (head id) name abbr dname dabbrev) + setId id x = (id, x) + + partIds = [ "P" ++ show n | n <- [1..] ] + +instance Monoid PartList where + mempty = def + mappend = (<>) + +data PartListElem + = Part + String + String + (Maybe String) + (Maybe String) + (Maybe String) -- id name abbrev? name-display? abbrev-display? + | Group + Level + StartStop + String + (Maybe String) + (Maybe GroupSymbol) + (Maybe GroupBarlines) + Bool -- number start/stop name abbrev? symbol barline style + +data GroupSymbol = GroupBrace | GroupLine | GroupBracket | GroupSquare | NoGroupSymbol +data GroupBarlines = GroupBarLines | GroupNoBarLines | GroupMensurstrich + +-- ---------------------------------------------------------------------------------- +-- Music +-- ---------------------------------------------------------------------------------- + +newtype Music = Music { getMusic :: [MusicElem] } + deriving (Semigroup, Monoid) + +data MusicElem + = MusicAttributes + Attributes + | MusicBackup + Duration + | MusicForward + Duration + | MusicNote + Note + | MusicDirection + Direction + | MusicHarmony -- TODO + | MusicFiguredBass -- TODO + | MusicPrint -- TODO + | MusicSound -- TODO + | MusicBarline -- TODO + | MusicGrouping -- TODO + | MusicLink -- TODO + | MusicBookmark -- TODO + + +-- ---------------------------------------------------------------------------------- +-- Attributes +-- ---------------------------------------------------------------------------------- + +data Attributes + = Divisions + Divs + | Key + Fifths + Mode + | Time + TimeSignature + | Staves + Natural + | PartSymbol -- TODO + | Instruments + Natural + | Clef + ClefSign + Line + | StaffDetails -- TODO + | Transpose -- TODO + | Directive -- TODO + | MeasureStyle -- TODO + +data TimeSignature + = CommonTime + | CutTime + | DivTime + Beat + BeatType + +data ClefSign + = GClef + | CClef + | FClef + | PercClef + | TabClef + deriving (Eq, Ord, Enum, Bounded) + + +-- ---------------------------------------------------------------------------------- +-- Notes +-- ---------------------------------------------------------------------------------- + +data Note + = Note + FullNote + Duration + [Tie] + NoteProps + | CueNote + FullNote + Duration + NoteProps + | GraceNote + FullNote + [Tie] + NoteProps + +data FullNote + = Pitched + IsChord + Pitch + | Unpitched + IsChord + (Maybe DisplayPitch) + | Rest + IsChord + (Maybe DisplayPitch) + +type IsChord = Bool +type Tie = StartStop + +data NoteProps + = NoteProps { + noteInstrument :: Maybe String, -- instrument + noteVoice :: Maybe Natural, -- voice + noteType :: Maybe NoteType, -- type + noteDots :: Natural, -- dots + noteAccidental :: Maybe (Accidental, Bool, Bool), -- accidental, cautionary, editorial + noteTimeMod :: Maybe (Natural, Natural), -- actual, normal + noteStem :: Maybe StemDirection, -- stem + noteNoteHead :: Maybe (NoteHead, Bool, Bool), -- notehead, filled, parentheses + noteNoteHeadText :: Maybe String, -- notehead-text + noteStaff :: Maybe Natural, -- staff + noteBeam :: Maybe (Level, BeamType), -- beam-level, beam-type + noteNotations :: [Notation], -- notation + noteLyrics :: [Lyric] -- lyric + } + +noChord :: IsChord +noChord = False + +noTies :: [Tie] +noTies = [] + + +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 + + + +-- ---------------------------------------------------------------------------------- +-- Notations +-- ---------------------------------------------------------------------------------- + +data Notation + = Tied + StartStopContinue -- type + | Slur + Level + StartStopContinue -- level start/stop + | Tuplet + Level + StartStopContinue -- level start/stop + | Glissando + Level + StartStopContinue + LineType + (Maybe String) -- level type start/stop text? + | Slide + Level + StartStopContinue + LineType + (Maybe String) -- level type start/stop text? + | Ornaments + [(Ornament, [Accidental])] + | Technical + [Technical] + | Articulations + [Articulation] + | DynamicNotation + Dynamics + | Fermata FermataSign + | Arpeggiate + | NonArpeggiate + | AccidentalMark + Accidental + | OtherNotation + String + +data FermataSign = NormalFermata | AngledFermata | SquaredFermata + +data Articulation + = Accent + | StrongAccent + | Staccato + | Tenuto + | DetachedLegato + | Staccatissimo + | Spiccato + | Scoop + | Plop + | Doit + | Falloff + | BreathMark + | Caesura + | Stress + | Unstress + | OtherArticulation + +data Ornament + = TrillMark + | Turn + | DelayedTurn + | InvertedTurn + | DelayedInvertedTurn + | VerticalTurn + | Shake + | WavyLine + | Mordent + | InvertedMordent + | Schleifer + | Tremolo + Natural -- TODO restrict to (1..8) range + | OtherOrnament + String + +data Technical + = UpBow + | DownBow + | Harmonic + | OpenString + | ThumbPosition + | Fingering + | Pluck + | DoubleTongue + | TripleTongue + | Stopped + | SnapPizzicato + | Fret + | String + | HammerOn + | PullOff + | Bend + | Tap + | Heel + | Toe + | Fingernails + | Hole + | Arrow + | Handbell + | OtherTechnical + String + +-- ---------------------------------------------------------------------------------- +-- Directions +-- ---------------------------------------------------------------------------------- + +data Direction + = Rehearsal + String + | Segno + | Words + String + | Coda + | Crescendo + StartStop -- start/stop + | Diminuendo + StartStop -- start/stop + | Dynamics + Dynamics + | Dashes + Level + StartStop -- level start/stop + | Bracket -- TODO + | Pedal + StartStopChange + | Metronome + NoteVal + Bool + Tempo -- noteVal isDotted bpm + | OctaveShift -- TODO + | HarpPedals -- TODO + | Damp -- TODO + | DampAll -- TODO + | EyeGlasses -- TODO + | StringMute -- TODO + | Scordatura -- TODO + | Image -- TODO + | PrincipalVoice -- TODO + | AccordionRegistration -- TODO + | Percussion -- TODO + | OtherDirection + String + + +-- ---------------------------------------------------------------------------------- +-- Lyrics +-- ---------------------------------------------------------------------------------- + +data Lyric = Lyric -- TODO + + +-- ---------------------------------------------------------------------------------- +-- Basic types +-- ---------------------------------------------------------------------------------- + +newtype Level = Level { getLevel :: Max8 } + +data BeamType + = BeginBeam + | ContinueBeam + | EndBeam + | ForwardHook + | BackwardHook + +type StartStop = StartStopContinueChange +type StartStopChange = StartStopContinueChange +type StartStopContinue = StartStopContinueChange + +data StartStopContinueChange + = Start + | Stop + | Continue + | Change + +data StemDirection + = StemDown + | StemUp + | StemNone + | StemDouble + +data LineType + = Solid + | Dashed + | Dotted + | Wavy + +data NoteHead + = SlashNoteHead + | TriangleNoteHead + | DiamondNoteHead + | SquareNoteHead + | CrossNoteHead + | XNoteHead + | CircleXNoteHead + | InvertedTriangleNoteHead + | ArrowDownNoteHead + | ArrowUpNoteHead + | SlashedNoteHead + | BackSlashedNoteHead + | NormalNoteHead + | ClusterNoteHead + | CircleDotNoteHead + | LeftTriangleNoteHead + | RectangleNoteHead + | NoNoteHead -- "none" + +deriving instance Eq Level +deriving instance Show Level +deriving instance Num Level + +-- ---------------------------------------------------------------------------------- + +-- Bounded ints +type Max8 = Index N8 + +notImplemented x = error $ "Not implemented: " ++ x + + diff --git a/src/Data/Music/MusicXml/Simple.hs b/src/Data/Music/MusicXml/Simple.hs new file mode 100644 --- /dev/null +++ b/src/Data/Music/MusicXml/Simple.hs @@ -0,0 +1,859 @@ + +{-# 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 Data.Music.MusicXml.Simple ( + + module Data.Music.MusicXml, + + ----------------------------------------------------------------------------- + -- * Score and parts + ----------------------------------------------------------------------------- + + -- ** Basic constructors + fromPart, + fromParts, + + -- ** Part lists + partList, + partListDisplay, + partListAbbr, + bracket, + brace, + + -- ** Measures + measure, + bar, + + -- -- ** Others + -- standardPartAttributes, + -- header, + -- setHeader, + -- setTitle, + -- setMovementTitle, + + ----------------------------------------------------------------------------- + -- * Top-level attributes + ----------------------------------------------------------------------------- + + -- ** Pitch + trebleClef, + altoClef, + bassClef, + defaultClef, + clef, + defaultKey, + key, + + -- ** Time + defaultDivisions, + divisions, + commonTime, + cutTime, + time, + staves, + + -- ** Tempo + -- TODO #15 tempo + metronome, + metronome', + + ----------------------------------------------------------------------------- + -- * Backup and forward + ----------------------------------------------------------------------------- + + backup, + forward, + + ----------------------------------------------------------------------------- + -- * 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 + ----------------------------------------------------------------------------- + + addTechnical, + addArticulation, + + -- ** Technical + upbow, + downbow, + harmonic, + openString, + + -- ** 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, + + ----------------------------------------------------------------------------- + -- * Folds and maps + ----------------------------------------------------------------------------- + + -- mapNote, + mapMusic, + foldMusic, + + ) +where + +import Data.Default +import Data.Ratio +import Data.Monoid +import Control.Arrow + +import Data.Music.MusicXml +import Data.Music.MusicXml.Score +import Data.Music.MusicXml.Time +import Data.Music.MusicXml.Pitch +import Data.Music.MusicXml.Dynamics +import Data.Music.MusicXml.Read +import Data.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) + (addPartwiseAttributes music) + +-- |  +-- Create a part list from instrument names. +-- +partList :: [String] -> PartList +partList = PartList . zipWith (\partId name -> Part partId name Nothing Nothing Nothing) standardPartAttributes + +-- |  +-- Create a part list from instrument names and displayed names (some applications need the name to be something +-- specific, so use displayed name to override). +-- +partListDisplay :: [(String, String)] -> PartList +partListDisplay = PartList . zipWith (\partId (name,dispName) -> Part partId name Nothing (Just dispName) 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) Nothing Nothing) standardPartAttributes + +-- | +-- 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 :: ScoreHeader -> Score -> Score +setHeader header (Partwise attrs _ music) = Partwise attrs header music +setHeader header (Timewise attrs _ music) = Timewise attrs header music + +setTitle :: String -> ScoreHeader -> ScoreHeader +setTitle title (ScoreHeader _ mvmTitle ident partList) = ScoreHeader (Just title) mvmTitle ident partList + +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 = 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 +-- ---------------------------------------------------------------------------------- + +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 + +staves :: Int -> Music +staves n = Music $ single $ MusicAttributes $ Staves (fromIntegral n) + + +-- | +-- 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 + + +backup :: Duration -> Music +backup d = Music . single $ MusicBackup d + +forward :: Duration -> Music +forward d = Music . single $ MusicForward d + +-- ---------------------------------------------------------------------------------- +-- Notes +-- ---------------------------------------------------------------------------------- + +-- | +-- Create a rest. +-- +-- > rest (1/4) +-- > rest (3/8) +-- > rest quarter +-- > rest (dotted eight) +-- +rest :: NoteVal -> Music +-- rest = rest' +rest dur = case dots of + 0 -> rest' dur' + 1 -> rest' dur' <> rest' (dur' / 2) + 2 -> rest' dur' <> rest' (dur' / 2) <> rest' (dur' / 4) + 3 -> rest' dur' <> rest' (dur' / 2) <> rest' (dur' / 4) <> rest' (dur' / 8) + _ -> error "Data.Music.MusicXml.Simple.rest: too 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 "Data.Music.MusicXml.Simple.separateDots: Note value must be a multiple of two or dotted" + + + +setVoice :: Int -> Music -> Music +setVoice n = Music . fmap (modifyNoteProps (setVoiceP n)) . getMusic + +dot :: Music -> Music +setNoteVal :: NoteVal -> Music -> Music +setTimeMod :: Int -> Int -> Music -> Music +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 (modifyNoteProps (addNotationP x)) . getMusic + +setNoteHead :: NoteHead -> Music -> Music +setNoteHead x = Music . fmap (modifyNoteProps (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 (modifyNoteProps (beginBeamP 1)) . getMusic +continueBeam = Music . fmap (modifyNoteProps (continueBeamP 1)) . getMusic +endBeam = Music . fmap (modifyNoteProps (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]) + +-- ---------------------------------------------------------------------------------- + +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]) +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] + +tuplet :: Int -> Int -> Music -> Music +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] +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 + +-- ---------------------------------------------------------------------------------- + +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 + 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 [] [] + + + +------------------------------------------------------------------------------------- + + +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 = (==) + + diff --git a/src/Data/Music/MusicXml/Time.hs b/src/Data/Music/MusicXml/Time.hs new file mode 100644 --- /dev/null +++ b/src/Data/Music/MusicXml/Time.hs @@ -0,0 +1,87 @@ + +{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : portable +-- +------------------------------------------------------------------------------------- + +module Data.Music.MusicXml.Time ( + Duration(..), + NoteType(..), + + Divs(..), + NoteVal(..), + NoteSize(..), + + Beat(..), + BeatType(..), + + Tempo(..) + ) where + +type Duration = Divs +type NoteType = (NoteVal, Maybe NoteSize) + +newtype Divs = Divs { getDivs :: Int } -- ^ Sounding time in ticks +newtype NoteVal = NoteVal { getNoteVal :: Rational } -- ^ Notated time in fractions, in @[2^^i | i <- [-10..3]]@. + +data NoteSize = SizeFull | SizeCue | SizeLarge + +newtype Beat = Beat { getBeat :: Int } -- ^ Time nominator +newtype BeatType = BeatType { getBeatType :: Int } -- ^ Time denominator + +newtype Tempo = Tempo { getTempo :: Double } -- ^ Tempo in BPM + + + + +deriving instance Eq Divs +deriving instance Ord Divs +deriving instance Num Divs +deriving instance Real Divs +deriving instance Integral Divs +deriving instance Enum Divs +deriving instance Show Divs + +deriving instance Eq NoteVal +deriving instance Ord NoteVal +deriving instance Num NoteVal +deriving instance Enum NoteVal +deriving instance Fractional NoteVal +deriving instance Real NoteVal +deriving instance RealFrac NoteVal +deriving instance Show NoteVal + +deriving instance Eq NoteSize +deriving instance Ord NoteSize +deriving instance Enum NoteSize +deriving instance Bounded NoteSize + +deriving instance Eq Beat +deriving instance Ord Beat +deriving instance Num Beat +deriving instance Enum Beat + +deriving instance Eq BeatType +deriving instance Ord BeatType +deriving instance Num BeatType +deriving instance Enum BeatType + +deriving instance Eq Tempo +deriving instance Ord Tempo +deriving instance Num Tempo +deriving instance Enum Tempo +deriving instance Fractional Tempo +deriving instance Real Tempo +deriving instance RealFrac Tempo +deriving instance Show Tempo + + diff --git a/src/Data/Music/MusicXml/Write.hs b/src/Data/Music/MusicXml/Write.hs new file mode 100644 --- /dev/null +++ b/src/Data/Music/MusicXml/Write.hs @@ -0,0 +1,23 @@ + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : portable +-- +------------------------------------------------------------------------------------- + +module Data.Music.MusicXml.Write ( + WriteMusicXml(..) + + ) where + +import Text.XML.Light (Element) + +class WriteMusicXml a where + write :: a -> [Element] + diff --git a/src/Data/Music/MusicXml/Write/Score.hs b/src/Data/Music/MusicXml/Write/Score.hs new file mode 100644 --- /dev/null +++ b/src/Data/Music/MusicXml/Write/Score.hs @@ -0,0 +1,586 @@ + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : portable +-- +------------------------------------------------------------------------------------- + +module Data.Music.MusicXml.Write.Score ( + ) where + +import Prelude hiding (getLine) + +import Data.Maybe (maybeToList) +import Data.Semigroup +import Data.Default +import Numeric.Natural + +import Text.XML.Light hiding (Line) + +import Data.Music.MusicXml.Score +import Data.Music.MusicXml.Time +import Data.Music.MusicXml.Pitch +import Data.Music.MusicXml.Dynamics +import Data.Music.MusicXml.Read +import Data.Music.MusicXml.Write + +import qualified Data.List as List +import qualified Data.Char as Char + + +-- This instance is used by toXml and should return a single list +instance WriteMusicXml Score where + write (Partwise attr + header + parts) = single + $ unode "score-partwise" + $ write header <> writePartwise parts + + write (Timewise attr + header + measures) = single + $ unode "timewise-score" + $ write header <> writeTimewise measures + +writePartwise :: [(PartAttrs, [(MeasureAttrs, Music)])] -> [Element] +writeTimewise :: [(MeasureAttrs, [(PartAttrs, Music)])] -> [Element] + +writePartwise = fmap (\(attrs, measures) -> writePartElem attrs $ + fmap (\(attrs, music) -> writeMeasureElem attrs $ + writeMusic music) measures) + +writeTimewise = fmap (\(attrs, parts) -> writeMeasureElem attrs $ + fmap (\(attrs, music) -> writePartElem attrs $ + writeMusic music) parts) + +writePartElem attrs = addPartAttrs attrs . unode "part" +writeMeasureElem attrs = addMeasureAttrs attrs . unode "measure" +writeMusic = concatMap write . getMusic + +addScoreAttrs :: ScoreAttrs -> Element -> Element +addPartAttrs :: PartAttrs -> Element -> Element +addMeasureAttrs :: MeasureAttrs -> Element -> Element + +addScoreAttrs (ScoreAttrs []) = id +addScoreAttrs (ScoreAttrs xs) = addAttr (uattr "version" $ concatSep "." $ map show xs) + +addPartAttrs (PartAttrs x) = addAttr (uattr "id" x) +addMeasureAttrs (MeasureAttrs n) = addAttr (uattr "number" $ show n) + + +instance WriteMusicXml ScoreHeader where + write (ScoreHeader title + mvm + ident + partList) = mempty <> writeTitle title + <> writeMvm mvm + <> writeIdent ident + <> writePartList partList + where { + writeTitle, writeMvm :: Maybe String -> [Element] ; + writeIdent :: Maybe Identification -> [Element] ; + writePartList :: PartList -> [Element] ; + + writeTitle = fmap (unode "title") . maybeToList ; + writeMvm = fmap (unode "movement-title") . maybeToList ; + writeIdent = single . unode "identification" . (write =<<) . maybeToList ; + writePartList = single . unode "part-list" . (write =<<) . getPartList ; + } + +instance WriteMusicXml Identification where + write (Identification creators) = map writeCreator creators + where + writeCreator (Creator t n) = unode "creator" (uattr "type" t, n) + + + + +-- ---------------------------------------------------------------------------------- +-- Part list +-- ---------------------------------------------------------------------------------- + +instance WriteMusicXml PartListElem where + write (Part id + name + abbrev + nameDisplay + abbrevDisplay + ) = single + $ addAttr (uattr "id" id) + $ unode "score-part" + $ mconcat [writeName name, writeAbbrev abbrev, + writeNameDisplay nameDisplay, writeAbbrevDisplay abbrevDisplay] + where + writeName = single . unode "part-name" + writeAbbrev = maybeToList . fmap (unode "part-abbreviation") + writeNameDisplay = maybeToList . fmap (unode "part-name-display" . unode "display-text") + writeAbbrevDisplay = maybeToList . fmap (unode "part-abbreviation-display" . unode "display-text") + + write (Group level + startStop + name + abbrev + symbol + barlines + time) = single + $ addAttr (uattr "number" $ show $ getLevel level) + $ addAttr (uattr "type" $ writeStartStop startStop) + $ unode "part-group" + $ mempty + <> writeName name + <> writeAbbrev abbrev + <> writeSymbol symbol + <> writeBarlines barlines + where + writeName = single . unode "group-name" + writeAbbrev = maybeToList . fmap (unode "group-abbreviation") + writeSymbol = maybeToList . fmap (unode "group-symbol" . writeGroupSymbol) + writeBarlines = maybeToList . fmap (unode "group-barline" . writeGroupBarlines) + +writeGroupSymbol :: GroupSymbol -> String +writeGroupBarlines :: GroupBarlines -> String + +-- ---------------------------------------------------------------------------------- +-- Music +-- ---------------------------------------------------------------------------------- + +instance WriteMusicXml MusicElem where + 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 +-- ---------------------------------------------------------------------------------- + + +instance WriteMusicXml Attributes where + write (Divisions divs) = single $ unode "divisions" + $ show $ getDivs divs + + write (Clef sign line) = single $ unode "clef" + [ unode "sign" (writeClef sign), + unode "line" (show $ getLine line)] + + write (Key fifths mode) = single $ unode "key" + [ unode "fifths" (show $ getFifths fifths), + unode "mode" (writeMode mode)] + + write (Time (CommonTime)) = single $ addAttr (uattr "symbol" "common") + $ unode "time" + [ unode "beats" (show 4), + unode "beat-type" (show 4)] + + write (Time (CutTime)) = single $ addAttr (uattr "symbol" "cut") + $ unode "time" + [ unode "beats" (show 2), + unode "beat-type" (show 2) ] + + write (Time (DivTime beats beatType)) = single $ unode "time" + [ unode "beats" (show $ getBeat beats), + unode "beat-type" (show $ getBeatType beatType)] + + write (Staves n) = single $ unode "staves" $ show n + +-- ---------------------------------------------------------------------------------- +-- Notes +-- ---------------------------------------------------------------------------------- + +instance WriteMusicXml NoteProps where + write (NoteProps + instrument -- TODO + voice + typ + dots + accidental -- TODO + timeMod -- TODO + stem -- TODO + noteHead + noteHeadText -- TODO + staff -- TODO + beam + notations + lyrics) -- TODO + = mempty + -- TODO instrument + <> maybeOne (\n -> unode "voice" $ show n) voice + <> maybeOne (\(noteVal, noteSize) -> unode "type" (writeNoteVal noteVal)) typ + <> replicate (fromIntegral dots) (unode "dot" ()) + -- TODO accidental + <> maybeOne (\(m, n) -> unode "time-modification" [ + unode "actual-notes" (show m), + unode "normal-notes" (show n) + ]) timeMod + -- TODO stem + <> maybeOne (\(nh,_,_) -> unode "notehead" (writeNoteHead nh)) noteHead + -- TODO notehead-text + -- TODO staff + <> maybeOne (\(n, typ) -> addAttr (uattr "number" $ show $ getLevel n) + $ unode "beam" $ writeBeamType typ) beam + + <> case notations of + [] -> [] + ns -> [unode "notations" (concatMap write ns)] + +instance WriteMusicXml FullNote where + write (Pitched isChord + (steps, alter, octaves)) = mempty + <> singleIf isChord (unode "chord" ()) + <> single (unode "pitch" (mempty + <> single ((unode "step" . show) steps) + <> maybeOne (unode "alter" . show . getSemitones) alter + <> single ((unode "octave" . show . getOctaves) octaves))) + write (Unpitched isChord + Nothing) = mempty + <> singleIf isChord (unode "chord" ()) + <> single (unode "unpitched" ()) + write (Unpitched isChord + (Just (steps, octaves))) = mempty + <> singleIf isChord (unode "chord" ()) + <> single (unode "unpitched" (mempty + <> single ((unode "display-step" . show) steps) + <> single ((unode "display-octave" . show . getOctaves) octaves))) + write (Rest isChord + Nothing) = mempty + <> singleIf isChord (unode "chord" ()) + <> single (unode "rest" ()) + write (Rest isChord + (Just (steps, octaves))) = mempty + <> singleIf isChord (unode "chord" ()) + <> single (unode "rest" (mempty + <> single ((unode "display-step" . show) steps) + <> single ((unode "display-octave" . show . getOctaves) octaves))) + + +instance WriteMusicXml Note where + write (Note full + dur + ties + props) = write full <> writeDuration dur + <> concatMap writeTie ties + <> write props + + write (CueNote full + dur + props) = [unode "cue" ()] <> write full + <> writeDuration dur + <> write props + + write (GraceNote full + ties + props) = [unode "grace" ()] <> write full + <> concatMap writeTie ties + <> write props +writeDuration :: Duration -> [Element] +writeDuration = single . unode "duration" . show . getDivs + +writeTie :: Tie -> [Element] +writeTie typ = single $ addAttr (uattr "type" $ writeStartStopContinue typ) $ unode "tie" () + + + +-- ---------------------------------------------------------------------------------- +-- Notations +-- ---------------------------------------------------------------------------------- + +instance WriteMusicXml Notation where + write (Tied typ) = single + $ addAttr (uattr "type" $ writeStartStopContinue typ) + $ unode "tied" () + write (Slur level typ) = single + $ addAttr (uattr "number" $ show $ getLevel level) + $ addAttr (uattr "type" $ writeStartStopContinue typ) + $ unode "slur" () + write (Tuplet level typ) = single + $ addAttr (uattr "number" $ show $ getLevel level) + $ addAttr (uattr "type" $ writeStartStopContinue typ) + $ unode "tuplet" () + + write (Glissando level typ lineTyp text) = single + $ addAttr (uattr "number" $ show $ getLevel level) + $ addAttr (uattr "type" $ writeStartStopContinue typ) + $ addAttr (uattr "line-type" $ writeLineType lineTyp) + $ case text of + Nothing -> unode "glissando" () + Just text -> unode "glissando" text + + write (Slide level typ lineTyp text) = single + $ addAttr (uattr "number" $ show $ getLevel level) + $ addAttr (uattr "type" $ writeStartStopContinue typ) + $ addAttr (uattr "line-type" $ writeLineType lineTyp) + $ case text of + Nothing -> unode "slide" () + Just text -> unode "slide" text + + write (Ornaments xs) = single $ unode "ornaments" (concatMap writeOrnamentWithAcc xs) + where + writeOrnamentWithAcc (o, as) = write o + <> fmap (unode "accidental-mark" . writeAccidental) as + + write (Technical xs) = single $ unode "technical" (concatMap write xs) + write (Articulations xs) = single $ unode "articulations" (concatMap write xs) + write (DynamicNotation dyn) = single $ unode "dynamics" (writeDynamics dyn) + write (Fermata sign) = single $ unode "fermata" (writeFermataSign sign) + write Arpeggiate = single $ unode "arpeggiate" () + write NonArpeggiate = single $ unode "non-arpeggiate" () + write (AccidentalMark acc) = single $ unode "accidental-mark" (writeAccidental acc) + write (OtherNotation not) = notImplemented "OtherNotation" + +instance WriteMusicXml Ornament where + write TrillMark = single $ unode "trill-mark" () + write Turn = single $ unode "turn" () + write DelayedTurn = single $ unode "delayed-turn" () + write InvertedTurn = single $ unode "inverted-turn" () + write DelayedInvertedTurn = single $ unode "delayed-inverted-turn" () + write VerticalTurn = single $ unode "vertical-turn" () + write Shake = single $ unode "shake" () + write WavyLine = single $ unode "wavyline" () + write Mordent = single $ unode "mordent" () + write InvertedMordent = single $ unode "inverted-mordent" () + write Schleifer = single $ unode "schleifer" () + write (Tremolo num) = single $ unode "tremolo" (show num) + +instance WriteMusicXml Technical where + write UpBow = single $ unode "up-bow" () + write DownBow = single $ unode "down-bow" () + write Harmonic = single $ unode "harmonic" () + write OpenString = single $ unode "openstring" () + write ThumbPosition = single $ unode "thumb-position" () + write Fingering = single $ unode "fingering" () + write Pluck = single $ unode "pluck" () + write DoubleTongue = single $ unode "double-tongue" () + write TripleTongue = single $ unode "triple-tongue" () + write Stopped = single $ unode "stopped" () + write SnapPizzicato = single $ unode "snap-pizzicato" () + write Fret = single $ unode "fret" () + write String = single $ unode "string" () + write HammerOn = single $ unode "hammer-on" () + write PullOff = single $ unode "pull-off" () + write Bend = single $ unode "bend" () + write Tap = single $ unode "tap" () + write Heel = single $ unode "heel" () + write Toe = single $ unode "toe" () + write Fingernails = single $ unode "fingernails" () + write Hole = single $ unode "hole" () + write Arrow = single $ unode "arrow" () + write Handbell = single $ unode "handbell" () + write (OtherTechnical tech) = notImplemented "OtherTechnical" + +instance WriteMusicXml Articulation where + write Accent = single $ unode "accent" () + write StrongAccent = single $ unode "strong-accent" () + write Staccato = single $ unode "staccato" () + write Tenuto = single $ unode "tenuto" () + write DetachedLegato = single $ unode "detached-legato" () + write Staccatissimo = single $ unode "staccatissimo" () + write Spiccato = single $ unode "spiccato" () + write Scoop = single $ unode "scoop" () + write Plop = single $ unode "plop" () + write Doit = single $ unode "doit" () + write Falloff = single $ unode "falloff" () + write BreathMark = single $ unode "breathmark" () + write Caesura = single $ unode "caesura" () + write Stress = single $ unode "stress" () + write Unstress = single $ unode "unstress" () + write OtherArticulation = notImplemented "OtherArticulation" + + + +-- ---------------------------------------------------------------------------------- +-- Directions +-- ---------------------------------------------------------------------------------- + +instance WriteMusicXml Direction where + write (Rehearsal str) = single $ unode "rehearsal" str + write Segno = single $ unode "segno" () + write (Words str) = single $ unode "words" str + write Coda = single $ unode "coda" () + + write (Crescendo Start) = single $ addAttr (uattr "type" "crescendo") $ unode "wedge" () + write (Diminuendo Start) = single $ addAttr (uattr "type" "diminuendo") $ unode "wedge" () + write (Crescendo Stop) = single $ addAttr (uattr "type" "stop") $ unode "wedge" () + write (Diminuendo Stop) = single $ addAttr (uattr "type" "stop") $ unode "wedge" () + + write (Dynamics dyn) = single $ unode "dynamics" (writeDynamics dyn) + write (Metronome noteVal dotted tempo) = single $ unode "metronome" $ + [ unode "beat-unit" (writeNoteVal noteVal) ] + <> singleIf dotted (unode "beat-unit-dot" ()) + <> [ unode "per-minute" (show $ round $ getTempo tempo) ] + write Bracket = notImplemented "Unsupported directions" + write (OtherDirection dir) = notImplemented "OtherDirection" + + +-- ---------------------------------------------------------------------------------- +-- Lyrics +-- ---------------------------------------------------------------------------------- + +instance WriteMusicXml Lyric where + write = notImplemented "WriteMusicXml instance for Lyric" + + +-- ---------------------------------------------------------------------------------- +-- Basic types +-- ---------------------------------------------------------------------------------- + + +writeBeamType BeginBeam = "begin" +writeBeamType ContinueBeam = "continue" +writeBeamType EndBeam = "end" +writeBeamType ForwardHook = "forward-hook" +writeBeamType BackwardHook = "backward-hook" + +writeStartStop = writeStartStopContinueChange +writeStartStopChange = writeStartStopContinueChange +writeStartStopContinue = writeStartStopContinueChange + +writeStartStopContinueChange Start = "start" +writeStartStopContinueChange Stop = "stop" +writeStartStopContinueChange Continue = "continue" +writeStartStopContinueChange Change = "change" + +writeStemDirection StemDown = "down" +writeStemDirection StemUp = "up" +writeStemDirection StemNone = "none" +writeStemDirection StemDouble = "double" + +writeLineType Solid = "solid" +writeLineType Dashed = "dashed" +writeLineType Dotted = "dotted" +writeLineType Wavy = "wavy" + +writeNoteHead SlashNoteHead = "slash" +writeNoteHead TriangleNoteHead = "triangle" +writeNoteHead DiamondNoteHead = "diamond" +writeNoteHead SquareNoteHead = "square" +writeNoteHead CrossNoteHead = "cross" +writeNoteHead XNoteHead = "x" +writeNoteHead CircleXNoteHead = "circle" +writeNoteHead InvertedTriangleNoteHead = "inverted-triangle" +writeNoteHead ArrowDownNoteHead = "arrow-down" +writeNoteHead ArrowUpNoteHead = "arrow-up" +writeNoteHead SlashedNoteHead = "slashed" +writeNoteHead BackSlashedNoteHead = "back-slashed" +writeNoteHead NormalNoteHead = "normal" +writeNoteHead ClusterNoteHead = "cluster" +writeNoteHead CircleDotNoteHead = "circle" +writeNoteHead LeftTriangleNoteHead = "left-triangle" +writeNoteHead RectangleNoteHead = "rectangle" +writeNoteHead NoNoteHead = "none" + +writeAccidental DoubleFlat = "double-flat" +writeAccidental Flat = "flat" +writeAccidental Natural = "natural" +writeAccidental Sharp = "sharp" +writeAccidental DoubleSharp = "double-sharp" + +writeNoteVal :: NoteVal -> String +writeNoteVal (NoteVal x) + | x == (1/1024) = "1024th" + | x == (1/512) = "512th" + | x == (1/256) = "256th" + | x == (1/128) = "128th" + | x == (1/64) = "64th" + | x == (1/32) = "32nd" + | x == (1/16) = "16th" + | x == (1/8) = "eighth" + | x == (1/4) = "quarter" + | x == (1/2) = "half" + | x == (1/1) = "whole" + | x == (2/1) = "breve" + | x == (4/1) = "long" + | x == (8/1) = "maxima" + | otherwise = error $ "Data.Music.MusicXml.Write.Score.wrietNoteVal: Invalid note value:" ++ show x + +writeClef :: ClefSign -> String +writeClef GClef = "G" +writeClef CClef = "C" +writeClef FClef = "F" +writeClef PercClef = "percussion" +writeClef TabClef = "tab" + +writeMode :: Mode -> String +writeMode NoMode = "none" +writeMode x = toLowerString . show $ x + +writeGroupSymbol GroupBrace = "brace" +writeGroupSymbol GroupLine = "line" +writeGroupSymbol GroupBracket = "bracket" +writeGroupSymbol GroupSquare = "square" +writeGroupSymbol NoGroupSymbol = "none" + +writeGroupBarlines GroupBarLines = "yes" +writeGroupBarlines GroupNoBarLines = "no" +writeGroupBarlines GroupMensurstrich = "Mensurstrich" + +writeFermataSign NormalFermata = "normal" +writeFermataSign AngledFermata = "angled" +writeFermataSign SquaredFermata = "squared" + +writeDynamics x = unode (toLowerString $ show x) () + + +-- ---------------------------------------------------------------------------------- + + +-- XML aliases + +addAttr :: Attr -> Element -> Element +addAttrs :: [Attr] -> Element -> Element +addAttr = add_attr +addAttrs = add_attrs + +uattr :: String -> String -> Attr +uattr n = Attr (unqual n) + + +-- Misc + +sep :: a -> [a] -> [a] +sep = List.intersperse + +concatSep :: [a] -> [[a]] -> [a] +concatSep x = concat . sep x + +toUpperChar :: Char -> Char +toUpperChar = Char.toUpper + +toLowerChar :: Char -> Char +toLowerChar = Char.toLower + +toUpperString :: String -> String +toUpperString = fmap Char.toUpper + +toLowerString :: String -> String +toLowerString = fmap Char.toLower + +toCapitalString :: String -> String +toCapitalString [] = [] +toCapitalString (x:xs) = toUpperChar x : toLowerString xs + +one :: (a -> b) -> a -> [b] +one f = single . f + +maybeOne :: (a -> b) -> Maybe a -> [b] +maybeOne f = maybeToList . fmap f + +single :: a -> [a] +single = return + +fromSingle :: [a] -> a +fromSingle [x] = x +fromSingle _ = error "fromSingle: non-single list" + +singleIf :: Bool -> a -> [a] +singleIf p x | not p = [] + | otherwise = [x] + + +notImplemented x = error $ "Not implemented: " ++ x diff --git a/src/Music/MusicXml.hs b/src/Music/MusicXml.hs deleted file mode 100644 --- a/src/Music/MusicXml.hs +++ /dev/null @@ -1,155 +0,0 @@ - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : portable --- --- A Haskell representation of MusicXML. --- You may want to use the "Music.MusicXml.Simple" module to generate the representation. --- --- For an introduction to MusicXML, see . --- -------------------------------------------------------------------------------------- - -module Music.MusicXml ( - - -- * Score - Score(..), - ScoreHeader(..), - Identification(..), - Creator(..), - Defaults(..), - ScoreAttrs(..), - PartAttrs(..), - MeasureAttrs(..), - - -- ** Part list - PartList(..), - PartListElem(..), - - -- * Music - Music(..), - MusicElem(..), - - -- ** Attributes - Attributes(..), - TimeSignature(..), - ClefSign(..), - - -- ** Notes - Note(..), - FullNote(..), - IsChord, - noChord, - Tie(..), - noTies, - NoteProps(..), - HasNoteProps(..), - - -- ** Notations - Notation(..), - Articulation(..), - Ornament(..), - Technical(..), - - -- ** Directions - Direction(..), - - -- ** Lyrics - Lyric(..), - - - - - -- * Basic types - - -- ** Pitch - Pitch(..), - DisplayPitch(..), - PitchClass, - Semitones(..), - noSemitones, - - Octaves(..), - Fifths(..), - Line(..), - - Mode(..), - Accidental(..), - - -- ** Time - Duration(..), - NoteType(..), - - Divs(..), - NoteVal(..), - NoteSize(..), - - Beat(..), - BeatType(..), - - - -- ** Dynamics - Dynamics, - - - ----------------------------------------------------------------------------- - -- ** Misc - - StemDirection(..), - NoteHead(..), - LineType(..), - - Level(..), - BeamType(..), - StartStop(..), - StartStopChange(..), - StartStopContinue(..), - StartStopContinueChange(..), - - - ----------------------------------------------------------------------------- - -- * Import and export functions - ----------------------------------------------------------------------------- - - toXml, - showXml - - ) where - -import Text.XML.Light hiding (Line) - -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 Music.MusicXml.Write.Score - --- -------------------------------------------------------------------------------- --- Import and export functions --- -------------------------------------------------------------------------------- - --- | --- Render a score as a MusicXML string. -showXml :: Score -> String -showXml = ppTopElement . toXml - --- | --- Render a score as MusicXML. -toXml :: Score -> Element -toXml = fromSingle . write - --- -------------------------------------------------------------------------------- - -fromSingle :: [a] -> a -fromSingle [x] = x -fromSingle _ = error "fromSingle: non-single list" - diff --git a/src/Music/MusicXml/Dynamics.hs b/src/Music/MusicXml/Dynamics.hs deleted file mode 100644 --- a/src/Music/MusicXml/Dynamics.hs +++ /dev/null @@ -1,67 +0,0 @@ - -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------- - -module Music.MusicXml.Dynamics ( - - Dynamics(..) - - ) where - -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 - | RFZ - | SFZ - | SFFZ - | FZ - deriving (Eq, Ord, Show, Enum, Bounded) - -instance IsDynamics Dynamics where - fromDynamics (DynamicsL (Just x, Nothing)) = case x of - (-6.5) -> PPPPPP - (-5.5) -> PPPPP - (-4.5) -> PPPP - (-3.5) -> PPP - (-2.5) -> PP - (-1.5) -> P - (-0.5) -> MP - 0.5 -> MF - 1.5 -> F - 2.5 -> FF - 3.5 -> FFF - 4.5 -> FFFF - 5.5 -> FFFFF - 6.5 -> FFFFFF - fromDynamics _ = error "fromDynamics: Unsupported literal for MusicXml.Dynamics" - diff --git a/src/Music/MusicXml/Pitch.hs b/src/Music/MusicXml/Pitch.hs deleted file mode 100644 --- a/src/Music/MusicXml/Pitch.hs +++ /dev/null @@ -1,119 +0,0 @@ - -{-# LANGUAGE - GeneralizedNewtypeDeriving, - StandaloneDeriving, - TypeSynonymInstances, - FlexibleInstances #-} - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------- - -module Music.MusicXml.Pitch ( - - Pitch(..), - DisplayPitch(..), - PitchClass(..), - Semitones(..), - noSemitones, - - Octaves(..), - Fifths(..), - Line(..), - - Mode(..), - Accidental(..) - - ) where - -import Music.Pitch.Literal - -type Pitch = (PitchClass, Maybe Semitones, Octaves) -type DisplayPitch = (PitchClass, Octaves) - -data Mode = Major | Minor - | Dorian | Phrygian | Lydian | Mixolydian - | Aeolian | Ionian | Locrian | NoMode - -data Accidental = DoubleFlat | Flat | Natural | Sharp | DoubleSharp - -data PitchClass = C | D | E | F | G | A | B - -newtype Semitones = Semitones { getSemitones :: Double } -- ^ Semitones, i.e 100 cent -newtype Octaves = Octaves { getOctaves :: Int } -- ^ Octaves, i.e. 1200 cent -newtype Fifths = Fifths { getFifths :: Int } -- ^ Number of fifths upwards relative to C (i.e. F is -1, G is 1) -newtype Line = Line { getLine :: Int } -- ^ Line number, from bottom (i.e. 1-5) - - -noSemitones :: Maybe Semitones -noSemitones = Nothing - -deriving instance Eq PitchClass -deriving instance Ord PitchClass -deriving instance Enum PitchClass -deriving instance Show PitchClass - -deriving instance Eq Accidental -deriving instance Ord Accidental -deriving instance Enum Accidental - -deriving instance Eq Mode -deriving instance Ord Mode -deriving instance Enum Mode -deriving instance Show Mode - -deriving instance Eq Semitones -deriving instance Ord Semitones -deriving instance Num Semitones -deriving instance Enum Semitones -deriving instance Fractional Semitones - -deriving instance Eq Octaves -deriving instance Ord Octaves -deriving instance Num Octaves -deriving instance Enum Octaves -deriving instance Real Octaves -deriving instance Integral Octaves - -deriving instance Eq Fifths -deriving instance Ord Fifths -deriving instance Num Fifths -deriving instance Enum Fifths - -deriving instance Eq Line -deriving instance Ord Line -deriving instance Num Line -deriving instance Enum Line - -instance IsPitch Pitch where - fromPitch (PitchL (pc, Nothing, oct)) = (toEnum pc, Nothing, fromIntegral oct) - fromPitch (PitchL (pc, Just st, oct)) = (toEnum pc, Just $ fromRational $ toRational $ st, fromIntegral oct) - -instance IsPitch DisplayPitch where - fromPitch (PitchL (pc, _, oct)) = (toEnum pc, fromIntegral oct) - -instance IsPitch Fifths where - fromPitch (PitchL (pc, Nothing, _)) = pitchToFifths pc 0 - fromPitch (PitchL (pc, Just ac, _)) = pitchToFifths pc (round ac) - -pitchToFifths 1 (-1) = (-4) -pitchToFifths 2 (-1) = (-3) -pitchToFifths 4 (-1) = (-6) -pitchToFifths 5 (-1) = (-5) -pitchToFifths 6 (-1) = (-2) -pitchToFifths 0 0 = 0 -pitchToFifths 1 0 = 2 -pitchToFifths 2 0 = 4 -pitchToFifths 3 0 = (-1) -pitchToFifths 4 0 = 1 -pitchToFifths 5 0 = 3 -pitchToFifths 6 0 = 5 -pitchToFifths 3 1 = 6 diff --git a/src/Music/MusicXml/Read.hs b/src/Music/MusicXml/Read.hs deleted file mode 100644 --- a/src/Music/MusicXml/Read.hs +++ /dev/null @@ -1,17 +0,0 @@ - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------- - -module Music.MusicXml.Read ( - ) where - - diff --git a/src/Music/MusicXml/Score.hs b/src/Music/MusicXml/Score.hs deleted file mode 100644 --- a/src/Music/MusicXml/Score.hs +++ /dev/null @@ -1,606 +0,0 @@ - -{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------- - -module Music.MusicXml.Score ( - - ----------------------------------------------------------------------------- - -- * Score - ----------------------------------------------------------------------------- - - Score(..), - ScoreHeader(..), - Identification(..), - Creator(..), - Defaults(..), - ScoreAttrs(..), - PartAttrs(..), - MeasureAttrs(..), - - -- ** Part list - PartList(..), - PartListElem(..), - GroupSymbol(..), - GroupBarlines(..), - - ----------------------------------------------------------------------------- - -- * Music - ----------------------------------------------------------------------------- - - Music(..), - MusicElem(..), - - ----------------------------------------------------------------------------- - - -- ** Attributes - Attributes(..), - TimeSignature(..), - ClefSign(..), - - ----------------------------------------------------------------------------- - -- ** Notes - - Note(..), - FullNote(..), - IsChord, - noChord, - noTies, - Tie, - NoteProps(..), - HasNoteProps(..), - - ----------------------------------------------------------------------------- - -- ** Notations - - Notation(..), - FermataSign(..), - Articulation(..), - Ornament(..), - Technical(..), - - ----------------------------------------------------------------------------- - -- ** Directions - - Direction(..), - - ----------------------------------------------------------------------------- - -- ** Lyrics - - Lyric(..), - - - ----------------------------------------------------------------------------- - -- * Basic types - ----------------------------------------------------------------------------- - - ----------------------------------------------------------------------------- - -- ** Pitch - - Pitch(..), - DisplayPitch(..), - PitchClass, - Semitones(..), - noSemitones, - - Octaves(..), - Fifths(..), - Line(..), - - Mode(..), - Accidental(..), - - ----------------------------------------------------------------------------- - -- ** Time - - Duration(..), - NoteType(..), - - Divs(..), - NoteVal(..), - NoteSize(..), - - Beat(..), - BeatType(..), - - ----------------------------------------------------------------------------- - -- ** Dynamics - - Dynamics(..), - - ----------------------------------------------------------------------------- - -- ** Misc - - StemDirection(..), - NoteHead(..), - LineType(..), - - Level(..), - BeamType(..), - StartStop(..), - StartStopChange(..), - StartStopContinue(..), - StartStopContinueChange(..), - - ) where - -import Prelude hiding (getLine) - -import Data.Default -import Data.Semigroup -import Data.Foldable -import Numeric.Natural -import TypeUnary.Nat - -import Music.MusicXml.Time -import Music.MusicXml.Pitch -import Music.MusicXml.Dynamics - -import qualified Data.List as List - --- ---------------------------------------------------------------------------------- --- Score --- ---------------------------------------------------------------------------------- - -data Score - = Partwise - ScoreAttrs - ScoreHeader - [(PartAttrs, - [(MeasureAttrs, Music)])] -- music by part and time - | Timewise - ScoreAttrs - ScoreHeader - [(MeasureAttrs, - [(PartAttrs, Music)])] -- music by time and part - -data ScoreHeader - = ScoreHeader - (Maybe String) -- title - (Maybe String) -- movement title - (Maybe Identification) -- identification? - -- defaults? - -- credit* - PartList -- partlist? - - -data Identification - = Identification - [Creator] -- creator - -data Creator - = Creator - String -- type (composer, lyricist, arranger etc) - String -- name - -data Defaults - = Defaults - -- page layout (marigins, distance etc) - -- system layout - -- staff layout - -- scaling - -- appearance (line width etc) - -data ScoreAttrs - = ScoreAttrs - [Int] -- score version - -data PartAttrs - = PartAttrs - String -- part id - -data MeasureAttrs - = MeasureAttrs - Int -- measure number - - --- ---------------------------------------------------------------------------------- --- Part list --- ---------------------------------------------------------------------------------- - -newtype PartList = PartList { getPartList :: [PartListElem] } - --- TODO fix for #11, by overwriting id when part list is merged - -instance Default PartList where - def = PartList [] - -instance Semigroup PartList where - PartList xs <> PartList ys = PartList (setIds $ xs <> ys) - where - setIds = snd . List.mapAccumL setId partIds - setId id (Part _ name abbr) = (tail id, Part (head id) name abbr) - setId id x = (id, x) - partIds = [ "P" ++ show n | n <- [1..] ] - -instance Monoid PartList where - mempty = def - mappend = (<>) - -data PartListElem - = Part - String - String - (Maybe String) -- id name abbrev? - | Group - Level - StartStop - String - (Maybe String) - (Maybe GroupSymbol) - (Maybe GroupBarlines) - Bool -- number start/stop name abbrev? symbol barline style - -data GroupSymbol = GroupBrace | GroupLine | GroupBracket | GroupSquare | NoGroupSymbol -data GroupBarlines = GroupBarLines | GroupNoBarLines | GroupMensurstrich - --- ---------------------------------------------------------------------------------- --- Music --- ---------------------------------------------------------------------------------- - -newtype Music = Music { getMusic :: [MusicElem] } - deriving (Semigroup, Monoid) - -data MusicElem - = MusicAttributes - Attributes - | MusicBackup - Duration - | MusicForward - Duration - | MusicNote - Note - | MusicDirection - Direction - | MusicHarmony -- TODO - | MusicFiguredBass -- TODO - | MusicPrint -- TODO - | MusicSound -- TODO - | MusicBarline -- TODO - | MusicGrouping -- TODO - | MusicLink -- TODO - | MusicBookmark -- TODO - - --- ---------------------------------------------------------------------------------- --- Attributes --- ---------------------------------------------------------------------------------- - -data Attributes - = Divisions - Divs - | Key - Fifths - Mode - | Time - TimeSignature - | Staves - Natural - | PartSymbol -- TODO - | Instruments - Natural - | Clef - ClefSign - Line - | StaffDetails -- TODO - | Transpose -- TODO - | Directive -- TODO - | MeasureStyle -- TODO - -data TimeSignature - = CommonTime - | CutTime - | DivTime - Beat - BeatType - -data ClefSign - = GClef - | CClef - | FClef - | PercClef - | TabClef - deriving (Eq, Ord, Enum, Bounded) - - --- ---------------------------------------------------------------------------------- --- Notes --- ---------------------------------------------------------------------------------- - -data Note - = Note - FullNote - Duration - [Tie] - NoteProps - | CueNote - FullNote - Duration - NoteProps - | GraceNote - FullNote - [Tie] - NoteProps - -data FullNote - = Pitched - IsChord - Pitch - | Unpitched - IsChord - (Maybe DisplayPitch) - | Rest - IsChord - (Maybe DisplayPitch) - -type IsChord = Bool -type Tie = StartStop - -data NoteProps - = NoteProps { - noteInstrument :: Maybe String, -- instrument - noteVoice :: Maybe Natural, -- voice - noteType :: Maybe NoteType, -- type - noteDots :: Natural, -- dots - noteAccidental :: Maybe (Accidental, Bool, Bool), -- accidental, cautionary, editorial - noteTimeMod :: Maybe (Natural, Natural), -- actual, normal - noteStem :: Maybe StemDirection, -- stem - noteNoteHead :: Maybe (NoteHead, Bool, Bool), -- notehead, filled, parentheses - noteNoteHeadText :: Maybe String, -- notehead-text - noteStaff :: Maybe Natural, -- staff - noteBeam :: Maybe (Level, BeamType), -- beam-level, beam-type - noteNotations :: [Notation], -- notation - noteLyrics :: [Lyric] -- lyric - } - -noChord :: IsChord -noChord = False - -noTies :: [Tie] -noTies = [] - - -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 - - - --- ---------------------------------------------------------------------------------- --- Notations --- ---------------------------------------------------------------------------------- - -data Notation - = Tied - StartStopContinue -- type - | Slur - Level - StartStopContinue -- level start/stop - | Tuplet - Level - StartStopContinue -- level start/stop - | Glissando - Level - StartStopContinue - LineType - (Maybe String) -- level type start/stop text? - | Slide - Level - StartStopContinue - LineType - (Maybe String) -- level type start/stop text? - | Ornaments - [(Ornament, [Accidental])] - | Technical - [Technical] - | Articulations - [Articulation] - | DynamicNotation - Dynamics - | Fermata FermataSign - | Arpeggiate - | NonArpeggiate - | AccidentalMark - Accidental - | OtherNotation - String - -data FermataSign = NormalFermata | AngledFermata | SquaredFermata - -data Articulation - = Accent - | StrongAccent - | Staccato - | Tenuto - | DetachedLegato - | Staccatissimo - | Spiccato - | Scoop - | Plop - | Doit - | Falloff - | BreathMark - | Caesura - | Stress - | Unstress - | OtherArticulation - -data Ornament - = TrillMark - | Turn - | DelayedTurn - | InvertedTurn - | DelayedInvertedTurn - | VerticalTurn - | Shake - | WavyLine - | Mordent - | InvertedMordent - | Schleifer - | Tremolo - Natural -- TODO restrict to (1..8) range - | OtherOrnament - String - -data Technical - = UpBow - | DownBow - | Harmonic - | OpenString - | ThumbPosition - | Fingering - | Pluck - | DoubleTongue - | TripleTongue - | Stopped - | SnapPizzicato - | Fret - | String - | HammerOn - | PullOff - | Bend - | Tap - | Heel - | Toe - | Fingernails - | Hole - | Arrow - | Handbell - | OtherTechnical - String - --- ---------------------------------------------------------------------------------- --- Directions --- ---------------------------------------------------------------------------------- - -data Direction - = Rehearsal - String - | Segno - | Words - String - | Coda - | Crescendo - StartStop -- start/stop - | Diminuendo - StartStop -- start/stop - | Dynamics - Dynamics - | Dashes - Level - StartStop -- level start/stop - | Bracket -- TODO - | Pedal - StartStopChange - | Metronome - NoteVal - Bool - Tempo -- noteVal isDotted bpm - | OctaveShift -- TODO - | HarpPedals -- TODO - | Damp -- TODO - | DampAll -- TODO - | EyeGlasses -- TODO - | StringMute -- TODO - | Scordatura -- TODO - | Image -- TODO - | PrincipalVoice -- TODO - | AccordionRegistration -- TODO - | Percussion -- TODO - | OtherDirection - String - - --- ---------------------------------------------------------------------------------- --- Lyrics --- ---------------------------------------------------------------------------------- - -data Lyric = Lyric -- TODO - - --- ---------------------------------------------------------------------------------- --- Basic types --- ---------------------------------------------------------------------------------- - -newtype Level = Level { getLevel :: Max8 } - -data BeamType - = BeginBeam - | ContinueBeam - | EndBeam - | ForwardHook - | BackwardHook - -type StartStop = StartStopContinueChange -type StartStopChange = StartStopContinueChange -type StartStopContinue = StartStopContinueChange - -data StartStopContinueChange - = Start - | Stop - | Continue - | Change - -data StemDirection - = StemDown - | StemUp - | StemNone - | StemDouble - -data LineType - = Solid - | Dashed - | Dotted - | Wavy - -data NoteHead - = SlashNoteHead - | TriangleNoteHead - | DiamondNoteHead - | SquareNoteHead - | CrossNoteHead - | XNoteHead - | CircleXNoteHead - | InvertedTriangleNoteHead - | ArrowDownNoteHead - | ArrowUpNoteHead - | SlashedNoteHead - | BackSlashedNoteHead - | NormalNoteHead - | ClusterNoteHead - | CircleDotNoteHead - | LeftTriangleNoteHead - | RectangleNoteHead - | NoNoteHead -- "none" - -deriving instance Eq Level -deriving instance Show Level -deriving instance Num Level - --- ---------------------------------------------------------------------------------- - --- Bounded ints -type Max8 = Index N8 - -notImplemented x = error $ "Not implemented: " ++ x - - diff --git a/src/Music/MusicXml/Simple.hs b/src/Music/MusicXml/Simple.hs deleted file mode 100644 --- a/src/Music/MusicXml/Simple.hs +++ /dev/null @@ -1,845 +0,0 @@ - -{-# 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 - -- standardPartAttributes, - -- header, - -- setHeader, - -- setTitle, - -- setMovementTitle, - - ----------------------------------------------------------------------------- - -- * Top-level attributes - ----------------------------------------------------------------------------- - - -- ** Pitch - trebleClef, - altoClef, - bassClef, - defaultClef, - clef, - defaultKey, - key, - - -- ** Time - defaultDivisions, - divisions, - commonTime, - cutTime, - time, - - -- ** Tempo - -- TODO #15 tempo - metronome, - metronome', - - ----------------------------------------------------------------------------- - -- * Backup and forward - ----------------------------------------------------------------------------- - - backup, - forward, - - ----------------------------------------------------------------------------- - -- * 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 - ----------------------------------------------------------------------------- - - addTechnical, - addArticulation, - - -- ** Technical - upbow, - downbow, - harmonic, - openString, - - -- ** 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, - - ----------------------------------------------------------------------------- - -- * 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 -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) - (addPartwiseAttributes music) - --- |  --- Create a part list from instrument names. --- -partList :: [String] -> PartList -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)) standardPartAttributes - --- | --- 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 :: ScoreHeader -> Score -> Score -setHeader header (Partwise attrs _ music) = Partwise attrs header music -setHeader header (Timewise attrs _ music) = Timewise attrs header music - -setTitle :: String -> ScoreHeader -> ScoreHeader -setTitle title (ScoreHeader _ mvmTitle ident partList) = ScoreHeader (Just title) mvmTitle ident partList - -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 = 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 --- ---------------------------------------------------------------------------------- - -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 - -backup :: Duration -> Music -backup d = Music . single $ MusicBackup d - -forward :: Duration -> Music -forward d = Music . single $ MusicForward d - --- ---------------------------------------------------------------------------------- --- Notes --- ---------------------------------------------------------------------------------- - --- | --- Create a rest. --- --- > rest (1/4) --- > rest (3/8) --- > rest quarter --- > rest (dotted eight) --- -rest :: NoteVal -> Music --- rest = rest' -rest dur = case dots of - 0 -> rest' dur' - 1 -> rest' dur' <> rest' (dur' / 2) - 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 - -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 (modifyNoteProps (setVoiceP n)) . getMusic - -dot :: Music -> Music -setNoteVal :: NoteVal -> Music -> Music -setTimeMod :: Int -> Int -> Music -> Music -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 (modifyNoteProps (addNotationP x)) . getMusic - -setNoteHead :: NoteHead -> Music -> Music -setNoteHead x = Music . fmap (modifyNoteProps (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 (modifyNoteProps (beginBeamP 1)) . getMusic -continueBeam = Music . fmap (modifyNoteProps (continueBeamP 1)) . getMusic -endBeam = Music . fmap (modifyNoteProps (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]) - --- ---------------------------------------------------------------------------------- - -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]) -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] - -tuplet :: Int -> Int -> Music -> Music -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] -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 - --- ---------------------------------------------------------------------------------- - -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 - 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 [] [] - - - -------------------------------------------------------------------------------------- - - -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 = (==) - - diff --git a/src/Music/MusicXml/Time.hs b/src/Music/MusicXml/Time.hs deleted file mode 100644 --- a/src/Music/MusicXml/Time.hs +++ /dev/null @@ -1,87 +0,0 @@ - -{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving #-} - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------- - -module Music.MusicXml.Time ( - Duration(..), - NoteType(..), - - Divs(..), - NoteVal(..), - NoteSize(..), - - Beat(..), - BeatType(..), - - Tempo(..) - ) where - -type Duration = Divs -type NoteType = (NoteVal, Maybe NoteSize) - -newtype Divs = Divs { getDivs :: Int } -- ^ Sounding time in ticks -newtype NoteVal = NoteVal { getNoteVal :: Rational } -- ^ Notated time in fractions, in @[2^^i | i <- [-10..3]]@. - -data NoteSize = SizeFull | SizeCue | SizeLarge - -newtype Beat = Beat { getBeat :: Int } -- ^ Time nominator -newtype BeatType = BeatType { getBeatType :: Int } -- ^ Time denominator - -newtype Tempo = Tempo { getTempo :: Double } -- ^ Tempo in BPM - - - - -deriving instance Eq Divs -deriving instance Ord Divs -deriving instance Num Divs -deriving instance Real Divs -deriving instance Integral Divs -deriving instance Enum Divs -deriving instance Show Divs - -deriving instance Eq NoteVal -deriving instance Ord NoteVal -deriving instance Num NoteVal -deriving instance Enum NoteVal -deriving instance Fractional NoteVal -deriving instance Real NoteVal -deriving instance RealFrac NoteVal -deriving instance Show NoteVal - -deriving instance Eq NoteSize -deriving instance Ord NoteSize -deriving instance Enum NoteSize -deriving instance Bounded NoteSize - -deriving instance Eq Beat -deriving instance Ord Beat -deriving instance Num Beat -deriving instance Enum Beat - -deriving instance Eq BeatType -deriving instance Ord BeatType -deriving instance Num BeatType -deriving instance Enum BeatType - -deriving instance Eq Tempo -deriving instance Ord Tempo -deriving instance Num Tempo -deriving instance Enum Tempo -deriving instance Fractional Tempo -deriving instance Real Tempo -deriving instance RealFrac Tempo -deriving instance Show Tempo - - diff --git a/src/Music/MusicXml/Write.hs b/src/Music/MusicXml/Write.hs deleted file mode 100644 --- a/src/Music/MusicXml/Write.hs +++ /dev/null @@ -1,23 +0,0 @@ - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------- - -module Music.MusicXml.Write ( - WriteMusicXml(..) - - ) where - -import Text.XML.Light (Element) - -class WriteMusicXml a where - write :: a -> [Element] - diff --git a/src/Music/MusicXml/Write/Score.hs b/src/Music/MusicXml/Write/Score.hs deleted file mode 100644 --- a/src/Music/MusicXml/Write/Score.hs +++ /dev/null @@ -1,578 +0,0 @@ - -------------------------------------------------------------------------------------- --- | --- Copyright : (c) Hans Hoglund 2012 --- --- License : BSD-style --- --- Maintainer : hans@hanshoglund.se --- Stability : experimental --- Portability : portable --- -------------------------------------------------------------------------------------- - -module Music.MusicXml.Write.Score ( - ) where - -import Prelude hiding (getLine) - -import Data.Maybe (maybeToList) -import Data.Semigroup -import Data.Default -import Numeric.Natural - -import Text.XML.Light hiding (Line) - -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 -import qualified Data.Char as Char - - --- This instance is used by toXml and should return a single list -instance WriteMusicXml Score where - write (Partwise attr - header - parts) = single - $ unode "score-partwise" - $ write header <> writePartwise parts - - write (Timewise attr - header - measures) = single - $ unode "timewise-score" - $ write header <> writeTimewise measures - -writePartwise :: [(PartAttrs, [(MeasureAttrs, Music)])] -> [Element] -writeTimewise :: [(MeasureAttrs, [(PartAttrs, Music)])] -> [Element] - -writePartwise = fmap (\(attrs, measures) -> writePartElem attrs $ - fmap (\(attrs, music) -> writeMeasureElem attrs $ - writeMusic music) measures) - -writeTimewise = fmap (\(attrs, parts) -> writeMeasureElem attrs $ - fmap (\(attrs, music) -> writePartElem attrs $ - writeMusic music) parts) - -writePartElem attrs = addPartAttrs attrs . unode "part" -writeMeasureElem attrs = addMeasureAttrs attrs . unode "measure" -writeMusic = concatMap write . getMusic - -addScoreAttrs :: ScoreAttrs -> Element -> Element -addPartAttrs :: PartAttrs -> Element -> Element -addMeasureAttrs :: MeasureAttrs -> Element -> Element - -addScoreAttrs (ScoreAttrs []) = id -addScoreAttrs (ScoreAttrs xs) = addAttr (uattr "version" $ concatSep "." $ map show xs) - -addPartAttrs (PartAttrs x) = addAttr (uattr "id" x) -addMeasureAttrs (MeasureAttrs n) = addAttr (uattr "number" $ show n) - - -instance WriteMusicXml ScoreHeader where - write (ScoreHeader title - mvm - ident - partList) = mempty <> writeTitle title - <> writeMvm mvm - <> writeIdent ident - <> writePartList partList - where { - writeTitle, writeMvm :: Maybe String -> [Element] ; - writeIdent :: Maybe Identification -> [Element] ; - writePartList :: PartList -> [Element] ; - - writeTitle = fmap (unode "title") . maybeToList ; - writeMvm = fmap (unode "movement-title") . maybeToList ; - writeIdent = single . unode "identification" . (write =<<) . maybeToList ; - writePartList = single . unode "part-list" . (write =<<) . getPartList ; - } - -instance WriteMusicXml Identification where - write (Identification creators) = map writeCreator creators - where - writeCreator (Creator t n) = unode "creator" (uattr "type" t, n) - - - - --- ---------------------------------------------------------------------------------- --- Part list --- ---------------------------------------------------------------------------------- - -instance WriteMusicXml PartListElem where - write (Part id - name - abbrev) = single - $ addAttr (uattr "id" id) - $ unode "score-part" - $ writeName name <> writeAbbrev abbrev - where - writeName = single . unode "part-name" - writeAbbrev = maybeToList . fmap (unode "part-abbreviation") - - write (Group level - startStop - name - abbrev - symbol - barlines - time) = single - $ addAttr (uattr "number" $ show $ getLevel level) - $ addAttr (uattr "type" $ writeStartStop startStop) - $ unode "part-group" - $ mempty - <> writeName name - <> writeAbbrev abbrev - <> writeSymbol symbol - <> writeBarlines barlines - where - writeName = single . unode "group-name" - writeAbbrev = maybeToList . fmap (unode "group-abbreviation") - writeSymbol = maybeToList . fmap (unode "group-symbol" . writeGroupSymbol) - writeBarlines = maybeToList . fmap (unode "group-barline" . writeGroupBarlines) - -writeGroupSymbol :: GroupSymbol -> String -writeGroupBarlines :: GroupBarlines -> String - --- ---------------------------------------------------------------------------------- --- Music --- ---------------------------------------------------------------------------------- - -instance WriteMusicXml MusicElem where - 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 --- ---------------------------------------------------------------------------------- - - -instance WriteMusicXml Attributes where - write (Divisions divs) = single $ unode "divisions" - $ show $ getDivs divs - - write (Clef sign line) = single $ unode "clef" - [ unode "sign" (writeClef sign), - unode "line" (show $ getLine line)] - - write (Key fifths mode) = single $ unode "key" - [ unode "fifths" (show $ getFifths fifths), - unode "mode" (writeMode mode)] - - write (Time (CommonTime)) = single $ addAttr (uattr "symbol" "common") - $ unode "time" - [ unode "beats" (show 4), - unode "beat-type" (show 4)] - - write (Time (CutTime)) = single $ addAttr (uattr "symbol" "cut") - $ unode "time" - [ unode "beats" (show 2), - unode "beat-type" (show 2) ] - - write (Time (DivTime beats beatType)) = single $ unode "time" - [ unode "beats" (show $ getBeat beats), - unode "beat-type" (show $ getBeatType beatType)] - --- ---------------------------------------------------------------------------------- --- Notes --- ---------------------------------------------------------------------------------- - -instance WriteMusicXml NoteProps where - write (NoteProps - instrument -- TODO - voice - typ - dots - accidental -- TODO - timeMod -- TODO - stem -- TODO - noteHead - noteHeadText -- TODO - staff -- TODO - beam - notations - lyrics) -- TODO - = mempty - -- TODO instrument - <> maybeOne (\n -> unode "voice" $ show n) voice - <> maybeOne (\(noteVal, noteSize) -> unode "type" (writeNoteVal noteVal)) typ - <> replicate (fromIntegral dots) (unode "dot" ()) - -- TODO accidental - <> maybeOne (\(m, n) -> unode "time-modification" [ - unode "actual-notes" (show m), - unode "normal-notes" (show n) - ]) timeMod - -- TODO stem - <> maybeOne (\(nh,_,_) -> unode "notehead" (writeNoteHead nh)) noteHead - -- TODO notehead-text - -- TODO staff - <> maybeOne (\(n, typ) -> addAttr (uattr "number" $ show $ getLevel n) - $ unode "beam" $ writeBeamType typ) beam - - <> case notations of - [] -> [] - ns -> [unode "notations" (concatMap write ns)] - -instance WriteMusicXml FullNote where - write (Pitched isChord - (steps, alter, octaves)) = mempty - <> singleIf isChord (unode "chord" ()) - <> single (unode "pitch" (mempty - <> single ((unode "step" . show) steps) - <> maybeOne (unode "alter" . show . getSemitones) alter - <> single ((unode "octave" . show . getOctaves) octaves))) - write (Unpitched isChord - Nothing) = mempty - <> singleIf isChord (unode "chord" ()) - <> single (unode "unpitched" ()) - write (Unpitched isChord - (Just (steps, octaves))) = mempty - <> singleIf isChord (unode "chord" ()) - <> single (unode "unpitched" (mempty - <> single ((unode "display-step" . show) steps) - <> single ((unode "display-octave" . show . getOctaves) octaves))) - write (Rest isChord - Nothing) = mempty - <> singleIf isChord (unode "chord" ()) - <> single (unode "rest" ()) - write (Rest isChord - (Just (steps, octaves))) = mempty - <> singleIf isChord (unode "chord" ()) - <> single (unode "rest" (mempty - <> single ((unode "display-step" . show) steps) - <> single ((unode "display-octave" . show . getOctaves) octaves))) - - -instance WriteMusicXml Note where - write (Note full - dur - ties - props) = write full <> writeDuration dur - <> concatMap writeTie ties - <> write props - - write (CueNote full - dur - props) = [unode "cue" ()] <> write full - <> writeDuration dur - <> write props - - write (GraceNote full - ties - props) = [unode "grace" ()] <> write full - <> concatMap writeTie ties - <> write props -writeDuration :: Duration -> [Element] -writeDuration = single . unode "duration" . show . getDivs - -writeTie :: Tie -> [Element] -writeTie typ = single $ addAttr (uattr "type" $ writeStartStopContinue typ) $ unode "tie" () - - - --- ---------------------------------------------------------------------------------- --- Notations --- ---------------------------------------------------------------------------------- - -instance WriteMusicXml Notation where - write (Tied typ) = single - $ addAttr (uattr "type" $ writeStartStopContinue typ) - $ unode "tied" () - write (Slur level typ) = single - $ addAttr (uattr "number" $ show $ getLevel level) - $ addAttr (uattr "type" $ writeStartStopContinue typ) - $ unode "slur" () - write (Tuplet level typ) = single - $ addAttr (uattr "number" $ show $ getLevel level) - $ addAttr (uattr "type" $ writeStartStopContinue typ) - $ unode "tuplet" () - - write (Glissando level typ lineTyp text) = single - $ addAttr (uattr "number" $ show $ getLevel level) - $ addAttr (uattr "type" $ writeStartStopContinue typ) - $ addAttr (uattr "line-type" $ writeLineType lineTyp) - $ case text of - Nothing -> unode "glissando" () - Just text -> unode "glissando" text - - write (Slide level typ lineTyp text) = single - $ addAttr (uattr "number" $ show $ getLevel level) - $ addAttr (uattr "type" $ writeStartStopContinue typ) - $ addAttr (uattr "line-type" $ writeLineType lineTyp) - $ case text of - Nothing -> unode "slide" () - Just text -> unode "slide" text - - write (Ornaments xs) = single $ unode "ornaments" (concatMap writeOrnamentWithAcc xs) - where - writeOrnamentWithAcc (o, as) = write o - <> fmap (unode "accidental-mark" . writeAccidental) as - - write (Technical xs) = single $ unode "technical" (concatMap write xs) - write (Articulations xs) = single $ unode "articulations" (concatMap write xs) - write (DynamicNotation dyn) = single $ unode "dynamics" (writeDynamics dyn) - write (Fermata sign) = single $ unode "fermata" (writeFermataSign sign) - write Arpeggiate = single $ unode "arpeggiate" () - write NonArpeggiate = single $ unode "non-arpeggiate" () - write (AccidentalMark acc) = single $ unode "accidental-mark" (writeAccidental acc) - write (OtherNotation not) = notImplemented "OtherNotation" - -instance WriteMusicXml Ornament where - write TrillMark = single $ unode "trill-mark" () - write Turn = single $ unode "turn" () - write DelayedTurn = single $ unode "delayed-turn" () - write InvertedTurn = single $ unode "inverted-turn" () - write DelayedInvertedTurn = single $ unode "delayed-inverted-turn" () - write VerticalTurn = single $ unode "vertical-turn" () - write Shake = single $ unode "shake" () - write WavyLine = single $ unode "wavyline" () - write Mordent = single $ unode "mordent" () - write InvertedMordent = single $ unode "inverted-mordent" () - write Schleifer = single $ unode "schleifer" () - write (Tremolo num) = single $ unode "tremolo" (show num) - -instance WriteMusicXml Technical where - write UpBow = single $ unode "up-bow" () - write DownBow = single $ unode "down-bow" () - write Harmonic = single $ unode "harmonic" () - write OpenString = single $ unode "openstring" () - write ThumbPosition = single $ unode "thumb-position" () - write Fingering = single $ unode "fingering" () - write Pluck = single $ unode "pluck" () - write DoubleTongue = single $ unode "double-tongue" () - write TripleTongue = single $ unode "triple-tongue" () - write Stopped = single $ unode "stopped" () - write SnapPizzicato = single $ unode "snap-pizzicato" () - write Fret = single $ unode "fret" () - write String = single $ unode "string" () - write HammerOn = single $ unode "hammer-on" () - write PullOff = single $ unode "pull-off" () - write Bend = single $ unode "bend" () - write Tap = single $ unode "tap" () - write Heel = single $ unode "heel" () - write Toe = single $ unode "toe" () - write Fingernails = single $ unode "fingernails" () - write Hole = single $ unode "hole" () - write Arrow = single $ unode "arrow" () - write Handbell = single $ unode "handbell" () - write (OtherTechnical tech) = notImplemented "OtherTechnical" - -instance WriteMusicXml Articulation where - write Accent = single $ unode "accent" () - write StrongAccent = single $ unode "strong-accent" () - write Staccato = single $ unode "staccato" () - write Tenuto = single $ unode "tenuto" () - write DetachedLegato = single $ unode "detached-legato" () - write Staccatissimo = single $ unode "staccatissimo" () - write Spiccato = single $ unode "spiccato" () - write Scoop = single $ unode "scoop" () - write Plop = single $ unode "plop" () - write Doit = single $ unode "doit" () - write Falloff = single $ unode "falloff" () - write BreathMark = single $ unode "breathmark" () - write Caesura = single $ unode "caesura" () - write Stress = single $ unode "stress" () - write Unstress = single $ unode "unstress" () - write OtherArticulation = notImplemented "OtherArticulation" - - - --- ---------------------------------------------------------------------------------- --- Directions --- ---------------------------------------------------------------------------------- - -instance WriteMusicXml Direction where - write (Rehearsal str) = single $ unode "rehearsal" str - write Segno = single $ unode "segno" () - write (Words str) = single $ unode "words" str - write Coda = single $ unode "coda" () - - write (Crescendo Start) = single $ addAttr (uattr "type" "crescendo") $ unode "wedge" () - write (Diminuendo Start) = single $ addAttr (uattr "type" "diminuendo") $ unode "wedge" () - write (Crescendo Stop) = single $ addAttr (uattr "type" "stop") $ unode "wedge" () - write (Diminuendo Stop) = single $ addAttr (uattr "type" "stop") $ unode "wedge" () - - write (Dynamics dyn) = single $ unode "dynamics" (writeDynamics dyn) - write (Metronome noteVal dotted tempo) = single $ unode "metronome" $ - [ unode "beat-unit" (writeNoteVal noteVal) ] - <> singleIf dotted (unode "beat-unit-dot" ()) - <> [ unode "per-minute" (show $ round $ getTempo tempo) ] - write Bracket = notImplemented "Unsupported directions" - write (OtherDirection dir) = notImplemented "OtherDirection" - - --- ---------------------------------------------------------------------------------- --- Lyrics --- ---------------------------------------------------------------------------------- - -instance WriteMusicXml Lyric where - write = notImplemented "WriteMusicXml instance for Lyric" - - --- ---------------------------------------------------------------------------------- --- Basic types --- ---------------------------------------------------------------------------------- - - -writeBeamType BeginBeam = "begin" -writeBeamType ContinueBeam = "continue" -writeBeamType EndBeam = "end" -writeBeamType ForwardHook = "forward-hook" -writeBeamType BackwardHook = "backward-hook" - -writeStartStop = writeStartStopContinueChange -writeStartStopChange = writeStartStopContinueChange -writeStartStopContinue = writeStartStopContinueChange - -writeStartStopContinueChange Start = "start" -writeStartStopContinueChange Stop = "stop" -writeStartStopContinueChange Continue = "continue" -writeStartStopContinueChange Change = "change" - -writeStemDirection StemDown = "down" -writeStemDirection StemUp = "up" -writeStemDirection StemNone = "none" -writeStemDirection StemDouble = "double" - -writeLineType Solid = "solid" -writeLineType Dashed = "dashed" -writeLineType Dotted = "dotted" -writeLineType Wavy = "wavy" - -writeNoteHead SlashNoteHead = "slash" -writeNoteHead TriangleNoteHead = "triangle" -writeNoteHead DiamondNoteHead = "diamond" -writeNoteHead SquareNoteHead = "square" -writeNoteHead CrossNoteHead = "cross" -writeNoteHead XNoteHead = "x" -writeNoteHead CircleXNoteHead = "circle" -writeNoteHead InvertedTriangleNoteHead = "inverted-triangle" -writeNoteHead ArrowDownNoteHead = "arrow-down" -writeNoteHead ArrowUpNoteHead = "arrow-up" -writeNoteHead SlashedNoteHead = "slashed" -writeNoteHead BackSlashedNoteHead = "back-slashed" -writeNoteHead NormalNoteHead = "normal" -writeNoteHead ClusterNoteHead = "cluster" -writeNoteHead CircleDotNoteHead = "circle" -writeNoteHead LeftTriangleNoteHead = "left-triangle" -writeNoteHead RectangleNoteHead = "rectangle" -writeNoteHead NoNoteHead = "none" - -writeAccidental DoubleFlat = "double-flat" -writeAccidental Flat = "flat" -writeAccidental Natural = "natural" -writeAccidental Sharp = "sharp" -writeAccidental DoubleSharp = "double-sharp" - -writeNoteVal :: NoteVal -> String -writeNoteVal (NoteVal x) - | x == (1/1024) = "1024th" - | x == (1/512) = "512th" - | x == (1/256) = "256th" - | x == (1/128) = "128th" - | x == (1/64) = "64th" - | x == (1/32) = "32nd" - | x == (1/16) = "16th" - | x == (1/8) = "eighth" - | x == (1/4) = "quarter" - | x == (1/2) = "half" - | x == (1/1) = "whole" - | x == (2/1) = "breve" - | x == (4/1) = "long" - | x == (8/1) = "maxima" - | otherwise = error $ "Music.MusicXml.Write.Score.wrietNoteVal: Invalid note value:" ++ show x - -writeClef :: ClefSign -> String -writeClef GClef = "G" -writeClef CClef = "C" -writeClef FClef = "F" -writeClef PercClef = "percussion" -writeClef TabClef = "tab" - -writeMode :: Mode -> String -writeMode NoMode = "none" -writeMode x = toLowerString . show $ x - -writeGroupSymbol GroupBrace = "brace" -writeGroupSymbol GroupLine = "line" -writeGroupSymbol GroupBracket = "bracket" -writeGroupSymbol GroupSquare = "square" -writeGroupSymbol NoGroupSymbol = "none" - -writeGroupBarlines GroupBarLines = "yes" -writeGroupBarlines GroupNoBarLines = "no" -writeGroupBarlines GroupMensurstrich = "Mensurstrich" - -writeFermataSign NormalFermata = "normal" -writeFermataSign AngledFermata = "angled" -writeFermataSign SquaredFermata = "squared" - -writeDynamics x = unode (toLowerString $ show x) () - - --- ---------------------------------------------------------------------------------- - - --- XML aliases - -addAttr :: Attr -> Element -> Element -addAttrs :: [Attr] -> Element -> Element -addAttr = add_attr -addAttrs = add_attrs - -uattr :: String -> String -> Attr -uattr n = Attr (unqual n) - - --- Misc - -sep :: a -> [a] -> [a] -sep = List.intersperse - -concatSep :: [a] -> [[a]] -> [a] -concatSep x = concat . sep x - -toUpperChar :: Char -> Char -toUpperChar = Char.toUpper - -toLowerChar :: Char -> Char -toLowerChar = Char.toLower - -toUpperString :: String -> String -toUpperString = fmap Char.toUpper - -toLowerString :: String -> String -toLowerString = fmap Char.toLower - -toCapitalString :: String -> String -toCapitalString [] = [] -toCapitalString (x:xs) = toUpperChar x : toLowerString xs - -one :: (a -> b) -> a -> [b] -one f = single . f - -maybeOne :: (a -> b) -> Maybe a -> [b] -maybeOne f = maybeToList . fmap f - -single :: a -> [a] -single = return - -fromSingle :: [a] -> a -fromSingle [x] = x -fromSingle _ = error "fromSingle: non-single list" - -singleIf :: Bool -> a -> [a] -singleIf p x | not p = [] - | otherwise = [x] - - -notImplemented x = error $ "Not implemented: " ++ x