diff --git a/COPYING b/COPYING --- a/COPYING +++ b/COPYING @@ -9,14 +9,14 @@ * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of the nor the + * Neither the name of the Music Suite nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE -DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND diff --git a/lilypond.cabal b/lilypond.cabal --- a/lilypond.cabal +++ b/lilypond.cabal @@ -1,6 +1,6 @@ name: lilypond -version: 1.0 +version: 1.6 cabal-version: >= 1.10 author: Hans Hoglund maintainer: Hans Hoglund @@ -18,19 +18,19 @@ source-repository head type: git - location: git://github.com/hanshoglund/lilypond.git + location: git://github.com/music-suite/lilypond.git library build-depends: - base >= 4 && < 5, + base >= 4 && < 5, semigroups, prettify, vector-space, process, data-default, - music-pitch-literal, - music-dynamics-literal + music-pitch-literal == 1.6, + music-dynamics-literal == 1.6 hs-source-dirs: src default-language: Haskell2010 exposed-modules: diff --git a/src/Music/Lilypond.hs b/src/Music/Lilypond.hs --- a/src/Music/Lilypond.hs +++ b/src/Music/Lilypond.hs @@ -58,10 +58,12 @@ rest, note, chord, + chordHarm, + chordWithPost, -- ** Composition - scat, - pcat, + sequential, + simultaneous, -- ** Post events addPost, @@ -76,6 +78,7 @@ -- ** Curves and lines beginTie, + beginGlissando, beginBeam, endBeam, beginSlur, @@ -127,9 +130,14 @@ addSegno, addCoda, addVarCoda, + + -- * Utility + foldMusic, + removeSingleChords, ) where +import Control.Arrow ((<<<), (***), first, second) import Data.Ratio import Data.String import Data.Default @@ -169,14 +177,14 @@ -- full markup etc -} --- | A Lilypond music expression. +-- | 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. + | Chord [(Note, [ChordPostEvent])] (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). @@ -186,11 +194,11 @@ | Relative Pitch Music -- ^ Use relative octave (octave). | Clef Clef -- ^ Clef. | Key Pitch Mode -- ^ Key signature. - | Time Rational -- ^ Time signature. + | Time Integer Integer -- ^ 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. + | New String (Maybe String) Music -- ^ New expression. + | Context String (Maybe String) Music -- ^ Context expression. | Set String Value deriving (Eq, Show) @@ -199,7 +207,7 @@ pretty (Note n d p) = pretty n <> pretty d <> prettyList p - pretty (Chord ns d p) = "<" <> nest 4 (sepByS "" $ map pretty ns) <> char '>' + pretty (Chord ns d p) = "<" <> nest 4 (sepByS "" $ fmap (uncurry (<>) <<< pretty *** pretty) ns) <> char '>' <> pretty d <> prettyList p pretty (Sequential xs) = "{" <=> nest 4 ((hsep . fmap pretty) xs) <=> "}" @@ -230,9 +238,9 @@ pretty (Clef c) = "\\clef" <+> pretty c - pretty (Key p m) = "\\clef" <+> pretty p <+> pretty m + pretty (Key p m) = "\\key" <+> pretty p <+> pretty m - pretty (Time n) = "\\time" <+> pretty n + pretty (Time m n) = "\\time" <+> (pretty m <> "/" <> pretty n) pretty (Breathe Nothing) = "\\breathe" pretty (Breathe a) = notImpl "Non-standard breath marks" @@ -323,27 +331,36 @@ | CurvedCaesura deriving (Eq, Show) +data ChordPostEvent + = Harmonic + deriving (Eq, Show) + +instance Pretty ChordPostEvent where + pretty Harmonic = "\\harmonic" + data PostEvent = Articulation Direction Articulation | Dynamics Direction Dynamics - | Tie + | Tie + | Glissando | BeginBeam | EndBeam | BeginSlur | EndSlur | BeginPhraseSlur | EndPhraseSlur - | BeginCresc - | BeginDim - | EndCrescDim - | Text Direction String - | Markup Direction Markup + | 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 Glissando = "\\glissando" pretty BeginBeam = "[" pretty EndBeam = "]" pretty BeginSlur = "(" @@ -417,7 +434,7 @@ pretty (Upright a) = "\\upright" <+> pretty a --- | Articulations. These include ornaments. +-- | Articulations. These include ornaments. data Articulation = Accent | Marcato @@ -512,7 +529,7 @@ data Direction = Above | Default - | Below + | Below deriving (Eq, Ord, Show) instance Default Direction where @@ -545,42 +562,48 @@ pds n = concat $ replicate n "." (nv, ds) = separateDots a --- | Construct a rest of default duration @1/4@. +-- | 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@. +-- | 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@. +-- | 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) [] +chord ns = Chord (fmap (\x -> (x,[])) ns) (Just $ 1/4) [] +chordHarm :: [(Note, Bool)] -> Music +chordHarm = chordWithPost . fmap (second $ \x -> if x then [Harmonic] else []) -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]) +chordWithPost :: [(Note, [ChordPostEvent])] -> Music +chordWithPost ns = Chord ns (Just $ 1/4) [] -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]) +sequential :: Music -> Music -> Music +Sequential as `sequential` Sequential bs = Sequential (as <> bs) +Sequential as `sequential` b = Sequential (as <> [b]) +a `sequential` Sequential bs = Sequential ([a] <> bs) +a `sequential` b = Sequential ([a,b]) +simultaneous :: Music -> Music -> Music +Simultaneous s as `simultaneous` Simultaneous t bs = Simultaneous True (as <> bs) +Simultaneous s as `simultaneous` b = Simultaneous s (as <> [b]) +a `simultaneous` Simultaneous t bs = Simultaneous t ([a] <> bs) +a `simultaneous` 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]) @@ -614,6 +637,9 @@ beginTie :: Music -> Music beginTie = addPost Tie +beginGlissando :: Music -> Music +beginGlissando = addPost Glissando + beginBeam :: Music -> Music beginBeam = addPost BeginBeam @@ -764,13 +790,34 @@ +foldMusic :: (Music -> Music) -> Music -> Music +foldMusic f = go + where + go (Sequential ms) = Sequential (fmap go ms) + go (Simultaneous b ms) = Simultaneous b (fmap go ms) + go (Repeat b i m qmm) = Repeat b i m (fmap (go *** go) qmm) + go (Tremolo n m) = Tremolo n (go m) + go (Times r m) = Times r (go m) + go (Transpose p p2 m) = Transpose p p2 (go m) + go (Relative p m) = Relative p (go m) + go (New s v m) = New s v (go m) + go (Context s v m) = Context s v (go m) + go x = f x +removeSingleChords :: Music -> Music +removeSingleChords = foldMusic go + where + go (Chord [(n,_)] d p) = Note n d p + go x = x + + + notImpl a = error $ "Not implemented: " ++ a asPitch = id asPitch :: Pitch -> Pitch @@ -791,7 +838,7 @@ separateDots' :: [Duration] -> Duration -> (Duration, Int) separateDots' [] nv = error "separateDots: Strange" separateDots' (div:divs) nv - | isDivisibleBy 2 nv = (nv, 0) + | isDivisibleBy 2 nv = (nv, 0) | otherwise = (nv', dots' + 1) where (nv', dots') = separateDots' divs (nv*div) @@ -820,7 +867,7 @@ engrave :: Music -> IO () engrave e = do - writeFile "test.ly" $ show $ pretty e + writeFile "test.ly" $ show $ pretty e runLy return () @@ -830,7 +877,7 @@ test = Simultaneous False [ New "StaffGroup" Nothing (Simultaneous False [ - New "Staff" Nothing (Relative c' $ Sequential [ + New "Staff" Nothing (Relative c' $ Sequential [ Set "Staff.instrumentName" (toValue "Violin I"), (addDynamics FF c), d, e ]), @@ -844,7 +891,7 @@ -- Simultaneous False -- [ Relative g' (Sequential [ -- addMarkup ([Bold "Hello", Italic (markup [MarkupText "cruel", Bold $ MarkupText "world"])]) rest, --- addArticulation Mordent $ chord [c,e,g]^*2, +-- addArticulation Mordent $ chord [c,e,g]^*2, -- d^*1, -- e^*2, -- c^*(3/2),