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.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff --git a/lilypond.cabal b/lilypond.cabal new file mode 100644 --- /dev/null +++ b/lilypond.cabal @@ -0,0 +1,41 @@ + +name: lilypond +version: 1.0 +cabal-version: >= 1.10 +author: Hans Hoglund +maintainer: Hans Hoglund +license: BSD3 +license-file: COPYING +synopsis: Bindings to Lilypond +category: Music +tested-with: GHC +build-type: Simple + +description: + This package contains a terse Haskell representation of (a subset of) Lilypond + expressions and a pretty-printer for such expressions. They can be used to generate + musical notation. + +source-repository head + type: git + location: git://github.com/hanshoglund/lilypond.git + + +library + build-depends: + base >= 4 && < 5, + semigroups, + prettify, + vector-space, + process, + data-default, + music-pitch-literal, + music-dynamics-literal + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: + Music.Lilypond + Music.Lilypond.Pitch + Music.Lilypond.Dynamics + Music.Lilypond.Value + Music.Lilypond.IO diff --git a/src/Music/Lilypond.hs b/src/Music/Lilypond.hs new file mode 100644 --- /dev/null +++ b/src/Music/Lilypond.hs @@ -0,0 +1,876 @@ + +{-# LANGUAGE + OverloadedStrings, + GeneralizedNewtypeDeriving, + StandaloneDeriving, + TypeFamilies, + ScopedTypeVariables, + ExistentialQuantification #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : GHC +-- +------------------------------------------------------------------------------------- +module Music.Lilypond ( + + -- * Representation + + -- ** Music expressions + Music(..), + Note(..), + Clef(..), + Mode(..), + + -- ** Attributes + Value, + toValue, + + -- ** Articulation and dynamics + PostEvent(..), + + -- ** Text + Articulation(..), + Markup(..), + HasMarkup(..), + + -- ** Miscellaneous types + Direction(..), + OctaveCheck(..), + BreathingSign(..), + + -- ** Time + Duration(..), + -- ** Pitch + Pitch(..), + PitchClass(..), + Accidental(..), + Octaves(..), + + -- * Constructing Lilypond expresions + -- ** Notes and rests + rest, + note, + chord, + + -- ** Composition + scat, + pcat, + + -- ** Post events + addPost, + addText, + addMarkup, + addDynamics, + addArticulation, + addText', + addMarkup', + addDynamics', + addArticulation', + + -- ** Curves and lines + beginTie, + beginBeam, + endBeam, + beginSlur, + endSlur, + beginPhraseSlur, + endPhraseSlur, + beginCresc, + endCresc, + beginDim, + endDim, + + -- ** Marks + addAccent, + addMarcato, + addStaccatissimo, + addEspressivo, + addStaccato, + addTenuto, + addPortato, + addUpbow, + addDownbow, + addFlageolet, + addThumb, + addLeftHeel, + addRightHeel, + addLeftToe, + addRightToe, + addOpen, + addStopped, + addTurn, + addReverseTurn, + addTrill, + addPrall, + addMordent, + addPrallPrall, + addPrallMordent, + addUpPrall, + addDownPrall, + addUpMordent, + addDownMordent, + addPrallDown, + addPrallUp, + addLinePrall, + addSignumCongruentiae, + addShortFermata, + addFermata, + addLongFermata, + addVeryLongFermata, + addSegno, + addCoda, + addVarCoda, + ) +where + +import Data.Ratio +import Data.String +import Data.Default +import Data.Semigroup +import Data.VectorSpace +import Text.Pretty hiding (Mode) +import Music.Pitch.Literal + +-- import System.Process -- TODO debug + +import Music.Lilypond.Pitch +import Music.Lilypond.Dynamics +import Music.Lilypond.Value + + +{- +data Lilypond + = Book Id [BookBlock] + | BookPart Id [BookPartBlock] + | Score Id [ScoreBlock] + +data BookBlock + = Paper OutputDef + | Bookpart Id [BookPartBlock] + | Score Id [ScoreBlock] + | Music CompositeMusic + -- full markup etc + +data BookPartBlock + = BookPartPaper OutputDef + | BookPartScore Id [ScoreBlock] + | BookPartMusic CompositeMusic + -- full markup etc + +data ScoreBlock + = ScoreMusic Music + -- full markup etc +-} + +-- | A Lilypond music expression. +-- +-- Use the 'Pretty' instance to convert into Lilypond syntax. +-- +data Music + = Rest (Maybe Duration) [PostEvent] -- ^ Single rest. + | Note Note (Maybe Duration) [PostEvent] -- ^ Single note. + | Chord [Note] (Maybe Duration) [PostEvent] -- ^ Single chord. + | Sequential [Music] -- ^ Sequential composition. + | Simultaneous Bool [Music] -- ^ Parallel composition (split voices?). + | Repeat Bool Int Music (Maybe (Music, Music)) -- ^ Repetition (unfold?, times, music, alternative). + | Tremolo Int Music -- ^ Tremolo (multiplier). + | Times Rational Music -- ^ Stretch music (multiplier). + | Transpose Pitch Pitch Music -- ^ Transpose music (from to). + | Relative Pitch Music -- ^ Use relative octave (octave). + | Clef Clef -- ^ Clef. + | Key Pitch Mode -- ^ Key signature. + | Time Rational -- ^ Time signature. + | Breathe (Maybe BreathingSign) -- ^ Breath mark (caesura) + | Tempo (Maybe String) (Maybe (Duration,Integer)) -- ^ Tempo mark. + | New String (Maybe String) Music -- ^ New expression. + | Context String (Maybe String) Music -- ^ Context expression. + | Set String Value + deriving (Eq, Show) + +instance Pretty Music where + pretty (Rest d p) = "r" <> pretty d <> prettyList p + + pretty (Note n d p) = pretty n <> pretty d <> prettyList p + + pretty (Chord ns d p) = "<" <> nest 4 (sepByS "" $ map pretty ns) <> char '>' + <> pretty d <> prettyList p + + pretty (Sequential xs) = "{" <=> nest 4 ((hsep . fmap pretty) xs) <=> "}" + + pretty (Simultaneous False xs) = "<<" nest 4 ((vcat . fmap pretty) xs) ">>" + pretty (Simultaneous True xs) = "<<" nest 4 ((sepByS " \\\\" . fmap pretty) xs) ">>" + + pretty (Repeat unfold times x alts) = + "\\repeat" <=> unf unfold <=> int times <=> pretty x <=> alt alts + where + unf p = if p then "unfold" else "volta" + alt Nothing = empty + alt (Just (x,y)) = "\\alternative" <> pretty x <> pretty y + + pretty (Tremolo n x) = + "\\repeat tremolo" <+> pretty n <=> pretty x + + pretty (Times n x) = + "\\times" <+> frac n <=> pretty x + where + frac n = pretty (numerator n) <> "/" <> pretty (denominator n) + + pretty (Transpose from to x) = + "\\transpose" <+> pretty from <=> pretty to <=> pretty x + + pretty (Relative p x) = + "\\relative" <=> pretty p <=> pretty x + + pretty (Clef c) = "\\clef" <+> pretty c + + pretty (Key p m) = "\\clef" <+> pretty p <+> pretty m + + pretty (Time n) = "\\time" <+> pretty n + + pretty (Breathe Nothing) = "\\breathe" + pretty (Breathe a) = notImpl "Non-standard breath marks" + + pretty (Tempo Nothing Nothing) = mempty + pretty (Tempo (Just t) Nothing) = "\\time" <+> pretty t + pretty (Tempo Nothing (Just (d,bpm))) = "\\time" <+> pretty d <+> "=" <+> pretty bpm + pretty (Tempo (Just t) (Just (d,bpm))) = "\\time" <+> pretty t <+> pretty d <+> "=" <+> pretty bpm + + -- TODO metronome + -- TODO tempo + + pretty (New typ name x) = + "\\new" <+> string typ <+> pretty name <+> pretty x + + pretty (Context typ name x) = + "\\context" <+> string typ <+> pretty name <+> pretty x + + pretty (Set name val) = + "\\set" <+> string name <+> "=" <+> (string . show) val + + -- pretty _ = notImpl "Unknown music expression" + + prettyList = hsep . fmap pretty + +instance IsPitch Music where + fromPitch = (\p -> Note p (Just (1/4)) []) . fromPitch + +instance AdditiveGroup Music where + zeroV = Rest (Just $ 1/4) [] + a ^+^ b = Sequential [a,b] + negateV = error "No Music.Lilypond.Music.negateV" + +instance VectorSpace Music where + type Scalar Music = Duration + a *^ (Rest (Just d) p) = Rest (Just $ a*d) p + a *^ (Note n (Just d) p) = Note n (Just $ a*d) p + a *^ (Chord ns (Just d) p) = Chord ns (Just $ a*d) p + a *^ x = x + + +data Note + = NotePitch Pitch (Maybe OctaveCheck) + | DrumNotePitch (Maybe Duration) + deriving (Eq, Show) + +instance Pretty Note where + pretty (NotePitch p Nothing) = pretty p + pretty (NotePitch p _) = notImpl "Non-standard pitch" + pretty (DrumNotePitch _) = notImpl "Non-standard pitch" + prettyList = hsep . fmap pretty + +instance IsPitch Note where + fromPitch = (\p -> (NotePitch p Nothing)) . fromPitch + +data Clef + = Treble + | Alto + | Tenor + | Bass + | French + | Soprano + | MezzoSoprano + | Baritone + | VarBaritone + | SubBass + | Percussion + | Tab + deriving (Eq, Show) + +instance Pretty Clef where + pretty Treble = "treble" + pretty Alto = "alto" + pretty Tenor = "tenor" + pretty Bass = "bass" + pretty French = "french" + pretty Soprano = "soprano" + pretty MezzoSoprano = "mezzosoprano" + pretty Baritone = "baritone" + pretty VarBaritone = "varbaritone" + pretty SubBass = "subbass" + pretty Percussion = "percussion" + pretty Tab = "tab" + +data BreathingSign + = RightVarComma + | StraightCaesura + | CurvedCaesura + deriving (Eq, Show) + +data PostEvent + = Articulation Direction Articulation + | Dynamics Direction Dynamics + | Tie + | BeginBeam + | EndBeam + | BeginSlur + | EndSlur + | BeginPhraseSlur + | EndPhraseSlur + | BeginCresc + | BeginDim + | EndCrescDim + | Text Direction String + | Markup Direction Markup + deriving (Eq, Show) + +instance Pretty PostEvent where + pretty (Articulation d a) = pretty d <> pretty a + pretty (Dynamics d a) = pretty d <> pretty a + pretty Tie = "~" + pretty BeginBeam = "[" + pretty EndBeam = "]" + pretty BeginSlur = "(" + pretty EndSlur = ")" + pretty BeginPhraseSlur = "\\(" + pretty EndPhraseSlur = "\\)" + pretty BeginCresc = "\\<" + pretty BeginDim = "\\>" + pretty EndCrescDim = "\\!" + pretty (Text d s) = pretty d <> (string . show) s -- add quotes + pretty (Markup d m) = pretty d <> ("\\markup" <+> pretty m) + prettyList = hcat . fmap pretty + +data Markup + = MarkupText String + | MarkupList [Markup] + | Bold Markup + | Box Markup + | Caps Markup + | DynamicsFont Markup + | FingeringFont Markup + | Fontsize Double Markup + | Huge Markup + | Italic Markup + | Large Markup + | Larger Markup + | Magnify Markup + | Medium Markup + | Roman Markup + | Sans Markup + | Sub Markup + | Super Markup + | TextFont Markup + | Tiny Markup + | TypewriterFont Markup + | Upright Markup + deriving (Eq, Show) + +class HasMarkup a where + markup :: a -> Markup + +instance HasMarkup Markup where + markup = id +instance HasMarkup a => HasMarkup [a] where + markup = MarkupList . fmap markup +instance IsString Markup where + fromString = MarkupText + +instance Pretty Markup where + pretty (MarkupText s) = (string . show) s + pretty (MarkupList as) = "{" <+> hsep (fmap pretty as) <+> "}" + pretty (Bold a) = "\\bold" <+> pretty a + pretty (Box a) = "\\box" <+> pretty a + pretty (Caps a) = "\\caps" <+> pretty a + pretty (DynamicsFont a) = "\\dynamics" <+> pretty a + pretty (FingeringFont a) = "\\fingering" <+> pretty a + pretty (Fontsize n a) = "\\fontsize" <+> ("#" <> pretty n) <+> pretty a + pretty (Huge a) = "\\huge" <+> pretty a + pretty (Italic a) = "\\italic" <+> pretty a + pretty (Large a) = "\\large" <+> pretty a + pretty (Larger a) = "\\larger" <+> pretty a + pretty (Magnify a) = "\\magnify" <+> pretty a + pretty (Medium a) = "\\medium" <+> pretty a + pretty (Roman a) = "\\roman" <+> pretty a + pretty (Sans a) = "\\sans" <+> pretty a + pretty (Sub a) = "\\sub" <+> pretty a + pretty (Super a) = "\\super" <+> pretty a + pretty (TextFont a) = "\\text" <+> pretty a + pretty (Tiny a) = "\\tiny" <+> pretty a + pretty (TypewriterFont a) = "\\typewriter" <+> pretty a + pretty (Upright a) = "\\upright" <+> pretty a + + +-- | Articulations. These include ornaments. +data Articulation + = Accent + | Marcato + | Staccatissimo + | Espressivo + | Staccato + | Tenuto + | Portato + | Upbow + | Downbow + | Flageolet + | Thumb + | LeftHeel + | RightHeel + | LeftToe + | RightToe + | Open + | Stopped + | Turn + | ReverseTurn + | Trill + | Prall + | Mordent + | PrallPrall + | PrallMordent + | UpPrall + | DownPrall + | UpMordent + | DownMordent + | PrallDown + | PrallUp + | LinePrall + | SignumCongruentiae + | ShortFermata + | Fermata + | LongFermata + | VeryLongFermata + | Segno + | Coda + | VarCoda + deriving (Eq, Show) + +instance Pretty Articulation where + -- pretty Accent = "\\accent" + -- pretty Marcato = "\\marcato" + -- pretty Staccatissimo = "\\staccatissimo" + pretty Accent = ">" + pretty Marcato = "^" + pretty Staccatissimo = "|" + pretty Espressivo = "\\espressivo" + -- pretty Staccato = "\\staccato" + -- pretty Tenuto = "\\tenuto" + -- pretty Portato = "\\portato" + pretty Staccato = "." + pretty Tenuto = "-" + pretty Portato = "_" + pretty Upbow = "\\upbow" + pretty Downbow = "\\downbow" + pretty Flageolet = "\\flageolet" + pretty Thumb = "\\thumb" + pretty LeftHeel = "\\leftheel" + pretty RightHeel = "\\rightheel" + pretty LeftToe = "\\lefttoe" + pretty RightToe = "\\righttoe" + pretty Open = "\\open" + -- pretty Stopped = "\\stopped" + pretty Stopped = "+" + pretty Turn = "\\turn" + pretty ReverseTurn = "\\reverseturn" + pretty Trill = "\\trill" + pretty Prall = "\\prall" + pretty Mordent = "\\mordent" + pretty PrallPrall = "\\prallprall" + pretty PrallMordent = "\\prallmordent" + pretty UpPrall = "\\upprall" + pretty DownPrall = "\\downprall" + pretty UpMordent = "\\upmordent" + pretty DownMordent = "\\downmordent" + pretty PrallDown = "\\pralldown" + pretty PrallUp = "\\prallup" + pretty LinePrall = "\\lineprall" + pretty SignumCongruentiae = "\\signumCongruentiae" + pretty ShortFermata = "\\shortfermata" + pretty Fermata = "\\fermata" + pretty LongFermata = "\\longfermata" + pretty VeryLongFermata = "\\verylongfermata" + pretty Segno = "\\segno" + pretty Coda = "\\coda" + pretty VarCoda = "\\varcoda" + prettyList = hcat . fmap pretty + +data Direction + = Above + | Default + | Below + deriving (Eq, Ord, Show) + +instance Default Direction where + def = Default + +instance Pretty Direction where + pretty Above = "^" + pretty Default = "-" + pretty Below = "_" + + +-- | Notated time in fractions, in @[2^^i | i <- [-10..3]]@. +newtype Duration = Duration { getDuration :: Rational } + +deriving instance Eq Duration +deriving instance Ord Duration +deriving instance Num Duration +deriving instance Enum Duration +deriving instance Fractional Duration +deriving instance Real Duration +deriving instance RealFrac Duration +deriving instance Show Duration + +instance Pretty Duration where + pretty a = string $ pnv (toRational nv) ++ pds ds + where + pnv 4 = "\\longa" + pnv 2 = "\\breve" + pnv n = show (denominator n) + pds n = concat $ replicate n "." + (nv, ds) = separateDots a + +-- | Construct a rest of default duration @1/4@. +-- +-- Use the 'VectorSpace' methods to change duration. +-- +rest :: Music +rest = Rest (Just $ 1/4) [] + +-- | Construct a note of default duration @1/4@. +-- +-- Use the 'VectorSpace' methods to change duration. +-- +note :: Note -> Music +note n = Note n (Just $ 1/4) [] + +-- | Construct a chord of default duration @1/4@. +-- +-- Use the 'VectorSpace' methods to change duration. +-- +chord :: [Note] -> Music +chord ns = Chord ns (Just $ 1/4) [] + + +scat :: Music -> Music -> Music +Sequential as `scat` Sequential bs = Sequential (as <> bs) +Sequential as `scat` b = Sequential (as <> [b]) +a `scat` Sequential bs = Sequential ([a] <> bs) +a `scat` b = Sequential ([a,b]) + +pcat :: Music -> Music -> Music +Simultaneous s as `pcat` Simultaneous t bs = Simultaneous True (as <> bs) +Simultaneous s as `pcat` b = Simultaneous s (as <> [b]) +a `pcat` Simultaneous t bs = Simultaneous t ([a] <> bs) +a `pcat` b = Simultaneous True ([a,b]) + + + +addPost :: PostEvent -> Music -> Music +addPost a (Rest d es) = Rest d (es ++ [a]) +addPost a (Note n d es) = Note n d (es ++ [a]) +addPost a (Chord ns d es) = Chord ns d (es ++ [a]) +addPost a m = m + +addText :: String -> Music -> Music +addText s = addPost (Text def s) + +addText' :: Direction -> String -> Music -> Music +addText' d s = addPost (Text d s) + +addMarkup :: HasMarkup a => a -> Music -> Music +addMarkup s = addPost (Markup def (markup s)) + +addMarkup' :: HasMarkup a => Direction -> a -> Music -> Music +addMarkup' d s = addPost (Markup d (markup s)) + +addArticulation :: Articulation -> Music -> Music +addArticulation a = addPost (Articulation def a) + +addArticulation' :: Direction -> Articulation -> Music -> Music +addArticulation' d a = addPost (Articulation d a) + +addDynamics :: Dynamics -> Music -> Music +addDynamics a = addPost (Dynamics def a) + +addDynamics' :: Direction -> Dynamics -> Music -> Music +addDynamics' d a = addPost (Dynamics d a) + +beginTie :: Music -> Music +beginTie = addPost Tie + +beginBeam :: Music -> Music +beginBeam = addPost BeginBeam + +endBeam :: Music -> Music +endBeam = addPost EndBeam + +beginSlur :: Music -> Music +beginSlur = addPost BeginSlur + +endSlur :: Music -> Music +endSlur = addPost EndSlur + +beginPhraseSlur :: Music -> Music +beginPhraseSlur = addPost BeginPhraseSlur + +endPhraseSlur :: Music -> Music +endPhraseSlur = addPost EndPhraseSlur + +beginCresc :: Music -> Music +beginCresc = addPost BeginCresc + +endCresc :: Music -> Music +endCresc = addPost EndCrescDim + +beginDim :: Music -> Music +beginDim = addPost BeginDim + +endDim :: Music -> Music +endDim = addPost EndCrescDim + + +addAccent :: Music -> Music +addAccent = addArticulation Accent + +addMarcato :: Music -> Music +addMarcato = addArticulation Marcato + +addStaccatissimo :: Music -> Music +addStaccatissimo = addArticulation Staccatissimo + +addEspressivo :: Music -> Music +addEspressivo = addArticulation Espressivo + +addStaccato :: Music -> Music +addStaccato = addArticulation Staccato + +addTenuto :: Music -> Music +addTenuto = addArticulation Tenuto + +addPortato :: Music -> Music +addPortato = addArticulation Portato + +addUpbow :: Music -> Music +addUpbow = addArticulation Upbow + +addDownbow :: Music -> Music +addDownbow = addArticulation Downbow + +addFlageolet :: Music -> Music +addFlageolet = addArticulation Flageolet + +addThumb :: Music -> Music +addThumb = addArticulation Thumb + +addLeftHeel :: Music -> Music +addLeftHeel = addArticulation LeftHeel + +addRightHeel :: Music -> Music +addRightHeel = addArticulation RightHeel + +addLeftToe :: Music -> Music +addLeftToe = addArticulation LeftToe + +addRightToe :: Music -> Music +addRightToe = addArticulation RightToe + +addOpen :: Music -> Music +addOpen = addArticulation Open + +addStopped :: Music -> Music +addStopped = addArticulation Stopped + +addTurn :: Music -> Music +addTurn = addArticulation Turn + +addReverseTurn :: Music -> Music +addReverseTurn = addArticulation ReverseTurn + +addTrill :: Music -> Music +addTrill = addArticulation Trill + +addPrall :: Music -> Music +addPrall = addArticulation Prall + +addMordent :: Music -> Music +addMordent = addArticulation Mordent + +addPrallPrall :: Music -> Music +addPrallPrall = addArticulation PrallPrall + +addPrallMordent :: Music -> Music +addPrallMordent = addArticulation PrallMordent + +addUpPrall :: Music -> Music +addUpPrall = addArticulation UpPrall + +addDownPrall :: Music -> Music +addDownPrall = addArticulation DownPrall + +addUpMordent :: Music -> Music +addUpMordent = addArticulation UpMordent + +addDownMordent :: Music -> Music +addDownMordent = addArticulation DownMordent + +addPrallDown :: Music -> Music +addPrallDown = addArticulation PrallDown + +addPrallUp :: Music -> Music +addPrallUp = addArticulation PrallUp + +addLinePrall :: Music -> Music +addLinePrall = addArticulation LinePrall + +addSignumCongruentiae :: Music -> Music +addSignumCongruentiae = addArticulation SignumCongruentiae + +addShortFermata :: Music -> Music +addShortFermata = addArticulation ShortFermata + +addFermata :: Music -> Music +addFermata = addArticulation Fermata + +addLongFermata :: Music -> Music +addLongFermata = addArticulation LongFermata + +addVeryLongFermata :: Music -> Music +addVeryLongFermata = addArticulation VeryLongFermata + +addSegno :: Music -> Music +addSegno = addArticulation Segno + +addCoda :: Music -> Music +addCoda = addArticulation Coda + +addVarCoda :: Music -> Music +addVarCoda = addArticulation VarCoda + + + + + + + + + + +notImpl a = error $ "Not implemented: " ++ a +asPitch = id +asPitch :: Pitch -> Pitch + + + + + + + + + + + +separateDots :: Duration -> (Duration, Int) +separateDots = separateDots' [2/3, 6/7, 14/15, 30/31, 62/63] + +separateDots' :: [Duration] -> Duration -> (Duration, Int) +separateDots' [] nv = error "separateDots: Strange" +separateDots' (div:divs) nv + | isDivisibleBy 2 nv = (nv, 0) + | otherwise = (nv', dots' + 1) + where + (nv', dots') = separateDots' divs (nv*div) + +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 + +equalTo = (==) + +infixl <=> +a <=> b = sep [a,b] + + + +{- +Debug stuff + +runLy = runCommand "lilypond -f pdf test.ly" + +engrave :: Music -> IO () +engrave e = do + writeFile "test.ly" $ show $ pretty e + runLy + return () + + +main = engrave test +-} + +test = Simultaneous False [ + New "StaffGroup" Nothing (Simultaneous False [ + New "Staff" Nothing (Relative c' $ Sequential [ + Set "Staff.instrumentName" (toValue "Violin I"), + (addDynamics FF c), d, e + ]), + New "Staff" Nothing (Sequential [ + Set "Staff.instrumentName" (toValue "Violin II"), + Clef Bass, c, g_, c]) + ]) + ] + +-- test = +-- Simultaneous False +-- [ Relative g' (Sequential [ +-- addMarkup ([Bold "Hello", Italic (markup [MarkupText "cruel", Bold $ MarkupText "world"])]) rest, +-- addArticulation Mordent $ chord [c,e,g]^*2, +-- d^*1, +-- e^*2, +-- c^*(3/2), +-- fs^*(1/2) +-- ]) +-- , Sequential [Tremolo 4 (Sequential [c^/4,d^/4]), Tremolo 4 (Sequential [c^/4,d^/4])] +-- , Sequential [rest,c^*2,d^*1,e^*2,c^*(3/2),fs^*(1/2)] +-- , Sequential [rest,c^*2,d^*1,e^*2,c^*(3/2),fs^*(1/2)] +-- , Relative g (Sequential [rest,c^*2,d^*1,e^*2,c^*(3/2),fs^*(1/2)]) +-- , Sequential +-- [ Times (4/5) (Sequential +-- [ +-- rest, +-- addArticulation Accent $ addPost BeginSlur $ addPost BeginCresc $ c^*2, +-- d^*1, +-- addPost Tie $ e^*1 +-- ]) +-- , Times (4/5) (Sequential +-- [ +-- addPost BeginDim $ addPost EndCrescDim $ e^*1, +-- c^*(3/2), +-- addPost EndSlur $ fs^*(1/2), +-- addPost EndCrescDim $ c^*2 +-- ]) +-- ] +-- ] + + + diff --git a/src/Music/Lilypond/Dynamics.hs b/src/Music/Lilypond/Dynamics.hs new file mode 100644 --- /dev/null +++ b/src/Music/Lilypond/Dynamics.hs @@ -0,0 +1,62 @@ + +{-# LANGUAGE OverloadedStrings #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : GHC +-- +------------------------------------------------------------------------------------- + +module Music.Lilypond.Dynamics ( + Dynamics(..), + ) where + +import Text.Pretty hiding (Mode) +import Music.Dynamics.Literal +import qualified Data.Char as Char + +data Dynamics + = PPPPP + | PPPP + | PPP + | PP + | P + | MP + | MF + | F + | FF + | FFF + | FFFF + | SF + | SFF + | SP + | SPP + | SFZ + | RFZ + deriving (Eq, Ord, Show, Enum, Bounded) + +instance Pretty Dynamics where + pretty = string . ("\\" ++) . fmap Char.toLower . show + +instance IsDynamics Dynamics where + fromDynamics (DynamicsL (Just x, Nothing)) = case x of + (-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 + fromDynamics _ = error "fromDynamics: Unsupported literal for MusicXml.Dynamics" + + diff --git a/src/Music/Lilypond/IO.hs b/src/Music/Lilypond/IO.hs new file mode 100644 --- /dev/null +++ b/src/Music/Lilypond/IO.hs @@ -0,0 +1,25 @@ + +{-# LANGUAGE OverloadedStrings, GeneralizedNewtypeDeriving #-} + +module Music.Lilypond.IO -- ( + -- ) +where + +import Music.Lilypond + +writeMusic :: FilePath -> Music -> IO () +writeMusic = error "writeMusic: Not implemented" + +data Format = PDF | PNG | PS + +data EngraveOptions + = EngraveOptions { + format :: Format, + include :: FilePath, + initFile :: FilePath, + logFile :: FilePath, + logLevel :: Int + } + +writeAndEngraveMusic :: FilePath -> EngraveOptions -> Music -> IO () +writeAndEngraveMusic = error "writeAndEngraveMusic: Not implemented" diff --git a/src/Music/Lilypond/Pitch.hs b/src/Music/Lilypond/Pitch.hs new file mode 100644 --- /dev/null +++ b/src/Music/Lilypond/Pitch.hs @@ -0,0 +1,67 @@ + +{-# LANGUAGE OverloadedStrings #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : GHC +-- +------------------------------------------------------------------------------------- + +module Music.Lilypond.Pitch ( + Pitch(..), + PitchClass(..), + Accidental(..), + Octaves(..), + Mode(..), + OctaveCheck(..), + ) where + +import Text.Pretty hiding (Mode) +import Music.Pitch.Literal + +data PitchClass = C | D | E | F | G | A | B + deriving (Eq, Ord, Show, Enum) + +newtype Pitch = Pitch { getPitch :: (PitchClass, Accidental, Octaves) } + deriving (Eq, Ord, Show) + +instance Pretty Pitch where + pretty (Pitch (c,a,o)) = string $ pc c ++ acc a ++ oct (o-4) + where + pc C = "c" ; pc D = "d" ; pc E = "e" ; pc F = "f" + pc G = "g" ; pc A = "a" ; pc B = "b" + acc n | n < 0 = concat $ replicate (negate n) "es" + | n == 0 = "" + | n > 0 = concat $ replicate (n) "is" + oct n | n < 0 = concat $ replicate (negate n) "," + | n == 0 = "" + | n > 0 = concat $ replicate n "'" + +instance IsPitch Pitch where + fromPitch (PitchL (c, Nothing, o)) = Pitch (toEnum c, 0, o) + fromPitch (PitchL (c, Just a, o)) = Pitch (toEnum c, round a, o) + + +-- | For double flat -2, flat -1, natural 0, sharp 1 and double sharp 2. +type Accidental = Int + +-- | Number of octaves raised (positive) or flattened (negative). +type Octaves = Int + +-- | Mode (for key signatures). +data Mode = Major | Minor + deriving (Eq, Show) + +instance Pretty Mode where + pretty Major = "\\major" + pretty Minor = "\\minor" + +data OctaveCheck = OctaveCheck + deriving (Eq, Show) + diff --git a/src/Music/Lilypond/Value.hs b/src/Music/Lilypond/Value.hs new file mode 100644 --- /dev/null +++ b/src/Music/Lilypond/Value.hs @@ -0,0 +1,76 @@ + +{-# LANGUAGE + OverloadedStrings, + ExistentialQuantification + #-} + +------------------------------------------------------------------------------------- +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : GHC +-- +------------------------------------------------------------------------------------- + +module Music.Lilypond.Value ( + Value, + toValue, + ) where + +import Data.String +import Text.Pretty hiding (Mode) +import Music.Pitch.Literal + +-- |  +-- Value of a @\\set@ command. +-- These are simply wrappers for showable things. +-- +-- For example use (with @OverloadedStrings@) +-- +-- > Set "Staff.instrumentName" "Violin I" +-- > Set "Staff.instrumentName" 2 +-- +-- to generate +-- +-- > \set Staff.instrumentName = "Violin I" +-- > \set Staff.instrumentName = 2 +-- +data Value = forall a . Show a => Value a + +instance IsString Value where + fromString = toValue + +instance Num Value where + (+) = noOverloading "(+)" + (*) = noOverloading "(*)" + (-) = noOverloading "(-)" + negate = noOverloading "negate" + abs = noOverloading "abs" + signum = noOverloading "signum" + fromInteger = toValue + +instance Fractional Value where + (/) = noOverloading "(/)" + recip = noOverloading "recip" + fromRational = (toValue . toDouble) + +instance Show Value where + show (Value a) = show a + +instance Eq Value where + a == b = show a == show b + +toValue :: Show a => a -> Value +toValue = Value + + + +noOverloading :: String -> a +noOverloading n = error $ "No overloading of " ++ n ++ " for Value" + +toDouble :: Rational -> Double +toDouble = fromRational