music-preludes 1.7 → 1.7.1
raw patch · 31 files changed
+1878/−106 lines, 31 filesdep +aesondep ~lensdep ~lilyponddep ~music-dynamics
Dependencies added: aeson
Dependency ranges changed: lens, lilypond, music-dynamics, music-dynamics-literal, music-parts, music-pitch, music-pitch-literal, music-score, musicxml2, process, vector-space, vector-space-points
Files
- README.md +15/−0
- examples/analysis.hs +25/−0
- examples/annotatations.hs +36/−0
- examples/bartok.hs +38/−0
- examples/canon.hs +21/−0
- examples/canon.music +15/−0
- examples/chords.hs +59/−0
- examples/duo.hs +42/−0
- examples/dynamics.hs +20/−0
- examples/imitations.hs +228/−0
- examples/mozart.hs +200/−0
- examples/part.hs +131/−0
- examples/phrases.hs +29/−0
- examples/plot.hs +115/−0
- examples/scheme.hs +225/−0
- examples/schubert.hs +44/−0
- examples/streams.hs +134/−0
- examples/test1.scm +18/−0
- examples/time_signatures.hs +16/−0
- examples/trio.hs +135/−0
- examples/try.hs +90/−0
- examples/tuplet.hs +39/−0
- music-preludes.cabal +22/−16
- src/Music/Prelude/CmdLine.hs +144/−43
- src/Music/Prelude/Instances.hs +1/−1
- src/Music/Prelude/Standard.hs +15/−15
- tests/tests.hs +15/−3
- tools/music2ly.hs +0/−0
- tools/music2pdf.hs +2/−10
- tools/music2png.hs +2/−9
- tools/music2svg.hs +2/−9
+ README.md view
@@ -0,0 +1,15 @@++# music-preludes++Some useful preludes for the Music Suite.++This library is part of the Music Suite, see <http://music-suite.github.io>.++## Requirements++* [Haskell Platform](http://www.haskell.org/platform)++## Installation++ cabal configure+ cabal install
+ examples/analysis.hs view
@@ -0,0 +1,25 @@++{-# LANGUAGE TypeFamilies #-}++import Music.Prelude.Standard+import qualified Music.Score as Score+import Data.Colour.Names (red)++markIf :: (HasColor a, HasPitches' a, Score.Pitch a ~ Behavior Pitch) => (Interval -> Bool) -> Score a -> Score a+markIf p = mapIf (\x -> p $ withOrigin c $ unb $ x ^?! pitches) mark+ where+ mark = color red+ mapIf p f = uncurry mplus . over _1 f . mpartition p+ unb = (! 0)+ withOrigin x = (.-. x)++markPerfect = text "Perfect consonances" . markIf isPerfectConsonance+markImperfect = text "Imperfect consonances" . markIf isImperfectConsonance+markDiss = text "Dissonances" . markIf isDissonance+++main = openLilypond $ asScore $ rcat [+ markPerfect $ scat [c..c'],+ markImperfect $ scat [c..c'],+ markDiss $ scat [c..c'] + ]
+ examples/annotatations.hs view
@@ -0,0 +1,36 @@++{-+ Annotate a melody with intervals.++ Written by Carlo Nucera+-}+module Annotations where++import Music.Prelude.Basic hiding (Interval)+import Music.Pitch (Interval)++main :: IO ()+main = openLilypond . showAnnotations' ""+ . intervalAnnotations subjectDiff+ . scat $ map (fromPitch'.pure) subject++subject :: [BasicPitch]+subject = [c, d, f, e, f, g, a, g, e, d, c]++subjectDiff :: [Interval]+subjectDiff = zipWith (.-.) (tail subject) subject++-- reify :: BasicPitch -> Score BasicNote+-- reify = (`up` c) . pure . (.-. c)++intervalAnnotations :: [Interval] -> (Score BasicNote -> Score BasicNote)+intervalAnnotations = foldr1 (.) . zipWith notate (map spanify [0..])+ where+ spanify :: Duration -> Span+ spanify t = (0 .+^ t) >-> 1++ notate :: Span -> Interval -> (Score BasicNote -> Score BasicNote)+ notate s n = annotateSpan s (" " ++ showIntervalName n)+ + showIntervalName = filter (/= '_') . show+
+ examples/bartok.hs view
@@ -0,0 +1,38 @@++{-# LANGUAGE OverloadedStrings #-}++import Music.Prelude.Basic++{- + Bela Bartok: Wandering (excerpt)+ From Mikrokosmos, vol. III++ Inspired by the Abjad transcription+-}++main = openLilypond music++++music :: Score BasicNote+music = let+ meta = id+ . title "Mikrokosmos (excerpt)"+ . composer "Bela Bartok"+ . timeSignature (2/4)+ . timeSignatureDuring ((2/4) >-> (5/4)) (3/4) + + left = (level pp {-. legato-}) + (scat [a,g,f,e] |> d^*2)+ |> {-(level ((mp |> mp `cresc` mf |> mf)^*8) . legato)-}id + (scat [g,f,e,d] |> c |> (d |> e)^/2 |> f |> e |> d^*8)+ -- + right = up _P4 . delay 2 $ + (level pp {-. legato-}) + (scat [a,g,f,e] |> d^*2)+ |> (level mp {-. legato-}) + (scat [g,f,e,d] |> c |> (d |> e)^/2 |> f |> e |> d^*8)++ in meta $ compress 8 $ left </> down _P8 right++
+ examples/canon.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}++{-+ This simple example shows how to construct a 4-part canon.+-}+module Main where++import Music.Prelude.Basic++frere = mempty+ |> times 2 (scat [c,d,e,c]^/4) + |> times 2 (scat [e,f,g^*2]^/4) + |> times 2 (scat [g,a,g,f,scat [e,c]^*2]^/8)+ |> times 2 (scat [c,g_,c^*2]^/4)++frere2 = delay 2 frere </> frere+frere4 = delay 4 frere2 </> frere2++info = title "Frere Jaques" . composer "Trad." . tempo (metronome (1/4) 120)+main = open $ info $ asScore $ frere4+
+ examples/canon.music view
@@ -0,0 +1,15 @@++let+ frere = mempty+ |> times 2 (scat [c,d,e,c]^/4) + |> times 2 (scat [e,f,g^*2]^/4) + |> times 2 (scat [g,a,g,f,scat [e,c]^*2]^/8)+ |> times 2 (scat [c,g_,c^*2]^/4)++ frere2 = delay 2 frere </> frere+ frere4 = delay 4 frere2 </> frere2++ info = {-title "Frere Jaques" . -}composer "Trad." . tempo (metronome (1/4) 120)++in info $ asScore $ frere4+
+ examples/chords.hs view
@@ -0,0 +1,59 @@++{-# LANGUAGE NoMonomorphismRestriction #-}++import Music.Prelude++import Control.Concurrent.Async+import Control.Applicative+import System.Process (system)++kStrum = 0.03++main = do+ -- openLilypond (music^/4)+ -- openMidi music+ openAudacity music++guitar = (tutti $ StdInstrument 26)+alto = (tutti $ StdInstrument 65)+rh = (tutti $ StdInstrument 113)+++-- Strum a chord+strum :: [Score a] -> Score a+strum = pcat . zipWith (\t x -> delay t . stretchTo (x^.duration ^-^ t) $ x) [0,kStrum..]++counterRh = set parts' rh $ (mcatMaybes $ times 4 $ octavesUp 1 $ scat [rest^*2,g,g,g^*2,g^*2, rest^*2, scat [g,g,g]^*2])^/8++strings = set parts' (tutti violin) $ octavesAbove 1 $ + (c_<>e_<>g_)^*4 + |> (c_<>fs_<>a_)^*4+ |> (g__<>c_<>e_)^*4 + |> (c_<>f_<>g_)^*4++melody = octavesDown 1 $ set parts' (tutti horn) $ + (scat [c',g'^*2,e',d',c'^*2,b,c'^*2,d'^*2,e',d',c'^*2]^/4)+ |>+ (scat [c',a'^*2,e',d',c'^*2,b,c'^*2,d'^*2,eb',d',c']^/4)+ ++music = asScore $ + (<> melody) $+ (<> level _p strings) $+ (<> level ff counterRh) $+ + set parts' (solo clarinet) $ level mf $ + (pcat $ take 4 $ zipWith delay [0,1..10] $ repeat $ strum [c_,e_,g_,c,e,g])+ |>+ (pcat $ take 4 $ zipWith delay [0,1..10] $ repeat $ strum [c_,fs_,a_,c,fs,a])+ |>+ (pcat $ take 4 $ zipWith delay [0,1..10] $ repeat $ strum [c_,e_,g_,c,e,g])+ |>+ (pcat $ take 4 $ zipWith delay [0,1..10] $ repeat $ strum [g_,a_,c,f,a,c'])+ ++openAudacity :: Score Note -> IO () +openAudacity x = do+ void $ writeMidi "test.mid" $ x+ void $ system "timidity -Ow test.mid"+ void $ system "open -a Audacity test.wav"
+ examples/duo.hs view
@@ -0,0 +1,42 @@++{-# LANGUAGE + OverloadedStrings, + ConstraintKinds,+ NoMonomorphismRestriction #-}++module Main where++import Control.Lens hiding ((|>))+import System.Process (runCommand)+import Music.Prelude.Basic++main = do+ -- writeMidi "test.mid" music+ -- writeXml "test.xml" $ music^/4+ -- openXml music+ openLilypond $ asScore music+ -- playMidiIO "Graphic MIDI" $ music^/10++toLydian :: Score BasicNote -> Score BasicNote+toLydian = pitches' %~ (\p -> if ((p::Behavior BasicPitch) ! 0) == ((c::Behavior BasicPitch) ! 0) then cs else p)+-- TODO cleanup++subj1 = (^/2) $+ (legato.accent) (b_ |> c) |> (legato.accent) (c |> b_^*2)+ |> legato (scat [b_, c, d])+ |> b_ |> c |> b_^*2+ |> legato (scat [e, d, b_, c]) |> b_^*2+ |> scat [d, e, b_] |> c^*2 |> b_++pres1 = subj1^*(2/2)+pres2 = subj1^*(2/2) </> delay 2 (subj1^*(3/2))++part1 = pres1 |> pres2+part2 = pres1 |> pres2 ++music = asScore $ clef CClef $ level pp $ compress 2 $ part1 |> toLydian part2++-- (|>) :: Score a -> Score a -> Score a+-- a |> b = mcatMaybes $ fmap Just a ||> fmap Just b++
+ examples/dynamics.hs view
@@ -0,0 +1,20 @@++{-# LANGUAGE OverloadedStrings #-}++import Music.Prelude++-- A simple subject+subj = times 20 $ scat [c,d,e,f]^/8 |> scat [g,fs]^/2++unb :: Behavior a -> a+unb = (! 0)++-- The +music = id+ $ title "Dynamics"+ $ composer "Anonymous"+ $ fmap (over dynamics (! 0)) + $ + rcat $ map (\phase -> level (stretch phase sine*fff) $ subj) [5.0,5.2..6.0]++main = open $ asScore $ music
+ examples/imitations.hs view
@@ -0,0 +1,228 @@++{-# LANGUAGE NoMonomorphismRestriction #-}++module Main where+import Music.Score.Util (rotated)+import Music.Prelude.Standard++-- Get (bar,beat)+-- 400 bars in 60 BPM+-- 20 seconds in bar 401+-- 45 bars (to 446)+-- 30 seconds in bar 447 ++-- notePos :: Int -> (Int,Int)+-- notePos t | t < 1600 = ( t `div` 4 + 1 , t `mod` 4 + 1)+-- | 1600 <= t && t < 1620 = ( 401 , t - (400*4) + 1)+-- | 400*4+20 <= t && t < 445*4+20 = ( (t-20) `div` 4 + 2, (t-20) `mod` 4 + 1 )+-- | otherwise = 447++main = {-openMusicXml-}open noteScore++noteScore :: Score Note+noteScore = compress 4 $ {-addInstrChange $-}+ mempty++ -- * Part 1 (first canon and col legno)+ ||> (colLegno1 </> delay (4*3) colLegno1) + -- ||> (canon_I <> (delay (4*5) $ moveToPart vl2 $ canon_I)) -- A+ ||> (colLegno2 </> delay (4*3) colLegno2) -- B+++++ -- + -- -- * Part 2 (canon_II and surrounding)+ -- -- C+ -- ||> (level _p $ bar^*30+ -- <> delay 0 (moveToPart vc2 g_^*(4*13))+ -- <> delay (4*15) (moveToPart vc1 a_^*(4*13))+ -- )+ -- -- -- D, E+ -- ||> canon_II+ -- ||> (bar^*15 <> moveToPart vl2 (rev canon_II))+ -- -- -- F+ -- ||> (level _p $ bar^*30+ -- <> delay 0 (moveToPart vc2 bb_^*(4*15))+ -- <> delay (4*15) (moveToPart vc1 c ^*(4*15))+ -- )+ -- ||> (canon_III <> (delay (4*30) $ moveToPart vl2 $ canon_III)) -- A+ -- + -- + -- -- * Part 3 (development to canon_IV)+ -- -- I+ -- ||> (mempty+ -- <> delay 0 (moveToPart vl1 f' ^*(4*15)) + -- <> delay (4*15) (moveToPart vl2 f' ^*(4*15)) + -- )+ -- -- K+ -- ||> bar^*1+ -- ||> canon_IV+ -- + -- ||> rest^*20+ -- + -- -- * Part 4 (jete)+ -- -- FIXME sync back to score+ -- ||> mconcat [+ -- delay 0 $ level ppp $ up (12*3) $ moveToPart vl2 $ d_^*(4*30),+ -- delay (4*10) (level _p $ jete1 </> delay (12*8) jete1)+ -- ]+ -- ||> bar^*2+ -- ||> c'^*4 -- mark ending!+++(||>) = (|>)+++--------------------------------------------------------------------------------++colLegno1 :: Score Note+colLegno1 = {-staccato $ -} level (ppp {-`cresc` mp |> mp^*0.2-}) $ text "col legno battuto" $+ (down 12 $ delay 0 $ repTimes 7 $ mcatMaybes $ ([4,4,4,5,4] `groupWith` g) |> rest^*6)+ </> (down 12 $ delay 1 $ repTimes 7 $ mcatMaybes $ ([4,4,5,4,5] `groupWith` g) |> rest^*6)+ </> (down 24 $ delay 3 $ repTimes 7 $ mcatMaybes $ ([4,5,4,5,4] `groupWith` g) |> rest^*6)+ </> (down 24 $ delay 6 $ repTimes 7 $ mcatMaybes $ ([3,3,5,3,5] `groupWith` g) |> rest^*6)++-- dur 45++colLegno2 :: Score Note+colLegno2 = {-staccato $ -} level (mp) $ text "col legno battuto" $+ (down 12 $ delay 0 $ repTimes 4 $ mcatMaybes $ [4,4,5,4,5,4] `groupWith` g |> rest^*6)+ </> (down 12 $ delay 1 $ repTimes 4 $ mcatMaybes $ [4,4,5,4,5,4] `groupWith` g |> rest^*6)+ </> (down 12 $ delay 3 $ repTimes 4 $ mcatMaybes $ [4,5,4,5,4,4] `groupWith` g |> rest^*6)+ </> (down 12 $ delay 6 $ repTimes 4 $ mcatMaybes $ [3,3,5,3,3] `groupWith` g |> rest^*6)+-- +colLegno2Alt :: Score Note+colLegno2Alt = {-staccato $ -} level (mp) $ text "col legno battuto" $+ (down 12 $ delay 0 $ mcatMaybes $ repWithIndex 4 $ \t -> [4,4,5,4,5,4] `groupWith` g |> rest^*(1+4*t))+ </> (down 12 $ delay 1 $ mcatMaybes $ repWithIndex 4 $ \t -> [4,4,5,4,5,4] `groupWith` g |> rest^*(1+4*t))+ </> (down 24 $ delay 3 $ mcatMaybes $ repWithIndex 4 $ \t -> [4,5,4,5,4,4] `groupWith` g |> rest^*(1+4*t))+ </> (down 24 $ delay 6 $ mcatMaybes $ repWithIndex 4 $ \t -> [3,3,5,3,3] `groupWith` g |> rest^*(1+4*t))++-- --------------------------------------------------------------------------------+-- +makeJete :: Behavior Pitch -> Bool -> Duration -> Score Note+makeJete p v d = text "jeté" $ pitches' %~ (+ p) $ mcatMaybes $ g_ |> ((if v then cs else cs_){-^/2-}) {-|> rest^/2-} |> rest^*d++makeJetes :: [Behavior Pitch] -> [Bool] -> [Duration] -> Score Note+makeJetes ps vs ds = scat $ zipWith3 makeJete ps vs ds++jete1 :: Score Note+jete1 = id $ -- FIXME temporary fix w.r.t onset/padToBar+ (delay 3 $ up 0 $ makeJetes (rotated 0 ps) (rotated 3 vs) (rotated 1 ds))+ </> (delay 5 $ up 0 $ makeJetes (rotated 1 ps) (rotated 0 vs) (rotated 3 ds))^*(4/5)+ </> (delay 7 $ down 12 $ makeJetes (rotated 2 ps) (rotated 1 vs) (rotated 2 ds))+ </> (delay 12 $ down 12 $ makeJetes (rotated 3 ps) (rotated 2 vs) (rotated 0 ds))^*(4/5)+ where+ ps = take n $ cycle [0,6,6,0,6,6,0]+ vs = take n $ cycle [True,False,True,False,True,False,True,False]+ ds = take n $ cycle $ fmap (+ 4) [3,7,5,7,5,5,3,7,7,7,7,7,5,3,7,7,7,7,7,3,3,5]+ n = 9+-- +-- -- colLegno3 :: Score Note+-- -- colLegno3 = (down 12 $ delay 0 $ rep $ [4,4,5,4,5,4] `groupWith` g |> rest^*6)+-- +-- +-- --------------------------------------------------------------------------------+-- +makeCanon_I :: Rational -> Dynamic Note -> Score Note -> Score Note -> Score Note+makeCanon_I n dn subj1 subj2 =+ level dn (rev (a </> b </> c </> d) |> (a </> b </> c </> d))+ where+ a = (repTimes (floor $ 5*n/(4/3)) $ subj1 ^*(4/3))+ b = (repTimes (floor $ 5*n/1) $ subj2 ^*1)+ c = (repTimes (floor $ 5*n/2) $ subj1 ^*2)+ d = (repTimes (floor $ 5*n/3) $ subj2 ^*3)+-- +canon_I :: Score Note+canon_I = text "ord" $ (^*2) $ makeCanon_I 1 {-dn-}mf subj1 subj2+ where+ subj1 = g_ |> a_^*(3/2) |> g_^*2+ subj2 = f_^*3 |> bb_^*1 |> a_ |> g_^*3+ -- dn = (repTimes 5 $ (pp `cresc` mf)^*3 |> (mf `dim` pp)^*3 )+-- +-- makeCanon_II :: Score (Levels Double) -> Score Note -> Score Note -> Score Note+-- makeCanon_II dn subj1 subj2 =+-- level dn (rev $ a </> b </> c </> d)+-- where+-- a = (repWithTime 5 $ \t -> {-up (round $ octave * t) $ -}subj1 ^*(4/3))+-- b = (repWithTime 5 $ \t -> {-up (round $ octave * t) $ -}subj2 ^*1)+-- c = (repWithTime 2 $ \t -> {-up (round $ octave * t) $ -}subj1 ^*2)+-- d = (repWithTime 2 $ \t -> {-up (round $ octave * t) $ -}subj2 ^*3)+-- +-- canon_II :: Score Note+-- canon_II = text "ord" $ (^*2) $ makeCanon_II dn subj1 subj2+-- where+-- subj1 = g_ |> d^*(3/2) |> c^/2 |> a_^/2 |> bb_^/2+-- subj2 = f_^*3 |> bb_^*1 |> a_ |> d_^*3+-- dn = (repTimes 5 $ (pp `cresc` mf)^*3 |> (mf `dim` pp)^*3 )+-- +-- makeCanon_III :: Double -> Score (Levels Double) -> Score Note -> Score Note -> Score Note+-- makeCanon_III n dn subj1 subj2 =+-- level dn (rev (a </> b </> c </> d) |> (a </> b </> c </> d))+-- where+-- a = (repTimes (5*n/(4/3)) $ subj1 ^*(4/3))+-- b = (repTimes (5*n/1) $ subj2 ^*1)+-- c = (repTimes (5*n/2) $ subj1 ^*2)+-- d = (repTimes (5*n/3) $ subj2 ^*3)+-- +-- canon_III :: Score Note+-- canon_III = text "ord" $ makeCanon_III 1.6 dn subj1 subj2+-- where+-- subj1 = g^*2 |> d |> eb^*(3/2) |> c^*2 |> d^*2+-- subj2 = f_^*3 |> bb_^*1 |> a_ |> g_^*2 |> d^*3 |> c^*1+-- dn = (repTimes 5 $ (mf `cresc` _f)^*3 |> (_f `dim` mf)^*3 )+-- +-- makeCanon_IV :: Bool -> Score Note -> Score Note -> Score Note -> Score Note+-- makeCanon_IV flip subj1 subj2 bass = if flip then lower </> upper else upper </> lower+-- where+-- upper = (repWithTime (10/(4/5)) $ \t -> reg Vl1 t $ subj1 ^* (4/5) )+-- </> (repWithTime (12/(2/3)) $ \t -> reg Vla1 t $ subj1 ^* (2/3) )+-- </> (repWithTime (15/ 1 ) $ \t -> reg Vc1 t $ subj1 ^* 1 )+-- </> (repWithTime (18/ 2 ) $ \t -> reg Db2 t $ bass ^* 1 )+-- +-- lower = (repWithTime (10/(2/3)) $ \t -> reg Vl2 t $ subj2 ^* (2/3) )+-- </> (repWithTime (12/ 1 ) $ \t -> reg Vla2 t $ subj2 ^* 1 )+-- </> (repWithTime (15/(3/2)) $ \t -> reg Vc2 t $ subj2 ^* (3/2) )+-- </> (repWithTime (18/ 2 ) $ \t -> reg Db2 t $ bass ^* 1 )+-- +-- reg Vl1 t | t < 0.3 = up (octave + fifth) | t < 0.6 = up octave | t >= 0.6 = up fifth+-- reg Vl2 t | t < 0.4 = up octave | t < 0.7 = up fifth | t >= 0.7 = up fifth+-- reg Vla1 t | t < 0.4 = up fifth | t < 0.7 = up fifth | t >= 0.7 = up unison+-- reg Vla2 t | t < 0.4 = up unison | t < 0.7 = up fifth | t >= 0.7 = up unison+-- reg Vc1 t | t < 0.4 = down octave | t < 0.7 = down octave | t >= 0.7 = down fourth+-- reg Vc2 t | t < 0.4 = down octave | t < 0.7 = down octave | t >= 0.7 = down fourth+-- +-- reg Db1 t | t < 0.4 = down (octave*1) | t < 0.7 = down (octave*1) | t >= 0.7 = down (octave*1)+-- reg Db2 t | t < 0.4 = down (octave*2) | t < 0.7 = down (octave*1) | t >= 0.7 = down (octave*1)+-- +-- +-- canon_IV :: Score Note+-- canon_IV = text "ord" $ c^*padC |> firstC |> secondC+-- where+-- firstC = level dn1 $ rev $ makeCanon_IV False subj1 subj2 bass+-- secondC = level dn2 $ makeCanon_IV True subj1 subj2 bass+-- padC = fromIntegral $ 4 - numerator (getDuration $ duration firstC) `mod` 4+-- dn1 = (repTimes 10 $ (mf `cresc` _f)^*5 |> (_f `dim` mf)^*5)+-- dn2 = (repTimes 10 $ (_f `cresc` ff)^*5 |> (ff `dim` _f)^*5)+-- +-- subj1 = down 2 $ (d^*3 |> a |> g^*2 |> c' |> b |> c' |> b |> g |> a^*3)+-- subj2 = down 2 $ (d^*2 |> a |> g^*2 |> c' |> b |> c' |> b |> g |> a^*3)+-- bass = melody [d,a] |> g^*2 |> melody [c,d,a] |> g^*2+-- -- bass = melody [d,g] |> a^*2 |> melody [c,g,d] |> a^*2++++cresc = const+dim = const+repTimes = times++-- groupWith :: [Int] -> a -> a+groupWith xs p = scat $ fmap (\n -> group n p) xs++group n x = times n x^/(fromIntegral n)+repWithIndex n f = scat $ fmap f [1..n]++moveToPart p x = parts' .~ p $ x++[vl1, vl2] = divide 2 $ tutti violin
+ examples/mozart.hs view
@@ -0,0 +1,200 @@++{-# LANGUAGE+ OverloadedStrings,+ TypeFamilies,+ FlexibleContexts,+ NoMonomorphismRestriction #-}++module Main where+import qualified Music.Score+import Music.Prelude.Standard hiding (open, play, openAndPlay)+import Control.Concurrent.Async+import Control.Applicative+import System.Process (system)++{- + W.A. Mozart: Ave Verum (excerpt)+ + Transcribed from autograph, see+ http://imslp.org/wiki/Ave_verum_corpus,_K.618_(Mozart,_Wolfgang_Amadeus)++ Divided as follows (including preceding accompaniement):++ stanza1: Ave verum corpus natum de Maria virgine+ stanza2: Vere passum immolatum in cruce pro homoni+ stanza3: Cujus latus perforatum unda fluxit et sanguine+ stanza4: Esto nobis praegustatum in mortis examine+-}+++-- Vocal parts+[vl1, vl2] = divide 2 (tutti violin)+vla = tutti viola+vc = tutti cello++-- Instruments+[sop, alt] = divide 2 (tutti violin)+ten = tutti viola+-- bs = tutti cello+bc = tutti doubleBass+++info = id+ . title "Ave Verum Corpus (excerpt)"+ . composer "W.A. Mozart"+ . timeSignature (4/4)+ . keySignature (key g False)++score' = info $ compress 4 $ tempo (metronome (1/4) 30) $ {-delay (4*2) $ -} + stanza1_instr </> stanza1_voc++-- Rhythm helper functions+lss l s1 s2 = l^*2 |> s1 |> s2+ssl s1 s2 l = s1 |> s2 |> l^*2+s3 s1 s2 s3 = s1 |> s2 |> s3+s4 s1 s2 s3 s4 = s1 |> s2 |> s3 |> s4+sl s l = s |> l^*3+ls l s = l^*3 |> s+fit2 x y = (x |> y)^/2+l4 l = l^*4+ll l1 l2 = (l1 |> l2)^*2++a2 = a ^* 2+as2 = as ^* 2+ab2 = ab ^* 2+b2 = b ^* 2+bs2 = bs ^* 2+bb2 = bb ^* 2+c2 = c ^* 2+cs2 = cs ^* 2+cb2 = cb ^* 2+d2 = d ^* 2+ds2 = ds ^* 2+db2 = db ^* 2+e2 = e ^* 2+es2 = es ^* 2+eb2 = eb ^* 2+f2 = f ^* 2+fs2 = fs ^* 2+fb2 = fb ^* 2+g2 = g ^* 2+gs2 = gs ^* 2+gb2 = gb ^* 2+(//) = (|>)++{-+ Can we "overload application" as in ++ c :: PitchL -> PitchL -> Score a+ (c d) :: PitchL -> Score a+ (c d) e :: Score a++ Alternatively, make score' instance of IsString and use Lilypond syntax+-}++-- Stanza 1+stanza1_voc = stanza1_sop </> stanza1_alto </> stanza1_ten </> stanza1_bass+stanza1_sop = asScore $ delay 8 $ empty+ |> s3 a2 d' fs |> s3 a gs g2 |> s4 g b a g |> ssl g fs fs+ |> ls e e |> s4 fs fs g g |> lss g (fit2 fs e) fs |> l4 e+stanza1_alto = asScore $ delay 8 $ empty+ |> ll fs fs |> ll e e |> s4 e g fs e |> ssl e d d + |> ls cs cs |> s4 d d e e |> lss e (fit2 d cs) d |> l4 cs+stanza1_ten = asScore $ delay 8 $ octavesDown 1 $ empty+ |> ll a a |> ll b b |> ls a a |> ll a a + |> ls e e |> s4 a a b b |> ls a a |> l4 e+stanza1_bass = asScore $ delay 8 $ octavesDown 1 $ empty+ |> ll d d |> ll d d |> ls cs cs |> ll d d + |> ls a a |> s4 d d cs cs |> ls d d |> l4 a_++stanza1_instr = stanza1_vl1 </> stanza1_vl2 </> stanza1_vla </> stanza1_bc+stanza1_vl1 = asScore $ empty+ |> s4 d a_ d e |> s4 fs d fs g+ |> lss a d' fs |> ssl a gs g |> s4 g b a g |> ssl g fs fs+ |> ls e e |> s4 fs fs g g |> lss g (fit2 fs e) fs |> l4 e+stanza1_vl2 = asScore $ empty+ |> s4 d a_ d e |> s4 fs d fs g+ |> ll fs fs |> ll e e |> s4 e g fs e |> ssl e d d + |> ls cs cs |> s4 d d e e |> lss e (fit2 d cs) d |> l4 cs+stanza1_vla = asScore $ octavesDown 1 $ empty+ |> s4 d a_ d e |> s4 fs d fs g+ |> ll a a |> ll b b |> ls a a |> ll a a + |> ls e e |> s4 a a b b |> ls a a |> l4 e+stanza1_bc = asScore $ octavesDown 1 $ empty+ |> s4 d a_ d e |> s4 fs d fs g+ |> ll d d |> ll d d |> ls cs cs |> ll d d + |> ls a a |> s4 d d cs cs |> ls d d |> l4 a_+++-- Stanza 2++++++++++++++++++++++++mapEvensOdds :: (a -> b) -> (a -> b) -> [a] -> [b]+mapEvensOdds f g xs = let+ evens = fmap (xs !!) [0,2..]+ odds = fmap (xs !!) [1,3..]+ merge xs ys = concatMap (\(x,y) -> [x,y]) $ xs `zip` ys+ in take (length xs) $ map f evens `merge` map g odds+++{-+openAudacity :: Score Note -> IO () +openAudacity x = do+ void $ writeMidi "test.mid" $ x+ void $ system "timidity -Ow test.mid"+ void $ system "open -a Audacity test.wav"++openAudio :: Score Note -> IO () +openAudio x = do+ void $ writeMidi "test.mid" $ x+ void $ system "timidity -Ow test.mid"+ void $ system "open -a Audacity test.wav"+-}++-- fixClefs :: Score Note -> Score Note+-- fixClefs = pcat . fmap (uncurry g) . extractParts'+-- where+-- g p x = clef (case defaultClef p of { 0 -> GClef; 1 -> CClef; 2 -> FClef } ) x+fixClefs = id++concurrently_ :: IO a -> IO b -> IO ()+concurrently_ = concurrentlyWith (\x y -> ())++concurrentlyWith :: (a -> b -> c) -> IO a -> IO b -> IO c+concurrentlyWith f x y = uncurry f <$> x `concurrently` y++palindrome x = rev x |> x+++++main :: IO ()+main = open score'++-- play, open, openAndPlay :: Score Note -> IO () +tempo_ = 80+play x = return () -- openAudio $ stretch ((60*(8/3))/tempo_) $ fixClefs $ x+open x = openLilypond' LyScoreFormat $ fixClefs $ x+openAndPlay x = play x `concurrently_` open x+
+ examples/part.hs view
@@ -0,0 +1,131 @@++{-# LANGUAGE OverloadedStrings, TypeFamilies #-}++import Music.Prelude.Standard hiding (open, play, openAndPlay)+import qualified Music.Score as Score+import Control.Concurrent.Async+import Control.Applicative+import System.Process (system)++{- + Arvo Pärt: Cantus in Memory of Benjamin Britten (1977)++ Inspired by the Abjad transcription+-}++main :: IO ()+main = open music++ensemble :: [Part]+ensemble = [solo tubularBells] <> (divide 2 (tutti violin)) <> [tutti viola] <> [tutti cello] <> [tutti doubleBass]++music :: Score Note+music = meta $ stretch (3/2) $ {-before 60-} (mempty <> bell <> delay 6 strings)+ where+ meta = id+ . title "Cantus in Memoriam Benjamin Britten" + . composer "Arvo Pärt" + . timeSignature (6/4) + . tempo (metronome (1/4) 120)++withTintin :: (HasPitches' a, Score.Pitch a ~ Behavior Pitch) => Pitch -> Score a -> Score a+withTintin p x = x <> tintin p x++-- | Given the melody voice return the tintinnabular voice.+tintin :: (HasPitches' a, Score.Pitch a ~ Behavior Pitch) => Pitch -> Score a -> Score a+tintin tonic = pitches . mapped %~ relative tonic tintin'++-- | +-- Given the melody interval (relative tonic), returns the tintinnabular voice interval. +--+-- That is return the highest interval that is a member of the tonic minorTriad in any octave+-- which is also less than the given interval +--+tintin' :: Interval -> Interval+tintin' melInterval + | isNegative melInterval = error "tintin: Negative interval"+ | otherwise = last $ takeWhile (< melInterval) $ tintinNotes+ where+ tintinNotes = concat $ iterate (fmap (+ _P8)) minorTriad+ minorTriad = [_P1,m3,_P5]+++bell :: Score Note+bell = let+ cue :: Score (Maybe Note)+ cue = stretchTo 1 (rest |> a) + in parts' .~ (ensemble !! 0) $ text "l.v." $ mcatMaybes $ times 40 $ scat [times 3 $ scat [cue,rest], rest^*2]++strings :: Score Note+strings = strings_vln1 <> strings_vln2 <> strings_vla <> strings_vc <> strings_db++strings_vln1 = clef GClef $ parts' .~ (ensemble !! 1) $ up (_P8^*1) $ strings_cue+strings_vln2 = clef GClef $ parts' .~ (ensemble !! 2) $ up (_P8^*0) $ stretch 2 strings_cue+strings_vla = clef CClef $ parts' .~ (ensemble !! 3) $ down (_P8^*1) $ stretch 4 strings_cue+strings_vc = clef FClef $ parts' .~ (ensemble !! 4) $ down (_P8^*2) $ stretch 8 strings_cue+strings_db = clef FClef $ parts' .~ (ensemble !! 5) $ down (_P8^*3) $ stretch 16 strings_cue+strings_cue = delay (1/2) $ withTintin (down (_P8^*4) $ asPitch a) $ mainSubject++fallingScale :: [Score Note]+fallingScale = [a',g'..a_]++fallingScaleSect :: Int -> [Score Note]+fallingScaleSect n = {-fmap (annotate (show n)) $-} take n $ fallingScale++mainSubject :: Score Note+mainSubject = stretch (1/6) $ asScore $ scat $ mapEvensOdds (accent . (^*2)) id $ concatMap fallingScaleSect [1..30]++++++++++++++++++mapEvensOdds :: (a -> b) -> (a -> b) -> [a] -> [b]+mapEvensOdds f g xs = let+ evens = fmap (xs !!) [0,2..]+ odds = fmap (xs !!) [1,3..]+ merge xs ys = concatMap (\(x,y) -> [x,y]) $ xs `zip` ys+ in take (length xs) $ map f evens `merge` map g odds+++openAudacity :: Score Note -> IO () +openAudacity x = do+ void $ writeMidi "test.mid" $ x+ void $ system "timidity -Ow test.mid"+ void $ system "open -a Audacity test.wav"++openAudio :: Score Note -> IO () +openAudio x = do+ -- void $ writeMidi "test.mid" $ x+ void $ system "timidity -Ow test.mid"+ void $ system "open -a Audacity test.wav"++fixClefs :: Score Note -> Score Note+fixClefs = id+-- fixClefs = pcat . fmap (uncurry g) . extractParts'+-- where+-- g p x = clef (case defaultClef p of { 0 -> GClef; 1 -> CClef; 2 -> FClef } ) x++concurrently_ :: IO a -> IO b -> IO ()+concurrently_ = concurrentlyWith (\x y -> ())++concurrentlyWith :: (a -> b -> c) -> IO a -> IO b -> IO c+concurrentlyWith f x y = uncurry f <$> x `concurrently` y++play, open, openAndPlay :: Score Note -> IO () +tempo_ = 120+play x = openAudio $ stretch ((60*4)/tempo_) $ fixClefs $ x+open x = openLilypond' LyScoreFormat $ fixClefs $ x+openAndPlay x = play x `concurrently_` open x+
+ examples/phrases.hs view
@@ -0,0 +1,29 @@++{-# LANGUAGE OverloadedStrings #-}++{-+ +-}+import Music.Prelude++-- A simple subject+subj = times 2 $ scat [c,c,d,b_,e,e]^/16++-- Each voice differ slighly in onset etc+voca v = delay ((4/8)^*v) $ mcatMaybes $ scat $ fmap (\i -> (id $ up (_M2^*i) subj) |> rest^*(15/8)) + $ [0..3]++-- The +music = id+ $ title "Phrases"+ $ composer "Anonymous"+ $ timeSignature (3/8) + $ timeSignatureDuring ((14*3/8) <-> 200) (4/8) + $ over phrases (rotateValues 1)+ -- $ over (phrases.middleV) (octavesAbove 1) + -- $ over phrases fuse + $ rcat + -- $ fadeIn 4+ $ map voca [0..3]++main = open $ asScore $ music
+ examples/plot.hs view
@@ -0,0 +1,115 @@++{-# LANGUAGE FlexibleContexts, NoMonomorphismRestriction #-}++module Main where++import Control.Applicative+import Graphics.EasyPlot ++import Music.Prelude.Basic+import Music.Time.Reactive +import Music.Time.Behavior++---+import Prelude hiding (null)+import Data.AffineSpace+import Data.VectorSpace+import Data.Sequence hiding (reverse)+---++durToPitch :: Duration -> Pitch+durToPitch = fromInteger . round++durToInterval :: Duration -> Interval+durToInterval = fromInteger . round++sc :: Score (Behavior Pitch)+sc = times 240 $ note (varying $ const 0)++changePitch :: Behavior Pitch -> Behavior Pitch+changePitch = liftA2 (^+.) $ + switchB 24 (pure _P1) + (switchB 48 sine sine2)+ where+ sine = varying (durToInterval.(*12).sinR.(* (tauR/12)))+ sine2 = delay 48 $ varying (durToInterval.(*13).sinR.(* (tauR/13)))++++-- main = do+ -- openLilypond $ sc2^/12+ -- playMidiIO "" $ sc2^/12++-- sc2 = fmap (? 0) $ __mapPitch changePitch sc+ ++tau = 2*pi+tauR = realToFrac tau+sinR :: (Real a, Fractional b) => a -> b+sinR = realToFrac . sin . realToFrac+(^+.) = flip (.+^)+++plotR :: (Num a, Show a) => Reactive a -> IO ()+plotR r = do+ plot X11 $ (\t -> r ? realToFrac t)+ return ()++plotRs :: (Num a, Show a) => [Reactive a] -> IO ()+plotRs rs = do+ plot X11 $ map (\r -> (\t -> r ? realToFrac t)) rs+ return ()++plotB :: (Num a, Show a) => Behavior a -> IO ()+plotB r = do+ plot X11 $ (\t -> r ? realToFrac t)+ return ()++plotBs :: (Num a, Show a) => [Behavior a] -> IO ()+plotBs rs = do+ plot X11 $ map (\r -> (\t -> r ? realToFrac t)) rs+ return ()+++-- main = +-- plotRs $ [delay (-0.5) r1, stretch 1.1 $ delay (-0.5) r1]+-- r1 = switch (-3) (pure (-3)) (switch 3 (activate ((0 <-> 1) =: (pure 1)) (pure 0)) (pure 3))+++++++++++++++-- From http://alexis.vallet.free.fr/?p=412+bezier, bezier' :: (AffineSpace p, VectorSpace (Diff p)) => + [p] -> Scalar (Diff p) -> p++bezier' [p] _ = p+bezier' polygon t = + let poly0 = reverse . tail $ reverse polygon+ poly1 = tail polygon in+ alerp (bezier' poly0 t) (bezier' poly1 t) t++bezier polygon t =+ bezierSeq (fromList polygon) t+ +bezierSeq :: (AffineSpace p, VectorSpace (Diff p)) => + Seq p -> Scalar (Diff p) -> p+bezierSeq polygon t =+ let poly0 :> _ = viewr polygon+ p :< poly1 = viewl polygon in+ if null poly1+ then p+ else alerp (bezierSeq poly0 t) (bezierSeq poly1 t) t++examplePolygon :: [(Double, Double)]+examplePolygon = [(0, 0), (1, 1), (2, 0)]+
+ examples/scheme.hs view
@@ -0,0 +1,225 @@++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-+ Basic Scheme bindings++ For examples, see test1.scm (TODO write more)++ Requires husk-scheme to be in your path+ http://hackage.haskell.org/package/husk-scheme+-}+module Main where++import Data.Either+import Data.IORef+import qualified Data.Map as Map+import Data.Maybe+import Data.Traversable+import Language.Scheme.Core+import Language.Scheme.Parser+import Language.Scheme.Types+import Language.Scheme.Variables+import Music.Prelude+import qualified Music.Score as Score+import System.IO.Unsafe+-- import qualified Data.List+-- import System.Random++type LispScore = Score Integer+instance AffineSpace Integer where+ type Diff Integer = Integer+ (.-.) = (-)+ (.+^) = (+)++lispApi = [+ ("c", toLisp (c :: LispScore)),+ ("d", toLisp (d :: LispScore)),+ ("e", toLisp (e :: LispScore)),+ ("f", toLisp (f :: LispScore)),+ ("g", toLisp (g :: LispScore)),+ ("a", toLisp (a :: LispScore)),+ ("b", toLisp (b :: LispScore)),++ ("c#", toLisp (cs :: LispScore)),+ ("d#", toLisp (ds :: LispScore)),+ ("e#", toLisp (es :: LispScore)),+ ("f#", toLisp (fs :: LispScore)),+ ("g#", toLisp (gs :: LispScore)),+ ("a#", toLisp (as :: LispScore)),+ ("b#", toLisp (bs :: LispScore)),++ ("cb", toLisp (cb :: LispScore)),+ ("db", toLisp (db :: LispScore)),+ ("eb", toLisp (eb :: LispScore)),+ ("fb", toLisp (fb :: LispScore)),+ ("gb", toLisp (gb :: LispScore)),+ ("ab", toLisp (ab :: LispScore)),+ ("bb", toLisp (bb :: LispScore)),++ ("m3", toLisp (m3 :: Integer)),+ ("M3", toLisp (_M3 :: Integer)),+ ("up", CustFunc $ lift2 (up :: Integer -> LispScore -> LispScore)),++ -- ("ff", toLisp (fff :: Sum Double)),+ -- ("level", CustFunc $ lift2 (up :: Sum Double -> LispScore -> LispScore)),+++ ("times", CustFunc $ lift2 (times :: Int -> LispScore -> LispScore)),+ ("stretch", CustFunc $ lift2 (stretch :: Duration -> LispScore -> LispScore)),+ ("compress", CustFunc $ lift2 (compress :: Duration -> LispScore -> LispScore)),+ ("move", CustFunc $ lift2 (delay :: Duration -> LispScore -> LispScore)),++ ("scat", CustFunc $ liftV (scat :: [LispScore] -> LispScore)),+ ("pcat", CustFunc $ liftV (pcat :: [LispScore] -> LispScore)),+ ("rcat", CustFunc $ liftV (rcat :: [LispScore] -> LispScore)),++ ("|>", CustFunc $ lift2 ((|>) :: LispScore -> LispScore -> LispScore)),+ ("<>", CustFunc $ lift2 ((|>) :: LispScore -> LispScore -> LispScore)),+ ("</>", CustFunc $ lift2 ((</>) :: LispScore -> LispScore -> LispScore)),++ ("first-argument", CustFunc $ \(x : _) -> return x),+ ("second-argument", CustFunc $ \(_ : x : _) -> return x)+ ]++++main = do+ stdEnv <- r5rsEnv+ env <- extendEnv stdEnv (map (over _1 (varNamespace,)) $ lispApi)+ code <- readFile "examples/test1.scm"+ res <- evalLisp' env $ fromRight $ readExpr code+ let sc = (\x -> x :: LispScore) $ fromJust $ fromRight $ fmap fromLisp $ res+ -- printScore sc+ openLilypond $ fmap (\x -> PartT(mempty::Part,TieT(mempty,ArticulationT(mempty::(Sum Double,Sum Double),DynamicT(mempty::Sum Double,[x]))))) $ sc+ return ()++printScore = mapM_ print . view notes+fromRight (Right x) = x +++class HasLisp a where+ _unlisp :: Prism' LispVal a++toLisp :: HasLisp a => a -> LispVal+toLisp = view (re _unlisp)++fromLisp :: HasLisp a => LispVal -> Maybe a+fromLisp = preview _unlisp++instance HasLisp Bool where+ _unlisp = prism' Bool $ \x -> case x of+ Bool x -> Just x+ _ -> Nothing++instance HasLisp Int where+ _unlisp = prism' (Number . toInteger) $ \x -> case x of+ Number x -> Just (fromInteger x)+ _ -> Nothing++instance HasLisp Integer where+ _unlisp = prism' Number $ \x -> case x of+ Number x -> Just x+ _ -> Nothing++-- instance HasLisp Pitch where+ -- _unlisp = _unlisp . iso ((c.+^) . spell usingSharps . fromInteger) (toInteger.semitones.(.-. c))++instance HasLisp Rational where+ _unlisp = prism' Rational $ \x -> case x of+ Number x -> Just (fromIntegral x)+ Rational x -> Just x+ Float x -> Just (realToFrac x)+ _ -> Nothing++instance HasLisp Double where+ _unlisp = prism' Float $ \x -> case x of+ Number x -> Just (fromIntegral x)+ Rational x -> Just (fromRational x)+ Float x -> Just x+ _ -> Nothing++instance HasLisp Duration where+ _unlisp = _unlisp . rationalFrac++instance HasLisp Time where+ _unlisp = _unlisp . rationalFrac++instance HasLisp Span where+ _unlisp = _unlisp . from delta++instance HasLisp a => HasLisp (Score.Note a) where+ _unlisp = _unlisp . note++instance HasLisp a => HasLisp (Score a) where+ _unlisp = _unlisp . from unsafeNotes++instance (HasLisp a, HasLisp b) => HasLisp (a, b) where+ _unlisp = prism' (lcons . over _1 toLisp . over _2 toLisp) $ \xs -> case xs of+ DottedList [x] y -> case (fromLisp x, fromLisp y) of+ (Just x, Just y) -> Just (x, y)+ _ -> Nothing+ _ -> Nothing + where+ lcons (x, y) = DottedList [x] y++instance HasLisp a => HasLisp [a] where+ _unlisp = prism' (List . map toLisp) $ \xs -> case xs of+ List xs -> sequenceA $ map fromLisp $ xs+ _ -> Nothing++-- instance HasLisp Double where+ -- _unlisp = _unlisp . iso fromInteger (toInteger.round)++type LispFunc = [LispVal] -> IOThrowsError LispVal++liftV :: (HasLisp a, HasLisp b) => ([a] -> b) -> LispFunc+liftV f as = case (sequenceA $ map fromLisp as) of+ (Just as) -> return $ toLisp $ f as+ _ -> fail $ "Type error: got " ++ show as++lift1 :: (HasLisp a, HasLisp b) => (a -> b) -> LispFunc+lift1 f [a1] = case (fromLisp a1) of+ (Just a1) -> return $ toLisp $ f a1+ _ -> fail $ "Type error: got " ++ show a1+lift1 f _ = fail "Wrong number of args"++lift2 :: (HasLisp a, HasLisp b, HasLisp c) => (a -> b -> c) -> LispFunc+lift2 f [a1, a2] = case (fromLisp a1, fromLisp a2) of+ (Just a1, Just a2) -> return $ toLisp $ f a1 a2+ _ -> fail "Type error"+lift2 f _ = fail "Wrong number of args"+ +-- lift2 :: (a -> b -> c) -> LispFunc+++{-+makeEnv :: [(String, LispFunc)] -> Env -> Env+makeEnv bindings = composed $ map (uncurry extendEnv2 . fmap CustFunc) $ bindings+ where+composed = foldr (.) id++extendEnv2 :: String -> LispVal -> Env -> Env+extendEnv2 k v p = Environment (Just p) (retR $ toMap ("_" ++ k) (retR v)) (retR mempty) + where+ toMap k v = Map.insert k v mempty+ + retR :: a -> IORef a+ retR = unsafePerformIO . newIORef+-}+++doubleFrac = iso fromDouble toDouble+ where+ toDouble :: Real a => a -> Double+ toDouble = realToFrac++ fromDouble :: Fractional a => Double -> a+ fromDouble = realToFrac++rationalFrac = iso fromRational toRational+integInteg = iso fromInteger toInteger
+ examples/schubert.hs view
@@ -0,0 +1,44 @@++{-# LANGUAGE OverloadedStrings #-}++module Main where++import System.Process (runCommand)+import Music.Prelude.Basic++{- + Franz Schubert: Erlkönig, op. 1 (excerpt)+-}++main = do+ -- writeMidi "test.mid" music+ -- writeXml "test.xml" $ music^/4+ -- openXml music+ openLilypond music+ -- playMidiIO "Graphic MIDI" $ music^/10++music = let+ meta = id+ . title "Erlkönig, op.1 (excerpt)"+ . composer "Franz Schubert"+ . timeSignature (4/4)+ . keySignature (key g False)+ + triplet = group 3++ a `x` b = a^*(3/4) |> b^*(1/4)+ a `l` b = (a |> b)^/2+ + motive = (legato $ stretchTo 2 $ scat [g,a,bb,c',d',eb']) |> staccato (d' |> bb |> g)+ bar = rest^*4++ song = mempty+ left = below _P8 $ times 4 (times 4 $ removeRests $ triplet g)+ right = removeRests $ clef FClef $ down _P8 $ times 2 (delay 4 motive |> rest^*3)++ -- Use 4/4 or 12/8 notation+ useCommonTime = True+ scale = if useCommonTime then id else timeSignature (time 12 8) . stretch (3/2) + below a x = x <> down a x++ in asScore $ meta $ scale $ stretch (1/4) $ song </> left </> down _P8 right
+ examples/streams.hs view
@@ -0,0 +1,134 @@++{-# LANGUAGE OverloadedStrings, FlexibleContexts, ConstraintKinds, TypeFamilies, RankNTypes #-}++import Music.Score (pitch) -- TODO+import qualified Music.Score+import Music.Prelude.Standard hiding (pitch, open, play, openAndPlay)+import Control.Concurrent.Async+import Control.Applicative+import System.Process (system)+import qualified Data.Foldable+import Control.Lens hiding (Parts)+import Data.Default -- debug+import Math.OEIS++{- + A serial composition using sequences from the OEIS (http://oeis.org/)++ TODO optimize extendSequence etc (use local caching, possibly `unamb`)+-}++main :: IO ()+main = openMusicXml music++ensemble :: [Part]+ensemble = (divide 4 (tutti violin)) <> (divide 2 (tutti viola)) <> (divide 2 (tutti cello)) <> [tutti doubleBass]++type Scale = Integer -> Interval+scale :: Scale+scale n = case n `mod` 6 of+ 0 -> _P1+ 1 -> _M2+ 2 -> _M3+ 3 -> _A4+ 4 -> _P5+ 5 -> _M6++len = 90++seq1 :: Score Integer+seq1 = scat $ take len $ fmap return $ fmap (`mod` 6) $ Data.Foldable.toList $ extendSequence [2,1,1,2,2]+seq2 = scat $ take len $ fmap return $ fmap (`mod` 6) $ Data.Foldable.toList $ extendSequence [2,1,1,2,2,1]++-- Thue–Morse sequence+seq3 = scat $ take len $ fmap return $ fmap (`mod` 6) $ Data.Foldable.toList $ extendSequence [2,1,1,2,2,1,1]++music = pcat [(partNs 0 & up (m3^*2) & compress 6),+ (partNs 1 & up (m3^*1) & compress 5),+ (partNs 2 & compress 4)]+ & fmap (pitches' %~ normalize) & compress 4 & staccato++partNs n = part1 n <> part2 n <> part3 n+part1 n = asScore $ (parts' .~ (ensemble !! (0+3*n))) $ fmap (\x -> pitches' %~ (.+^ pure (scale x)) $ (c::Note)) $ seq1+part2 n = asScore $ (parts' .~ (ensemble !! (1+3*n))) $ fmap (\x -> pitches' %~ (.+^ pure (scale x)) $ (c::Note)) $ seq2+part3 n = asScore $ (parts' .~ (ensemble !! (2+3*n))) $ fmap (\x -> pitches' %~ (.+^ pure (scale x)) $ (c::Note)) $ seq3++-- instance Monoid Part where+-- mempty = def+-- instance Monoid p => Monad (PartT p) where+-- return x = PartT (mempty, x)++++++++++++-- TODO remove Default +{-+parts :: (Default (Music.Score.Part a), Traversable t, HasPart a) => Traversal' (t a) (Music.Score.Part a) +parts = traverse . part++part :: (Default (Music.Score.Part a), HasPart a) => Lens' a (Music.Score.Part a)+part = lens getPart (flip setPart)++part_ :: HasSetPitch a b => Setter a b (Music.Score.Pitch a) (Music.Score.Pitch b)+part_ = sets __mapPitch+-}++class Normal a where+ normalize :: a -> a+instance Normal Pitch where+ normalize = relative c (spell usingSharps)+instance Normal a => Normal (Behavior a) where+ normalize = fmap normalize++++merge xs ys = concatMap (\(x,y) -> [x,y]) $ xs `zip` ys++mapEvensOdds :: (a -> b) -> (a -> b) -> [a] -> [b]+mapEvensOdds f g xs = let++ evens [] = []+ evens (x:xs) = x:odds xs++ odds [] = []+ odds (x:xs) = evens xs++ in take (length xs) $ map f (evens xs) `merge` map g (odds xs)+++openAudacity :: Score Note -> IO () +openAudacity x = do+ void $ writeMidi "test.mid" $ x+ void $ system "timidity -Ow test.mid"+ void $ system "open -a Audacity test.wav"++openAudio :: Score Note -> IO () +openAudio x = do+ void $ writeMidi "test.mid" $ x+ void $ system "timidity -Ow test.mid"+ void $ system "open -a Audacity test.wav"++fixClefs :: Score Note -> Score Note+fixClefs = pcat . fmap (uncurry g) . extractParts'+ where+ g p x = clef (case defaultClef p of { 0 -> GClef; 1 -> CClef; 2 -> FClef } ) x++concurrently_ :: IO a -> IO b -> IO ()+concurrently_ = concurrentlyWith (\x y -> ())++concurrentlyWith :: (a -> b -> c) -> IO a -> IO b -> IO c+concurrentlyWith f x y = uncurry f <$> x `concurrently` y++play, open, openAndPlay :: Score Note -> IO () +tempo_ = 120+play x = openAudio $ stretch ((60*4)/tempo_) $ fixClefs $ x+open x = openLilypond' LyScoreFormat $ fixClefs $ x+openAndPlay x = play x `concurrently_` openMusicXml x+
+ examples/test1.scm view
@@ -0,0 +1,18 @@+(let ((first-note-duration 5/3) + (second-note-duration 2)+ (foo (lambda (x) x)))++ ;(rcat+ ; (move 3 (times 4 (scat (stretch first-note-duration c) (stretch second-note-duration d) eb)))+ ; (move 3 (times 4 (scat (stretch first-note-duration c) (stretch second-note-duration d) eb))))+ + (stretch 4+ (scat+ (compress 8 (scat c d e))+ (compress 16 (scat c d e))+ (compress 8 (scat c d e f))+ (up (foo m3)+ (scat+ (compress 16 (scat c d e))+ (compress 8 (scat c d e))+ (compress 16 (scat c d e (pcat f bb))))))))
+ examples/time_signatures.hs view
@@ -0,0 +1,16 @@++{-# LANGUAGE OverloadedStrings #-}++import Music.Prelude++main = open music++music = id+ $ title "Time signatures"+ $ fmap (over dynamics (! 0)) + -- $ timeSignature (2/4)+ -- $ timeSignature (3/4)+ $ timeSignature (6/8)+ -- $ timeSignature ((4+3)/8)+ $ level (ff*stretch (2*14/8) sine)+ $ scat [c,c',b,bb,a,as,g^*2,scat [f,e,d,b_]^/2,d^*2,c^*2]^/8
+ examples/trio.hs view
@@ -0,0 +1,135 @@++{-# LANGUAGE+ OverloadedStrings,+ NoMonomorphismRestriction #-}++import Music.Prelude.Standard hiding (open, play, openAndPlay)+import Control.Concurrent.Async+import Control.Applicative+import System.Process (system)++{- + String quartet+ Hommage a Henrik Strindberg+-}++-- Ensemble+[vl1, vl2] = divide 2 (tutti violin)+vla = tutti viola+vc = tutti cello++music :: Score Note+music = mainCanon2++tremCanon = compress 4 $+ (delay 124 $ set parts' vl1 $ subjs^*1)+ <>+ (delay 120 $ set parts' vl2 $ subjs^*1)+ <>+ (delay 4 $ set parts' vla $ subjs^*2)+ <>+ (delay 0 $ set parts' vc $ subjs^*2)+ where+ subjs = scat $ map (\n -> palindrome $ rev2 $ subj n) [1..40]+ subj n + | n < 8 = a_^*2 |> e^*1 |> a^*1+ | n < 16 = a_^*2 |> e^*1 |> a^*1 |> e^*1 |> a^*1+ | n < 24 = a_^*2 |> e^*0.5 |> a^*0.5 |> e^*0.5 |> a^*0.5+ | otherwise = e^*0.5 |> a^*0.5++mainCanon2 = palindrome mainCanon <> celloEntry++celloEntry = set parts' vc e''^*(25*5/8)++mainCanon = timeSignature (time 6 8) $ asScore $ + (set parts' vl1 $ harmonic 2 $ times 50 $ legato $ accentLast $ + octavesUp 2 $ scat [a_,e,a,cs',cs',a,e,a_]^/8) ++ <> + (set parts' vl2 $ harmonic 2 $ times 50 $ legato $ accentLast $ + octavesUp 2 $ scat [d,g,b,b,g,d]^/8)^*(3/2)++ <> + (set parts' vla $ harmonic 2 $ times 50 $ legato $ accentLast $ + octavesUp 2 $ scat [a,d,a,a,d,a]^/8)^*(3*2/2)++ <> + set parts' vc a'^*(25*5/8)++++++++++++++++++++++++++++++++mapEvensOdds :: (a -> b) -> (a -> b) -> [a] -> [b]+mapEvensOdds f g xs = let+ evens = fmap (xs !!) [0,2..]+ odds = fmap (xs !!) [1,3..]+ merge xs ys = concatMap (\(x,y) -> [x,y]) $ xs `zip` ys+ in take (length xs) $ map f evens `merge` map g odds+++openAudacity :: Score Note -> IO () +openAudacity x = do+ void $ writeMidi "test.mid" $ x+ void $ system "timidity -Ow test.mid"+ void $ system "open -a Audacity test.wav"++openAudio :: Score Note -> IO () +openAudio x = do+ void $ writeMidi "test.mid" $ x+ void $ system "timidity -Ow test.mid"+ void $ system "open -a Audacity test.wav"++fixClefs :: Score Note -> Score Note+fixClefs = pcat . fmap (uncurry g) . extractParts'+ where+ g p x = clef (case defaultClef p of { 0 -> GClef; 1 -> CClef; 2 -> FClef } ) x++concurrently_ :: IO a -> IO b -> IO ()+concurrently_ = concurrentlyWith (\x y -> ())++concurrentlyWith :: (a -> b -> c) -> IO a -> IO b -> IO c+concurrentlyWith f x y = uncurry f <$> x `concurrently` y++-- palindrome x = rev2 x |> x+-- TODO+-- rev2 = rev+rev2 = id++++main :: IO ()+main = open music++play, open, openAndPlay :: Score Note -> IO () +tempo_ = 130+play x = openAudio $ stretch ((60*(8/3))/tempo_) $ fixClefs $ x+open x = openLilypond' LyScoreFormat $ fixClefs $ x+openAndPlay x = play x `concurrently_` open x+
+ examples/try.hs view
@@ -0,0 +1,90 @@++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}++{-+ A webb with a Music Suite-aware interpreter+ Requires threepenny-gui-0.4.2.0+-}+module Main where++import Data.Either+import qualified Data.Map as Map+import Data.Maybe+import Data.Traversable+import Music.Prelude hiding ((#), element, set, text, option, pre, never)+import qualified Music.Score as Score+-- import qualified Data.List+-- import System.Random++import Graphics.UI.Threepenny+import Graphics.UI.Threepenny.Core+import Graphics.UI.Threepenny.Elements++main :: IO ()+main = do+ startGUI defaultConfig+ { tpPort = Just 1032+ , tpStatic = Nothing+ } + -- setup+ (runR $ buttonR "Test")+++-- Data that:+-- Can be used to create some GUI (in UI)+-- May vary depending on user input (in UI)+data R a = R {+ getR :: Element -> UI (Event a)+ }+buttonR :: String -> R ()+buttonR t = R $ \p -> do+ e <- set text t $ button+ return p #+ [return e]+ return $ fmap (const ()) $ click e+++-- rowR :: [R a] -> R a+-- rowR rs = R (\e -> fmap (($ e) . getR) rs)++runR :: Show a => R a -> Window -> UI ()+runR (R r) window = do+ p <- getBody window+ e <- r p+ stop <- liftIO $ register e print+ -- stop is never called+ return ()+ ++++++++++++setup :: Window -> UI ()+setup window = do + body <- getBody window++ presets <- select+ return presets #+ [option # set text "Foo", option # set text "Bar"]+ input <- textarea # set text "" # set rows "20" # set cols "80"+ button <- button # set text "Compile"+ result1 <- pre+ (accumB "|" $ fmap (const (\x -> x ++ "|")) $ valueChange input) >>= \presetB ->+ sink text presetB $ return result1++ return body #+ [column [+ return presets,+ return input, + return button,+ return result1+ ]] + return ()
+ examples/tuplet.hs view
@@ -0,0 +1,39 @@++{-# LANGUAGE OverloadedStrings #-}++module Main where++import Prelude+import System.Process (runCommand)+import Music.Prelude.Basic++main = do+ -- writeMidi "test.mid" music+ -- writeXml "test.xml" $ music^/4+ -- openXml music+ openLilypond music+ -- playMidiIO "Graphic MIDI" $ music^/10+++-- infixr 7 //+-- (//) = flip times++music :: Score BasicNote+music = {-fadeIn 1 $-} {-fadeOut 1 $-} rcat $ map test [1..5]++test 1 = group 5 g |> g^*3 +test 2 = group 3 fs |> fs^*3 +test 3 = group 3 f |> group 5 f |> group 3 f |> group 7 f+test 4 = group 3 e |> group 5 e |> c |> group 7 e+test 5 = ds |> group 5 ds |> ds |> group 7 ds+-- all above ok+++test 8 = times 5 d^/5 |> times 3 d^/3 -- ok+test 9 = times 4 cs^/5 |> cs^*(1/5+1/3) -- not ok, needs to be bound from last quintuplet note++test 99 = group 5 c |> group 3 c |> c^*2++++group n = times n^/(fromIntegral n)
music-preludes.cabal view
@@ -1,6 +1,6 @@ name: music-preludes-version: 1.7+version: 1.7.1 author: Hans Hoglund maintainer: Hans Hoglund license: BSD3@@ -16,19 +16,24 @@ . This library is part of the Music Suite, see <http://music-suite.github.io>. +extra-source-files: README.md,+ examples/*.hs,+ examples/*.scm,+ examples/*.music+ source-repository head type: git location: git://github.com/music-suite/music-preludes.git library build-depends: base >= 4 && < 5,- lens >= 4.1.2 && < 4.2,+ aeson >= 0.7.0.6 && < 1,+ lens >= 4.3 && < 4.4, split,- unix, containers,- vector-space,- vector-space-points,- process,+ vector-space >= 0.8.7 && < 0.9,+ vector-space-points >= 0.2 && < 0.3,+ process >= 1.2 && < 1.3, filepath >= 1.3 && < 2, temporary >= 1.1 && < 2, optparse-applicative >= 0.8 && < 1,@@ -36,23 +41,24 @@ data-default, monadplus, reverse-apply,- lilypond == 1.7,- musicxml2 == 1.7,- music-score == 1.7,- music-pitch == 1.7,- music-dynamics == 1.7,- music-parts == 1.7,- music-pitch-literal == 1.7,- music-dynamics-literal == 1.7,+ lilypond == 1.7.1,+ musicxml2 == 1.7.1,+ music-score == 1.7.1,+ music-pitch == 1.7.1,+ music-dynamics == 1.7.1,+ music-parts == 1.7.1,+ music-pitch-literal == 1.7.1,+ music-dynamics-literal == 1.7.1, -- For examples: async+ if !os(windows)+ build-depends: unix exposed-modules: Music.Prelude Music.Prelude.Basic Music.Prelude.Standard- -- Music.Prelude.Piano- -- Music.Prelude.StringQuartet Music.Prelude.CmdLine Music.Prelude.Instances+ other-modules: Paths_music_preludes hs-source-dirs: src default-language: Haskell2010
src/Music/Prelude/CmdLine.hs view
@@ -1,8 +1,14 @@ +{-# LANGUAGE CPP #-}+ module Music.Prelude.CmdLine ( converterMain,- translateFileAndRunLilypond,+ lilypondConverterMain,+ translateFile,+ translateFileAndRunLilypond,++ version, versionString ) where @@ -10,9 +16,9 @@ import Data.Version (showVersion) import Data.Monoid import Options.Applicative--- import Paths_music_preludes (version)+import Paths_music_preludes (version) import Data.Char-import Data.List (intercalate)+import Data.List (intercalate, isPrefixOf) import Data.List.Split import Data.Map (Map) import qualified Data.Map as Map@@ -24,42 +30,82 @@ import System.FilePath import System.IO import System.IO.Temp+#ifndef mingw32_HOST_OS import qualified System.Posix.Env as PE+#endif import System.Process --- TODO Can not link due to haskell/cabal#1759+import qualified Music.Prelude.Basic as PreludeBasic+import qualified Music.Prelude.Standard as PreludeStandard++-- Note that Paths_music_preludes must be in other-modules for executables+-- See haskell/cabal#1759 versionString :: String-versionString = "1.7"--- versionString = showVersion version+versionString = showVersion version -data Options = Options {++data ConverterOptions = ConverterOptions { prelude :: Maybe String, outFile :: Maybe FilePath, inFile :: FilePath } deriving (Show) -converterOptions :: Parser Options-converterOptions = Options- <$> (optional $ strOption $ mconcat [long "prelude", metavar "<name>"])- <*> (optional $ strOption $ mconcat [short 'o', long "output", metavar "<file>"])- <*> (argument str $ metavar "<input>")--runConverter :: String -> String -> Options -> IO ()-runConverter func ext (Options prelude outFile inFile) =- translateFile func ext prelude (Just inFile) outFile+converterOptions :: Parser ConverterOptions+converterOptions = liftA3 ConverterOptions+ (optional $ strOption $ mconcat [long "prelude", metavar "<name>"])+ (optional $ strOption $ mconcat [short 'o', long "output", metavar "<file>"])+ (argument str $ metavar "<input>") +-- A basic converter program+-- Used for music2ly, music2musicxml et al converterMain :: String -> String -> IO ()-converterMain func ext = getProgName >>= converterMain' func ext+converterMain func ext = do + pgmName <- getProgName+ options <- execParser (opts pgmName)+ runConverter func ext options+ where + opts pgmName = info + (helper <*> converterOptions) + (fullDesc <> header (pgmName ++ "-" ++ versionString))+ runConverter func ext (ConverterOptions prelude outFile inFile) + = translateFile func ext prelude (Just inFile) outFile -converterMain' :: String -> String -> String -> IO ()-converterMain' func ext pgmName = execParser opts >>= runConverter func ext+++-- A converter program that invokes Lilypond+-- Used for music2pdf, music2svg et al+data LilypondConverterOptions = LilypondConverterOptions {+ _prelude :: Maybe String,+ _inFile :: FilePath+ } deriving (Show)++lilypondConverterOptions :: Parser LilypondConverterOptions+lilypondConverterOptions = liftA2 LilypondConverterOptions+ (optional $ strOption $ mconcat [long "prelude", metavar "<name>"])+ (argument str $ metavar "<input>")++-- A converter program+-- Used for music2ly, music2musicxml et al+lilypondConverterMain :: String -> IO ()+lilypondConverterMain ext = do + pgmName <- getProgName+ options <- execParser (opts pgmName)+ runLilypondConverter ext options where - opts = info - (helper <*> converterOptions) - (fullDesc <> header (pgmName ++ "-" ++ versionString))+ opts pgmName = info + (helper <*> lilypondConverterOptions) + (fullDesc <> header (pgmName ++ "-" ++ versionString))+ runLilypondConverter ext (LilypondConverterOptions prelude inFile) + = translateFileAndRunLilypond ext prelude (Just inFile) -translateFileAndRunLilypond :: String -> Maybe String -> Maybe FilePath -> IO ()+++translateFileAndRunLilypond + :: String -- ^ Output file suffix/format passed to Lilypond.+ -> Maybe String -- ^ Prelude to use.+ -> Maybe FilePath -- ^ Input file. + -> IO () translateFileAndRunLilypond format preludeName' inFile' = do let inFile = fromMaybe "test.music" inFile' let preludeName = fromMaybe "basic" preludeName'@@ -70,7 +116,13 @@ runCommand $ "rm -f " ++ takeBaseName inFile ++ "-*.tex " ++ takeBaseName inFile ++ "-*.texi " ++ takeBaseName inFile ++ "-*.count " ++ takeBaseName inFile ++ "-*.eps " ++ takeBaseName inFile ++ "-*.pdf " ++ takeBaseName inFile ++ ".eps" return () -translateFile :: String -> String -> Maybe String -> Maybe FilePath -> Maybe FilePath -> IO ()+translateFile + :: String -- ^ Translate function (of type @'FilePath' -> music -> 'IO' ()@).+ -> String -- ^ Output file suffix.+ -> Maybe String -- ^ Prelude to use.+ -> Maybe FilePath -- ^ Input file.+ -> Maybe FilePath -- ^ Output file.+ -> IO () translateFile translationFunction outSuffix preludeName' inFile' outFile' = do let inFile = fromMaybe "test.music" inFile' let preludeName = fromMaybe "basic" preludeName'@@ -83,15 +135,23 @@ let prelude = "Music.Prelude." ++ toCamel preludeName let scoreType = "Score " ++ toCamel preludeName ++ "Note" let main = translationFunction- score <- readFile inFile- newScore <- return $ expand templ (Map.fromList [- ("prelude" , prelude),- ("main" , main),- ("scoreType" , scoreType),- ("score" , score),- ("outFile" , outFile)- ])-+ code <- readFile inFile+ newScore <- return $ if isNotExpression code + then expand declTempl (Map.fromList [+ ("prelude" , prelude),+ ("main" , main),+ ("scoreType" , scoreType),+ ("code" , code),+ ("outFile" , outFile)+ ])+ else expand exprTempl (Map.fromList [+ ("prelude" , prelude),+ ("main" , main),+ ("scoreType" , scoreType),+ ("score" , code),+ ("outFile" , outFile)+ ])+ -- putStrLn newScore withSystemTempDirectory "music-suite." $ \tmpDir -> do let tmpFile = tmpDir ++ "/" ++ takeFileName inFile let opts = ["-XOverloadedStrings", "-XNoMonomorphismRestriction", "-XTypeFamilies"]@@ -103,9 +163,37 @@ return () where- templ = "module Main where { import $(prelude); main = $(main) \"$(outFile)\" ( $(score) :: $(scoreType) ) }"+ exprTempl = "module Main where { import $(prelude); main = $(main) \"$(outFile)\" ( $(score) :: $(scoreType) ) }"+ declTempl = "module Main where \nimport $(prelude) \n$(code) \nmain = $(main) \"$(outFile)\" ( example :: $(scoreType) )" +-- TODO hackish, preferably parse using haskell-src-exts or similar+isNotExpression :: String -> Bool+isNotExpression t = anyLineStartsWith "type" t || anyLineStartsWith "data" t || anyLineStartsWith "example =" t ++++++++++++++-- |+-- >>> anyLineStartsWith "h" "ahc"+-- False+-- >>> anyLineStartsWith "h" "a\nhc"+-- True+-- >>> anyLineStartsWith "h" "hac"+--+anyLineStartsWith :: String -> String -> Bool+anyLineStartsWith t = any (t `isPrefixOf`) . lines++ type Template = String -- |@@ -129,25 +217,38 @@ toCamel [] = [] toCamel (x:xs) = toUpper x : xs ++-- |+-- Wrap IO actions that invoke 'ghc', 'ghci' or 'runhaskell' using this+-- to assure that invocations will work when using a development version of+-- the suite (i.e. the Music packages are in a sandbox).+--+-- Does nothing on Windows, as we can not reliably implement withEnv for that+-- platform current HP release (needs base 4.7).+--+withMusicSuiteInScope :: IO a -> IO a+withMusicSuiteInScope k = do+ r <- try $ readProcess "music-util" ["package-path"] ""+ case r of+ Left x -> let _ = (x::SomeException) in withEnv "GHC_PACKAGE_PATH" (const "") k+ Right packagePath -> withEnv "GHC_PACKAGE_PATH" (const packagePath) k+ -- | Temporarily modfiy an environment variable (POSIX only). -- -- @--- withEnv MYVAR (\oldValue -> newValue) $ do+-- withEnv varName (\oldValueIfPresent -> newValue) $ do -- ... -- @ -- withEnv :: String -> (Maybe String -> String) -> IO a -> IO a+#ifdef mingw32_HOST_OS+withEnv _ _ = id+#else withEnv n f k = do x <- PE.getEnv n PE.setEnv n (f x) True res <- k case x of Nothing -> PE.unsetEnv n >> return res- Just x2 -> PE.setEnv n x2 True >> return res--withMusicSuiteInScope :: IO a -> IO a-withMusicSuiteInScope k = do- r <- try $ readProcess "music-util" ["package-path"] ""- case r of- Left x -> let _ = (x::SomeException) in withEnv "GHC_PACKAGE_PATH" (const "") k- Right packagePath -> withEnv "GHC_PACKAGE_PATH" (const packagePath) k+ Just x2 -> PE.setEnv n x2 True >> return res +#endif
src/Music/Prelude/Instances.hs view
@@ -18,7 +18,7 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) ----- A basic music representation.+-- Provides orphan instances that does not fit into other packages. -- -------------------------------------------------------------------------------------
src/Music/Prelude/Standard.hs view
@@ -22,7 +22,7 @@ module Music.Pitch, module Music.Dynamics, module Music.Parts,- Note,+ StandardNote, asScore, asVoice, asTrack,@@ -43,16 +43,16 @@ import Music.Prelude.Instances () -asNote :: Note -> Note+asNote :: StandardNote -> StandardNote asNote = id -asScore :: Score Note -> Score Note+asScore :: Score StandardNote -> Score StandardNote asScore = id -asVoice :: Voice Note -> Voice Note+asVoice :: Voice StandardNote -> Voice StandardNote asVoice = id -asTrack :: Track Note -> Track Note+asTrack :: Track StandardNote -> Track StandardNote asTrack = id -- newtype BasicPart = BasicPart { getBasicPart :: Integer }@@ -62,17 +62,17 @@ -- instance Show BasicPart where -- show _ = "" -type Note = +type StandardNote = (PartT Part- (TieT- (ColorT - (TextT- (TremoloT- (HarmonicT- (SlideT- (ArticulationT (Sum Double, Sum Double)- (DynamicT (Sum Double)- [Behavior StandardPitch])))))))))+ (ColorT + (TextT+ (TremoloT+ (HarmonicT+ (SlideT+ (ArticulationT (Sum Double, Sum Double)+ (DynamicT (Average Double)+ [TieT+ (Behavior StandardPitch)])))))))) type StandardPitch = Music.Pitch.Pitch -- data StandardPitch = StandardPitch Music.Pitch.Pitch
tests/tests.hs view
@@ -24,9 +24,20 @@ (name ++ "." ++ ext) ("tests/golden/" ++ name ++ "." ++ ext) ("tests/current/" ++ name ++ "." ++ ext)- ((system $ converter ext ++" -o tests/current/"++name++"."++ext++" tests/"++name++".music") + (convertFile ext name)++convertFile + :: String -- ^ Extension+ -> FilePath -- ^ Name+ -> IO ()+convertFile ext name =+ ((mySystem $ converter ext ++" -o tests/current/"++name++"."++ext++" tests/"++name++".music") >>= \e -> if e == ExitSuccess then return () else fail ("Could not convert "++name++".music")) +mySystem str = do+ (_,_,_,p) <- createProcess $ (shell str) { delegate_ctlc = False }+ waitForProcess p + {- This test will always fail if the test files have been edited. @@ -34,9 +45,9 @@ your changes permanent, please assure that you are in a clean working directory (except for your edits), and then run: - $ make generate+ $ make -f tests/Makefile generate - You should commit all the resulting files along with your edits.+ You should commit all the resulting files (in tests/golden) along with your edits. -} sanity = testGroup "Sanity checks" [ testMusicFilesCheckSum,@@ -63,6 +74,7 @@ testMusicFile "articulation_legato", testMusicFile "articulation_portato", testMusicFile "articulation_staccato",+ testMusicFile "decl_style1", testMusicFile "dynamics_constant", testMusicFile "melody_chords", testMusicFile "meta_annotations",
tools/music2ly.hs view
tools/music2pdf.hs view
@@ -1,14 +1,6 @@ module Main where -import Music.Prelude.CmdLine-import System.Environment---- TODO-main = do- args <- getArgs- main2 args+import Music.Prelude.CmdLine -main2 args = do- [inFile] <- return args- translateFileAndRunLilypond "pdf" (Just "basic") (Just inFile)+main = lilypondConverterMain "pdf"
tools/music2png.hs view
@@ -1,14 +1,7 @@ module Main where -import Music.Prelude.CmdLine-import System.Environment+import Music.Prelude.CmdLine --- TODO-main = do- args <- getArgs- main2 args+main = lilypondConverterMain "png" -main2 args = do- [inFile] <- return args- translateFileAndRunLilypond "png" (Just "basic") (Just inFile)
tools/music2svg.hs view
@@ -1,14 +1,7 @@ module Main where -import Music.Prelude.CmdLine-import System.Environment+import Music.Prelude.CmdLine --- TODO-main = do- args <- getArgs- main2 args+main = lilypondConverterMain "svg" -main2 args = do- [inFile] <- return args- translateFileAndRunLilypond "svg" (Just "basic") (Just inFile)