diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,26 @@ + +Copyright (c) 2013, Hans Höglund +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/musicxml2.cabal b/musicxml2.cabal new file mode 100644 --- /dev/null +++ b/musicxml2.cabal @@ -0,0 +1,37 @@ + +name: musicxml2 +version: 1.4 +cabal-version: >= 1.2 +author: Hans Hoglund +maintainer: Hans Hoglund +license: BSD3 +license-file: COPYING +synopsis: A representation of the MusicXML format. +category: Music +tested-with: GHC +build-type: Simple + +description: + A representation of the MusicXML format. + +library + build-depends: + base >= 4 && < 5, + semigroups, data-default, type-unary, reverse-apply, + xml, + music-pitch-literal, + music-dynamics-literal + + hs-source-dirs: src + 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 + diff --git a/src/Music/MusicXml.hs b/src/Music/MusicXml.hs new file mode 100644 --- /dev/null +++ b/src/Music/MusicXml.hs @@ -0,0 +1,157 @@ + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : portable +-- +-- A Haskell representation of MusicXML. +-- +-- For an introduction, 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(..), + + -- TODO rewrite these + mapNoteProps, + mapNoteProps2, + + -- ** 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 new file mode 100644 --- /dev/null +++ b/src/Music/MusicXml/Dynamics.hs @@ -0,0 +1,51 @@ + +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Music/MusicXml/Pitch.hs @@ -0,0 +1,115 @@ + +{-# 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 new file mode 100644 --- /dev/null +++ b/src/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 Music.MusicXml.Read ( + ) where + + diff --git a/src/Music/MusicXml/Score.hs b/src/Music/MusicXml/Score.hs new file mode 100644 --- /dev/null +++ b/src/Music/MusicXml/Score.hs @@ -0,0 +1,600 @@ + +{-# 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(..), + mapNoteProps, + mapNoteProps2, + + ----------------------------------------------------------------------------- + -- ** 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 -- TODO + | MusicForward -- TODO + | 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 = [] + +mapNoteProps :: (NoteProps -> NoteProps) -> Note -> Note +mapNoteProps f (Note x d t p) = Note x d t (f p) +mapNoteProps f (CueNote x d p) = CueNote x d (f p) +mapNoteProps f (GraceNote x t p) = GraceNote x t (f p) + +mapNoteProps2 :: (NoteProps -> NoteProps) -> MusicElem -> MusicElem +mapNoteProps2 f (MusicNote n) = MusicNote (mapNoteProps f n) +mapNoteProps2 f x = x + + + +-- ---------------------------------------------------------------------------------- +-- 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 new file mode 100644 --- /dev/null +++ b/src/Music/MusicXml/Simple.hs @@ -0,0 +1,770 @@ + +{-# LANGUAGE ScopedTypeVariables, NoMonomorphismRestriction #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : portable +-- +-- Provides smart constructors for the MusicXML representation. +-- + +------------------------------------------------------------------------------------- + +module Music.MusicXml.Simple ( + + module Music.MusicXml, + + ----------------------------------------------------------------------------- + -- * Score and parts + ----------------------------------------------------------------------------- + + -- ** Basic constructors + fromPart, + fromParts, + + -- ** Part lists + partList, + partListAbbr, + bracket, + brace, + + -- ** Measures + measure, + bar, + + -- -- ** Others + -- partIds, + -- header, + -- setHeader, + -- setTitle, + -- setMvmTitle, + + ----------------------------------------------------------------------------- + -- * Top-level attributes + ----------------------------------------------------------------------------- + + -- ** Pitch + trebleClef, + altoClef, + bassClef, + defaultClef, + clef, + defaultKey, + key, + + -- ** Time + defaultDivisions, + divisions, + commonTime, + cutTime, + time, + + -- ** Tempo + -- TODO #15 tempo + metronome, + metronome', + + ----------------------------------------------------------------------------- + -- * Notes + ----------------------------------------------------------------------------- + + -- ** Basic constructors + rest, + note, + chord, + + -- ** Voice + setVoice, + + -- ** Duration + dot, + tuplet, + setNoteVal, + -- setTimeMod, + -- beginTuplet, + -- endTuplet, + separateDots, + + -- ** Beams + beam, + beginBeam, + continueBeam, + endBeam, + + -- ** Ties + beginTie, + endTie, + + -- ** Note heads + setNoteHead, + + -- ** Notations + addNotation, + + ----------------------------------------------------------------------------- + -- * Pitch transformations + ----------------------------------------------------------------------------- + + -- ** Glissando + beginGliss, + endGliss, + + -- ** Slides + beginSlide, + endSlide, + + ----------------------------------------------------------------------------- + -- * Time transformations + ----------------------------------------------------------------------------- + + -- ** Accelerando and ritardando + -- TODO #16 accelerando, + -- TODO #16 ritardando, + + -- ** Fermatas and breaks + fermata, + breathMark, + caesura, + + ----------------------------------------------------------------------------- + -- * Articulation + ----------------------------------------------------------------------------- + + -- ** Slurs + slur, + beginSlur, + endSlur, + + -- ** Staccato and tenuto + staccato, + tenuto, + spiccato, + staccatissimo, + + -- ** Accents + accent, + strongAccent, + + -- ** Miscellaneous + scoop, + plop, + doit, + falloff, + stress, + unstress, + + -- ** Ornaments + trill, + turn, + shake, + mordent, + tremolo, + + ----------------------------------------------------------------------------- + -- * Dynamics + ----------------------------------------------------------------------------- + + -- ** Crescendo and diminuendo + cresc, + dim, + beginCresc, + endCresc, + beginDim, + endDim, + + -- ** Dynamic levels + dynamic, + + -- ** Both + crescFrom, + crescTo, + crescFromTo, + dimFrom, + dimTo, + dimFromTo, + + ----------------------------------------------------------------------------- + -- * Text + ----------------------------------------------------------------------------- + + text, + rehearsal, + segno, + coda, + + ) +where + +import Data.Default +import Data.Ratio +import Data.Monoid + +import Music.MusicXml +import Music.MusicXml.Score +import Music.MusicXml.Time +import Music.MusicXml.Pitch +import Music.MusicXml.Dynamics +import Music.MusicXml.Read +import Music.MusicXml.Write + +import qualified Data.List as List + +-- ---------------------------------------------------------------------------------- +-- Score and parts +-- ---------------------------------------------------------------------------------- + +-- | +-- Create a single-part score. +-- +-- > fromPart title composer partName measures +-- +-- Example: +-- +-- @ 'fromPart' \"Suite\" \"Bach\" \"Cello solo\" [] @ +-- +fromPart :: String -> String -> String -> [Music] -> Score +fromPart title composer partName music = + fromParts title composer (partList [partName]) [music] + +-- | +-- Create a multi-part score. +-- +-- > fromParts title composer partList parts +-- +-- Example: +-- +-- @ 'fromParts' \"4'33\" \"Cage\" ('partList' [\"Violin\", \"Viola\", \"Cello\"]) [[]] @ +-- +fromParts :: String -> String -> PartList -> [[Music]] -> Score +fromParts title composer partList music + = Partwise + (def) + (header title composer partList) + (parts music) + + +partIds :: [String] +partIds = [ "P" ++ show n | n <- [1..] ] + +-- |  +-- Create a part list from instrument names. +-- +partList :: [String] -> PartList +partList = PartList . zipWith (\partId name -> Part partId name Nothing) partIds + +-- |  +-- Create a part list from instrument names and abbreviations. +-- +partListAbbr :: [(String, String)] -> PartList +partListAbbr = PartList . zipWith (\partId (name,abbr) -> Part partId name (Just abbr)) partIds + +-- | +-- Enclose the given parts in a bracket. +-- +bracket :: PartList -> PartList +bracket ps = PartList $ mempty + <> [Group 1 Start "" Nothing (Just GroupBracket) (Just GroupBarLines) False] + <> getPartList ps + <> [Group 1 Stop "" Nothing Nothing Nothing False] + +-- | +-- Enclose the given parts in a brace. +-- +brace :: PartList -> PartList +brace ps = PartList $ mempty + <> [Group 1 Start "" Nothing (Just GroupBrace) (Just GroupBarLines) False] + <> getPartList ps + <> [Group 1 Stop "" Nothing Nothing Nothing False] + + +-- | +-- Convenient synonym for 'mconcat', allowing us to write things like +-- +-- > measure [ +-- > beam [ +-- > note c (1/8), +-- > note d (1/8), +-- > note e (1/8), +-- > note f (1/8) +-- > ], +-- > tuplet 3 2 [ +-- > note g (1/4), +-- > note a (1/4), +-- > note b (1/4) +-- > ] +-- > ] +-- +measure :: [Music] -> Music +measure = mconcat + +-- | +-- Convenient synonym for 'mconcat'. +-- +bar :: [Music] -> Music +bar = measure + + +header :: String -> String -> PartList -> ScoreHeader +header title composer partList = ScoreHeader Nothing (Just title) (Just (Identification [Creator "composer" composer])) partList + +setHeader header (Partwise attrs _ music) = Partwise attrs header music +setHeader header (Timewise attrs _ music) = Timewise attrs header music + +setTitle title (ScoreHeader _ mvmTitle ident partList) = ScoreHeader title mvmTitle ident partList +setMvmTitle mvmTitle (ScoreHeader title _ ident partList) = ScoreHeader title (Just mvmTitle) ident partList +-- addIdent ident (ScoreHeader title mvmTitle idents partList) = ScoreHeader title mvmTitle (ident:idents) partList + +parts :: [[Music]] -> [(PartAttrs, [(MeasureAttrs, Music)])] +parts = zipWith (\ids mus -> (PartAttrs ids, zipWith (\ids mus -> (MeasureAttrs ids, mus)) barIds mus)) partIds' + where + partIds' = partIds + barIds = [1..] + + +-- ---------------------------------------------------------------------------------- +-- Top-level attributes +-- ---------------------------------------------------------------------------------- + +trebleClef, altoClef, bassClef :: Music +trebleClef = clef GClef 2 +altoClef = clef CClef 3 +bassClef = clef FClef 4 + +defaultClef :: Music +defaultClef = trebleClef + +-- | +-- Create a clef. +-- +clef :: ClefSign -> Line -> Music +clef symbol line = Music . single $ MusicAttributes $ Clef symbol line + +defaultKey :: Music +defaultKey = key 0 Major + +-- | +-- Create a key signature. +-- +key :: Fifths -> Mode -> Music +key n m = Music . single $ MusicAttributes $ Key n m + + +-- Number of ticks per whole note (we use 768 per quarter like Sibelius). +defaultDivisionsVal :: Divs +defaultDivisionsVal = 768 * 4 + +-- | +-- Set the tick division to the default value. +-- +defaultDivisions :: Music +defaultDivisions = Music $ single $ MusicAttributes $ Divisions $ defaultDivisionsVal `div` 4 + +-- | +-- Define the number of ticks per quarter note. +-- +divisions :: Divs -> Music +divisions n = Music . single $ MusicAttributes $ Divisions $ n + +commonTime, cutTime :: Music +commonTime = Music . single $ MusicAttributes $ Time CommonTime +cutTime = Music . single $ MusicAttributes $ Time CutTime + +-- | +-- Create a time signature. +-- +time :: Beat -> BeatType -> Music +time a b = Music . single $ MusicAttributes $ Time $ DivTime a b + +-- | +-- Create a metronome mark. +-- +metronome :: NoteVal -> Tempo -> Music +metronome nv tempo = case dots of + 0 -> metronome' nv' False tempo + 1 -> metronome' nv' True tempo + _ -> error "Metronome mark requires a maximum of one dot." + where + (nv', dots) = separateDots nv + +-- | +-- Create a metronome mark. +-- +metronome' :: NoteVal -> Bool -> Tempo -> Music +metronome' nv dot tempo = Music . single $ MusicDirection (Metronome nv dot tempo) + +-- TODO #15 tempo + + +-- ---------------------------------------------------------------------------------- +-- Notes +-- ---------------------------------------------------------------------------------- + +-- | +-- Create a rest. +-- +-- > rest (1/4) +-- > rest (3/8) +-- > rest quarter +-- > rest (dotted eight) +-- +rest :: NoteVal -> Music +rest dur = case dots of + 0 -> rest' dur' + 1 -> rest' dur' <> rest' (dur' / 2) + _ -> error "Music.MusicXml.Simple.rest: to many dots" + where + (dur', dots) = separateDots dur + +rest' :: NoteVal -> Music +rest' dur = Music . single $ MusicNote (Note def (defaultDivisionsVal `div` denom) noTies (setNoteValP val def)) + where + num = fromIntegral $ numerator $ toRational $ dur + denom = fromIntegral $ denominator $ toRational $ dur + val = NoteVal $ toRational $ dur + +-- | +-- Create a single note. +-- +-- > note c (1/4) +-- > note fs_ (3/8) +-- > note c quarter +-- > note (c + pure fifth) (dotted eight) +-- +note :: Pitch -> NoteVal -> Music +note pitch dur = note' False pitch dur' dots + where + (dur', dots) = separateDots dur + +chordNote :: Pitch -> NoteVal -> Music +chordNote pitch dur = note' True pitch dur' dots + where + (dur', dots) = separateDots dur + +-- | +-- Create a chord. +-- +-- > chord [c,eb,fs_] (3/8) +-- > chord [c,d,e] quarter +-- > chord [c,d,e] (dotted eight) +-- +chord :: [Pitch] -> NoteVal -> Music +chord [] d = rest d +chord (p:ps) d = note p d <> Music (concatMap (\p -> getMusic $ chordNote p d) ps) + + +note' :: Bool -> Pitch -> NoteVal -> Int -> Music +note' isChord pitch dur dots + = Music . single $ MusicNote $ + Note + (Pitched isChord $ pitch) + (defaultDivisionsVal `div` denom) + noTies + (setNoteValP val $ addDots $ def) + where + addDots = foldl (.) id (replicate dots dotP) + num = fromIntegral $ numerator $ toRational $ dur + denom = fromIntegral $ denominator $ toRational $ dur + val = NoteVal $ toRational $ dur + +separateDots :: NoteVal -> (NoteVal, Int) +separateDots = separateDots' [2/3, 6/7, 14/15, 30/31, 62/63] + +separateDots' :: [NoteVal] -> NoteVal -> (NoteVal, Int) +separateDots' [] nv = errorNoteValue +separateDots' (div:divs) nv + | isDivisibleBy 2 nv = (nv, 0) + | otherwise = (nv', dots' + 1) + where + (nv', dots') = separateDots' divs (nv*div) + +errorNoteValue = error "Music.MusicXml.Simple.separateDots: Note value must be a multiple of two or dotted" + + + +setVoice :: Int -> Music -> Music +setVoice n = Music . fmap (mapNoteProps2 (setVoiceP n)) . getMusic + +dot :: Music -> Music +setNoteVal :: NoteVal -> Music -> Music +setTimeMod :: Int -> Int -> Music -> Music +dot = Music . fmap (mapNoteProps2 dotP) . getMusic +setNoteVal x = Music . fmap (mapNoteProps2 (setNoteValP x)) . getMusic +setTimeMod m n = Music . fmap (mapNoteProps2 (setTimeModP m n)) . getMusic + +addNotation :: Notation -> Music -> Music +addNotation x = Music . fmap (mapNoteProps2 (addNotationP x)) . getMusic + +setNoteHead :: NoteHead -> Music -> Music +setNoteHead x = Music . fmap (mapNoteProps2 (mapNoteHeadP (const $ Just (x,False,False)))) . getMusic + +-- TODO clean up, skip empty notation groups etc +mergeNotations :: [Notation] -> [Notation] +mergeNotations notations = mempty + <> [foldOrnaments ornaments] + <> [foldTechnical technical] + <> [foldArticulations articulations] + <> others + where + (ornaments,notations') = List.partition isOrnaments notations + (technical,notations'') = List.partition isTechnical notations' + (articulations,others) = List.partition isArticulations notations' + + isOrnaments (Ornaments _) = True + isOrnaments _ = False + isTechnical (Technical _) = True + isTechnical _ = False + isArticulations (Articulations _) = True + isArticulations _ = False + + foldOrnaments = foldr mergeN (Ornaments []) + foldTechnical = foldr mergeN (Technical []) + foldArticulations = foldr mergeN (Articulations []) + (Ornaments xs) `mergeN` (Ornaments ys) = Ornaments (xs <> ys) + (Technical xs) `mergeN` (Technical ys) = Technical (xs <> ys) + (Articulations xs) `mergeN` (Articulations ys) = Articulations (xs <> ys) + + +beginTuplet :: Music -> Music +endTuplet :: Music -> Music +beginTuplet = addNotation (Tuplet 1 Start) +endTuplet = addNotation (Tuplet 1 Stop) + +beginBeam :: Music -> Music +continueBeam :: Music -> Music +endBeam :: Music -> Music +beginBeam = Music . fmap (mapNoteProps2 (beginBeamP 1)) . getMusic +continueBeam = Music . fmap (mapNoteProps2 (continueBeamP 1)) . getMusic +endBeam = Music . fmap (mapNoteProps2 (endBeamP 1)) . getMusic + +beginTie :: Music -> Music +endTie :: Music -> Music +beginTie = beginTie' . addNotation (Tied Start) +endTie = endTie' . addNotation (Tied Stop) +beginTie' = Music . fmap beginTie'' . getMusic +endTie' = Music . fmap endTie'' . getMusic +beginTie'' (MusicNote (Note full dur ties props)) = (MusicNote (Note full dur (ties++[Start]) props)) +beginTie'' x = x +endTie'' (MusicNote (Note full dur ties props)) = (MusicNote (Note full dur ([Stop]++ties) props)) +endTie'' x = x + + +setNoteValP v x = x { noteType = Just (v, Nothing) } +setVoiceP n x = x { noteVoice = Just (fromIntegral n) } +setTimeModP m n x = x { noteTimeMod = Just (fromIntegral m, fromIntegral n) } +beginBeamP n x = x { noteBeam = Just (fromIntegral n, BeginBeam) } +continueBeamP n x = x { noteBeam = Just (fromIntegral n, ContinueBeam) } +endBeamP n x = x { noteBeam = Just (fromIntegral n, EndBeam) } +dotP x@(NoteProps { noteDots = n@_ }) = x { noteDots = succ n } +addNotationP n x@(NoteProps { noteNotations = ns@_ }) = x { noteNotations = (mergeNotations $ ns++[n]) } +mapNotationsP f x@(NoteProps { noteNotations = ns@_ }) = x { noteNotations = (f ns) } +mapStemP f x@(NoteProps { noteStem = a@_ }) = x { noteNotations = (f a) } +mapNoteHeadP f x@(NoteProps { noteNoteHead = a@_ }) = x { noteNoteHead = (f a) } + + +-- ---------------------------------------------------------------------------------- + +beginGliss :: Music -> Music +endGliss :: Music -> Music +beginSlide :: Music -> Music +endSlide :: Music -> Music +beginGliss = addNotation (Glissando 1 Start Solid Nothing) +endGliss = addNotation (Glissando 1 Stop Solid Nothing) +beginSlide = addNotation (Slide 1 Start Solid Nothing) +endSlide = addNotation (Slide 1 Stop Solid Nothing) + +arpeggiate :: Music -> Music +nonArpeggiate :: Music -> Music +arpeggiate = addNotation Arpeggiate +nonArpeggiate = addNotation NonArpeggiate + + +-- ---------------------------------------------------------------------------------- + +fermata :: FermataSign -> Music -> Music +breathMark :: Music -> Music +caesura :: Music -> Music +fermata = addNotation . Fermata +breathMark = addNotation (Articulations [BreathMark]) +caesura = addNotation (Articulations [Caesura]) + +-- ---------------------------------------------------------------------------------- + +beginSlur :: Music -> Music +endSlur :: Music -> Music +beginSlur = addNotation (Slur 1 Start) +endSlur = addNotation (Slur 1 Stop) + +staccato :: Music -> Music +tenuto :: Music -> Music +accent = addNotation (Articulations [Accent]) +strongAccent = addNotation (Articulations [StrongAccent]) +staccato = addNotation (Articulations [Staccato]) +tenuto = addNotation (Articulations [Tenuto]) +detachedLegato = addNotation (Articulations [DetachedLegato]) +staccatissimo = addNotation (Articulations [Staccatissimo]) +spiccato = addNotation (Articulations [Spiccato]) +scoop = addNotation (Articulations [Scoop]) +plop = addNotation (Articulations [Plop]) +doit = addNotation (Articulations [Doit]) +falloff = addNotation (Articulations [Falloff]) +stress = addNotation (Articulations [Stress]) +unstress = addNotation (Articulations [Unstress]) + +-- ---------------------------------------------------------------------------------- + +cresc, dim :: Music -> Music +crescFrom, crescTo, dimFrom, dimTo :: Dynamics -> Music -> Music +crescFromTo, dimFromTo :: Dynamics -> Dynamics -> Music -> Music + +cresc = \m -> beginCresc <> m <> endCresc +dim = \m -> beginDim <> m <> endDim + +crescFrom x = \m -> dynamic x <> cresc m +crescTo x = \m -> cresc m <> dynamic x +crescFromTo x y = \m -> dynamic x <> cresc m <> dynamic y + +dimFrom x = \m -> dynamic x <> dim m +dimTo x = \m -> dim m <> dynamic x +dimFromTo x y = \m -> dynamic x <> dim m <> dynamic y + +beginCresc, endCresc, beginDim, endDim :: Music + +beginCresc = Music $ [MusicDirection $ Crescendo Start] +endCresc = Music $ [MusicDirection $ Crescendo Stop] +beginDim = Music $ [MusicDirection $ Diminuendo Start] +endDim = Music $ [MusicDirection $ Diminuendo Stop] + +dynamic :: Dynamics -> Music +dynamic level = Music $ [MusicDirection $ Dynamics level] + + +-- FIXME should scale duration by inverse, see #1 +tuplet :: Int -> Int -> Music -> Music +tuplet m n (Music []) = Music [] +tuplet m n (Music [xs]) = Music [xs] +tuplet m n (Music xs) = setTimeMod m n $ (as <> bs <> cs) + where + as = beginTuplet $ Music [head xs] + bs = Music $ init (tail xs) + cs = endTuplet $ Music [last (tail xs)] + +beam :: Music -> Music +beam (Music []) = Music [] +beam (Music [xs]) = Music [xs] +beam (Music xs) = (as <> bs <> cs) + where + as = beginBeam $ Music [head xs] + bs = continueBeam $ Music (init (tail xs)) + cs = endBeam $ Music [last (tail xs)] + +slur :: Music -> Music +slur (Music []) = Music [] +slur (Music [xs]) = Music [xs] +slur (Music xs) = (as <> bs <> cs) + where + as = beginSlur $ Music [head xs] + bs = Music $ init (tail xs) + cs = endSlur $ Music [last (tail xs)] + +-- TODO combine tuplet, beam, slur etc + + + +----------------------------------------------------------------------------- +-- * Ornaments +----------------------------------------------------------------------------- + +tremolo :: Int -> Music -> Music +tremolo n = addNotation (Ornaments [(Tremolo $ fromIntegral n, [])]) + +trill :: Music -> Music +turn :: Bool -> Bool -> Music -> Music +shake :: Music -> Music +mordent :: Bool -> Music -> Music + +trill = addOrnament TrillMark +turn delay invert = case (delay,invert) of + (False,False) -> addOrnament Turn + (True, False) -> addOrnament DelayedTurn + (False,True) -> addOrnament InvertedTurn + (True, True) -> addOrnament DelayedInvertedTurn + +shake = addOrnament Shake +mordent invert = case invert of + False -> addOrnament Mordent + True -> addOrnament InvertedMordent + +addOrnament a = addNotation (Ornaments [(a, [])]) + +-- ---------------------------------------------------------------------------------- +-- Text +-- ---------------------------------------------------------------------------------- + +text :: String -> Music +rehearsal :: String -> Music + +text = Music . single . MusicDirection . Words +rehearsal = Music . single . MusicDirection . Rehearsal + +segno, coda :: Music +segno = Music . single . MusicDirection $ Segno +coda = Music . single . MusicDirection $ Coda + + +-- ---------------------------------------------------------------------------------- + +instance Default ScoreAttrs where + def = ScoreAttrs [] + +instance Default ScoreHeader where + def = ScoreHeader Nothing Nothing Nothing mempty + +instance Default Note where + def = Note def def [] def + +instance Default Divs where + def = defaultDivisionsVal + +instance Default FullNote where + def = Rest noChord Nothing + +instance Default NoteProps where + def = NoteProps Nothing Nothing (Just (1/4, Nothing)) 0 Nothing Nothing Nothing Nothing Nothing Nothing Nothing [] [] + + +-- class HasDyn a where +-- mapLevel :: (Level -> Level) -> (a -> a) +-- +-- class HasPitch a where +-- mapPitch :: (Pitch -> Pitch) -> (a -> a) +-- +-- class HasPitch a => HasAcc a where +-- flatten :: a -> a +-- sharpen :: a -> a +-- mapAcc :: (Semitones -> Semitones) -> a -> a +-- flatten = mapAcc pred +-- sharpen = mapAcc succ + + + +------------------------------------------------------------------------------------- + + +logBaseR :: forall a . (RealFloat a, Floating a) => Rational -> Rational -> a +logBaseR k n + | isInfinite (fromRational n :: a) = logBaseR k (n/k) + 1 +logBaseR k n + | isDenormalized (fromRational n :: a) = logBaseR k (n*k) - 1 +logBaseR k n = logBase (fromRational k) (fromRational n) + +isDivisibleBy :: (Real a, Real b) => a -> b -> Bool +isDivisibleBy n = (equalTo 0.0) . snd . properFraction . logBaseR (toRational n) . toRational + +single x = [x] +equalTo = (==) diff --git a/src/Music/MusicXml/Time.hs b/src/Music/MusicXml/Time.hs new file mode 100644 --- /dev/null +++ b/src/Music/MusicXml/Time.hs @@ -0,0 +1,84 @@ + +{-# 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 Show Tempo + + diff --git a/src/Music/MusicXml/Write.hs b/src/Music/MusicXml/Write.hs new file mode 100644 --- /dev/null +++ b/src/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 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 new file mode 100644 --- /dev/null +++ b/src/Music/MusicXml/Write/Score.hs @@ -0,0 +1,576 @@ + +------------------------------------------------------------------------------------- +-- | +-- 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) + +-- ---------------------------------------------------------------------------------- +-- 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