diff --git a/examples/analysis.hs b/examples/analysis.hs --- a/examples/analysis.hs +++ b/examples/analysis.hs @@ -17,9 +17,12 @@ markImperfect = text "Imperfect consonances" . markIf isImperfectConsonance markDiss = text "Dissonances" . markIf isDissonance +-- Try different subjects +subject = [c..c'] +-- subject = [c,d,cs,gs,f,fs,g_,gs_,fs,f,e,ds',c] -main = openLilypond $ asScore $ rcat [ - markPerfect $ scat [c..c'], - markImperfect $ scat [c..c'], - markDiss $ scat [c..c'] +main = openLilypond $ asScore $ rcat [ + markPerfect $ scat subject, + markImperfect $ scat subject, + markDiss $ scat subject ] diff --git a/examples/annotatations.hs b/examples/annotatations.hs --- a/examples/annotatations.hs +++ b/examples/annotatations.hs @@ -14,13 +14,13 @@ . intervalAnnotations subjectDiff . scat $ map (fromPitch'.pure) subject -subject :: [BasicPitch] +subject :: [Pitch] subject = [c, d, f, e, f, g, a, g, e, d, c] subjectDiff :: [Interval] subjectDiff = zipWith (.-.) (tail subject) subject --- reify :: BasicPitch -> Score BasicNote +-- reify :: Pitch -> Score BasicNote -- reify = (`up` c) . pure . (.-. c) intervalAnnotations :: [Interval] -> (Score BasicNote -> Score BasicNote) diff --git a/examples/bartok.hs b/examples/bartok.hs --- a/examples/bartok.hs +++ b/examples/bartok.hs @@ -25,14 +25,14 @@ 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) + (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) + (scat [g,f,e,d] |> c |> (d |> e)^/2 |> f |> e |> d^*8) - in meta $ compress 8 $ left down _P8 right + in meta $ compress 8 $ left down _P8 right diff --git a/examples/behavior.hs b/examples/behavior.hs new file mode 100644 --- /dev/null +++ b/examples/behavior.hs @@ -0,0 +1,10 @@ + +import Music.Prelude + +toPitch :: Double -> Pitch +toPitch x = c .+^ si x + where + si t = spell usingSharps $ (floor t :: Semitones) + +main = open music +music = set pitches' (stretch 12 $ fmap toPitch $ sine * 7) $ times 24 c diff --git a/examples/canon.hs b/examples/canon.hs --- a/examples/canon.hs +++ b/examples/canon.hs @@ -1,3 +1,4 @@ + {-# LANGUAGE OverloadedStrings #-} {- diff --git a/examples/canon.music b/examples/canon.music --- a/examples/canon.music +++ b/examples/canon.music @@ -9,7 +9,7 @@ frere2 = delay 2 frere frere frere4 = delay 4 frere2 frere2 - info = {-title "Frere Jaques" . -}composer "Trad." . tempo (metronome (1/4) 120) + info = title "Frere Jaques" . composer "Trad." . tempo (metronome (1/4) 120) in info $ asScore $ frere4 diff --git a/examples/chords.hs b/examples/chords.hs --- a/examples/chords.hs +++ b/examples/chords.hs @@ -7,12 +7,12 @@ import Control.Applicative import System.Process (system) -kStrum = 0.03 +-- kStrum = 0.005 +kStrum = 0 main = do - -- openLilypond (music^/4) + openLilypond music -- openMidi music - openAudacity music guitar = (tutti $ StdInstrument 26) alto = (tutti $ StdInstrument 65) @@ -20,40 +20,73 @@ -- Strum a chord -strum :: [Score a] -> Score a -strum = pcat . zipWith (\t x -> delay t . stretchTo (x^.duration ^-^ t) $ x) [0,kStrum..] +-- TODO port this to Chord module +strumUp :: [Score a] -> Score a +strumUp = pcat . zipWith (\t x -> delay t . stretchTo (x^.duration ^-^ t) $ x) [0,kStrum..] +strumDown = strumUp . reverse + +data StrumDirection = Up | Down deriving (Eq, Ord, Show, Enum) + +nextDirection :: StrumDirection -> StrumDirection +nextDirection Up = Down +nextDirection Down = Up + +-- 21212 + +strumRhythm + :: StrumDirection -- ^ Initial direction + -> [Duration] -- ^ Duration pattern (repeated if necessary) + -> [[Score a]] -- ^ Sequence of chords to strum + -> Score a +strumRhythm startDirection durations' values = scat chords + where + directions = iterate nextDirection startDirection + durations = cycle durations' + chords = zipWith3 (\dir dur chord -> case dir of + Up -> strumUp (stretch dur chord) + Down -> strumDown (stretch dur chord) + ) directions durations values + + +strum x = strumRhythm Up (map (/8) [2,1,2,1,2]) + [x,dropLast 1 x,level _p $ drop 1 x,level _p $ dropLast 1 x, level _p $ drop 1 x] + where + dropLast n = reverse . drop n . reverse + + 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 $ +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) $  +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]) +music = scat [music1, music2] +music1 = asScore $ mempty + -- <> (level mf $ set parts' guitar $ melody) + -- <> level _p strings + <> level mp counterRh + <> gtr +music2 = asScore $ mempty + <> (level mf $ melody) + <> level _p strings + <> level _p counterRh + <> gtr + +gtr = set parts' guitar $ + (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_,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 [c_,e_,g_,c,e,g]) |> - (pcat $ take 4 $ zipWith delay [0,1..10] $ repeat $ strum [g_,a_,c,f,a,c']) + (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" diff --git a/examples/duo.hs b/examples/duo.hs --- a/examples/duo.hs +++ b/examples/duo.hs @@ -18,7 +18,7 @@ -- 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) +toLydian = pitches' %~ (\p -> if ((p::Behavior Pitch) ! 0) == ((c::Behavior Pitch) ! 0) then cs else p) -- TODO cleanup subj1 = (^/2) $ diff --git a/examples/part.hs b/examples/part.hs --- a/examples/part.hs +++ b/examples/part.hs @@ -13,13 +13,14 @@ 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 :: Score StandardNote music = meta $ stretch (3/2) $ {-before 60-} (mempty <> bell <> delay 6 strings) where meta = id @@ -44,19 +45,19 @@ tintin' :: Interval -> Interval tintin' melInterval | isNegative melInterval = error "tintin: Negative interval" - | otherwise = last $ takeWhile (< melInterval) $ tintinNotes + | otherwise = last $ takeWhile (< melInterval) $ tintinStandardNotes where - tintinNotes = concat $ iterate (fmap (+ _P8)) minorTriad + tintinStandardNotes = concat $ iterate (fmap (+ _P8)) minorTriad minorTriad = [_P1,m3,_P5] -bell :: Score Note +bell :: Score StandardNote bell = let - cue :: Score (Maybe Note) + cue :: Score (Maybe StandardNote) 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 :: Score StandardNote strings = strings_vln1 <> strings_vln2 <> strings_vla <> strings_vc <> strings_db strings_vln1 = clef GClef $ parts' .~ (ensemble !! 1) $ up (_P8^*1) $ strings_cue @@ -66,13 +67,13 @@ 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 :: [Score StandardNote] fallingScale = [a',g'..a_] -fallingScaleSect :: Int -> [Score Note] +fallingScaleSect :: Int -> [Score StandardNote] fallingScaleSect n = {-fmap (annotate (show n)) $-} take n $ fallingScale -mainSubject :: Score Note +mainSubject :: Score StandardNote mainSubject = stretch (1/6) $ asScore $ scat $ mapEvensOdds (accent . (^*2)) id $ concatMap fallingScaleSect [1..30] @@ -99,19 +100,19 @@ in take (length xs) $ map f evens `merge` map g odds -openAudacity :: Score Note -> IO () +openAudacity :: Score StandardNote -> 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 :: Score StandardNote -> 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 :: Score StandardNote -> Score StandardNote fixClefs = id -- fixClefs = pcat . fmap (uncurry g) . extractParts' -- where @@ -123,7 +124,7 @@ 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 () +play, open, openAndPlay :: Score StandardNote -> IO () tempo_ = 120 play x = openAudio $ stretch ((60*4)/tempo_) $ fixClefs $ x open x = openLilypond' LyScoreFormat $ fixClefs $ x diff --git a/examples/scheme.hs b/examples/scheme.hs --- a/examples/scheme.hs +++ b/examples/scheme.hs @@ -8,7 +8,7 @@ {- Basic Scheme bindings - For examples, see test1.scm (TODO write more) + See Scheme files in example directory Requires husk-scheme to be in your path http://hackage.haskell.org/package/husk-scheme @@ -20,13 +20,15 @@ import qualified Data.Map as Map import Data.Maybe import Data.Traversable +import Data.Colour (Colour(..)) 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 System.Environment +import qualified System.IO.Unsafe -- import qualified Data.List -- import System.Random @@ -36,7 +38,7 @@ (.-.) = (-) (.+^) = (+) -lispApi = [ +musicSuiteApi = [ ("c", toLisp (c :: LispScore)), ("d", toLisp (d :: LispScore)), ("e", toLisp (e :: LispScore)), @@ -45,13 +47,13 @@ ("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)), + ("cs", toLisp (cs :: LispScore)), + ("ds", toLisp (ds :: LispScore)), + ("es", toLisp (es :: LispScore)), + ("fs", toLisp (fs :: LispScore)), + ("gs", toLisp (gs :: LispScore)), + ("as", toLisp (as :: LispScore)), + ("bs", toLisp (bs :: LispScore)), ("cb", toLisp (cb :: LispScore)), ("db", toLisp (db :: LispScore)), @@ -61,9 +63,20 @@ ("ab", toLisp (ab :: LispScore)), ("bb", toLisp (bb :: LispScore)), + -- TODO does not work well with Integer + -- ("red", toLisp ("red" :: String)), + -- ("blue", toLisp ("blue" :: String)), + -- ("black", toLisp ("black" :: String)), + -- ("color", CustFunc $ lift2 ((\x -> case x of { "red" -> colorRed ; "black" -> colorBlack }) :: String -> LispScore -> LispScore)), + + -- TODO does not work well with Integer + -- ("accent", CustFunc $ lift1 (accent :: LispScore -> LispScore)), + + ("m3", toLisp (m3 :: Integer)), ("M3", toLisp (_M3 :: Integer)), ("up", CustFunc $ lift2 (up :: Integer -> LispScore -> LispScore)), + ("down", CustFunc $ lift2 (up :: Integer -> LispScore -> LispScore)), -- ("ff", toLisp (fff :: Sum Double)), -- ("level", CustFunc $ lift2 (up :: Sum Double -> LispScore -> LispScore)), @@ -88,18 +101,29 @@ -main = do +main = do + args <- System.Environment.getArgs + files <- case args of + [] -> do + putStrLn "Usage: runhaskell scheme.hs file..." + fail mempty + xs -> return args stdEnv <- r5rsEnv - env <- extendEnv stdEnv (map (over _1 (varNamespace,)) $ lispApi) - code <- readFile "examples/test1.scm" - res <- evalLisp' env $ fromRight $ readExpr code + env <- extendEnv stdEnv (map (over _1 (varNamespace,)) $ musicSuiteApi) + code <- readFile (head files) + -- TODO handle error here + res <- evalLisp' env $ readExprErrorFail $ 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 + openLilypond $ fmap (\x -> PartT(mempty::Part,TieT(mempty,ArticulationT(mempty::Articulation,DynamicT(mempty::Sum Double,[x]))))) $ sc return () printScore = mapM_ print . view notes +readExprErrorFail (Right x) = x +readExprErrorFail _ = error "Could not read scheme expression" + fromRight (Right x) = x +fromRight _ = error "Unknown error" class HasLisp a where @@ -116,6 +140,11 @@ Bool x -> Just x _ -> Nothing +instance HasLisp Char where + _unlisp = prism' (Char) $ \x -> case x of + Char x -> Just x + _ -> Nothing + instance HasLisp Int where _unlisp = prism' (Number . toInteger) $ \x -> case x of Number x -> Just (fromInteger x) @@ -209,7 +238,7 @@ toMap k v = Map.insert k v mempty retR :: a -> IORef a - retR = unsafePerformIO . newIORef + retR = System.IO.Unsafe.unsafePerformIO . newIORef -} diff --git a/examples/test1.scm b/examples/test1.scm --- a/examples/test1.scm +++ b/examples/test1.scm @@ -1,3 +1,6 @@ + +; Usage: +; runhaskell examples/scheme.hs examples/test1.scm (let ((first-note-duration 5/3) (second-note-duration 2) (foo (lambda (x) x))) diff --git a/examples/test2.scm b/examples/test2.scm new file mode 100644 --- /dev/null +++ b/examples/test2.scm @@ -0,0 +1,12 @@ + +; Usage: +; runhaskell examples/scheme.hs examples/test2.scm +(let ( + (cell1 (compress 16 (scat c cs e))) + (cell2 (compress 16 (scat fs f e))) + ) + + ; TODO variadic + (define (seq i x y) (scat x (up i y))) + + (seq m3 (scat cell1 cell2) (scat cell2 cell1))) diff --git a/examples/time_signatures.hs b/examples/time_signatures.hs --- a/examples/time_signatures.hs +++ b/examples/time_signatures.hs @@ -6,11 +6,14 @@ main = open music music = id + $ title "Time signatures" - $ fmap (over dynamics (! 0)) - -- $ timeSignature (2/4) - -- $ timeSignature (3/4) + + -- Try commenting out some of these lines $ timeSignature (6/8) - -- $ timeSignature ((4+3)/8) - $ level (ff*stretch (2*14/8) sine) + $ timeSignature (3/4) + $ timeSignature (2/4) + $ timeSignature ((4+3)/8) + $ timeSignature ((3+4)/8) + $ scat [c,c',b,bb,a,as,g^*2,scat [f,e,d,b_]^/2,d^*2,c^*2]^/8 diff --git a/examples/trio.hs b/examples/trio.hs --- a/examples/trio.hs +++ b/examples/trio.hs @@ -18,7 +18,7 @@ vla = tutti viola vc = tutti cello -music :: Score Note +music :: Score StandardNote music = mainCanon2 tremCanon = compress 4 $ @@ -30,12 +30,12 @@ <> (delay 0 $ set parts' vc $ subjs^*2) where - subjs = scat $ map (\n -> palindrome $ rev2 $ subj n) [1..40] + subjs = scat $ map (\n -> palindrome $ rev2 $ subj n) [1..40::Int] 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 + | otherwise = e^*0.5 |> a^*0.5 mainCanon2 = palindrome mainCanon <> celloEntry @@ -55,7 +55,7 @@ <> set parts' vc a'^*(25*5/8) - + @@ -94,20 +94,20 @@ in take (length xs) $ map f evens `merge` map g odds -openAudacity :: Score Note -> IO () +openAudacity :: Score StandardNote -> 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 :: Score StandardNote -> 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' +fixClefs :: Score StandardNote -> Score StandardNote +fixClefs = pcat . fmap (uncurry g) . extractPartsWithInfo where g p x = clef (case defaultClef p of { 0 -> GClef; 1 -> CClef; 2 -> FClef } ) x @@ -127,7 +127,7 @@ main :: IO () main = open music -play, open, openAndPlay :: Score Note -> IO () +play, open, openAndPlay :: Score StandardNote -> IO () tempo_ = 130 play x = openAudio $ stretch ((60*(8/3))/tempo_) $ fixClefs $ x open x = openLilypond' LyScoreFormat $ fixClefs $ x diff --git a/music-preludes.cabal b/music-preludes.cabal --- a/music-preludes.cabal +++ b/music-preludes.cabal @@ -1,6 +1,6 @@ name: music-preludes -version: 1.7.1 +version: 1.7.2 author: Hans Hoglund maintainer: Hans Hoglund license: BSD3 @@ -28,7 +28,7 @@ library build-depends: base >= 4 && < 5, aeson >= 0.7.0.6 && < 1, - lens >= 4.3 && < 4.4, + lens >= 4.3.3 && < 4.4, split, containers, vector-space >= 0.8.7 && < 0.9, @@ -37,18 +37,20 @@ filepath >= 1.3 && < 2, temporary >= 1.1 && < 2, optparse-applicative >= 0.8 && < 1, + average >= 0.6 && < 1, semigroups >= 0.13.0.1 && < 1, data-default, monadplus, reverse-apply, - 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, + lilypond == 1.7.2, + musicxml2 == 1.7.2, + music-score == 1.7.2, + music-pitch == 1.7.2, + music-dynamics == 1.7.2, + music-articulation == 1.7.2, + music-parts == 1.7.2, + music-pitch-literal == 1.7.2, + music-dynamics-literal == 1.7.2, -- For examples: async if !os(windows) diff --git a/src/Music/Prelude/Basic.hs b/src/Music/Prelude/Basic.hs --- a/src/Music/Prelude/Basic.hs +++ b/src/Music/Prelude/Basic.hs @@ -18,14 +18,15 @@ ------------------------------------------------------------------------------------- module Music.Prelude.Basic ( - module Music.Score, module Music.Pitch, module Music.Dynamics, + module Music.Articulation, module Music.Parts, + module Music.Score, module Control.Monad.Plus, module Control.Lens.Operators, BasicNote, - BasicPitch, + -- BasicPitch, asScore, asVoice, asTrack, @@ -38,18 +39,15 @@ import Data.Default import Data.Typeable +import Music.Pitch hiding (Fifths, Note) +import qualified Music.Pitch import Music.Dynamics +import Music.Articulation import Music.Parts hiding (Part) -import Music.Pitch hiding (Fifths, Note, Part, - pitch) --- Need to export Pitch.Pitch for transf for now - -import qualified Music.Pitch -import Music.Score hiding (Pitch, Interval) +import Music.Score hiding (Pitch, Dynamics, Articulation, Interval) import Control.Lens.Operators hiding ((<.>), (<|), (|>)) import Control.Monad.Plus -import Data.Semigroup (Product) import Music.Prelude.Instances () @@ -71,11 +69,13 @@ (SlideT (TremoloT (HarmonicT - (ArticulationT (Sum Double, Sum Double) - (DynamicT (Sum Double) - [Behavior BasicPitch])))))))) + (ArticulationT Articulation + (DynamicT Dynamics + [Behavior Pitch])))))))) -type BasicPitch = Music.Pitch.Pitch +-- type BasicDynamics = Music.Dynamics.Dynamics +-- type BasicArticulation = Music.Articulation.Articulation +-- type BasicPitch = Music.Pitch.Pitch open = openLilypond . asScore play = error "Not implemented: play" diff --git a/src/Music/Prelude/CmdLine.hs b/src/Music/Prelude/CmdLine.hs --- a/src/Music/Prelude/CmdLine.hs +++ b/src/Music/Prelude/CmdLine.hs @@ -1,6 +1,21 @@ {-# LANGUAGE CPP #-} +------------------------------------------------------------------------------------ +-- | +-- Copyright : (c) Hans Hoglund 2012 +-- +-- License : BSD-style +-- +-- Maintainer : hans@hanshoglund.se +-- Stability : experimental +-- Portability : non-portable (TF,GNTD) +-- +-- Provides framework for building simple command-line converter programs such as +-- @music2midi@, @music2pdf@ etc. +-- +------------------------------------------------------------------------------------- + module Music.Prelude.CmdLine ( converterMain, lilypondConverterMain, @@ -16,7 +31,9 @@ import Data.Version (showVersion) import Data.Monoid import Options.Applicative -import Paths_music_preludes (version) +#ifndef GHCI +import qualified Paths_music_preludes as Paths +#endif import Data.Char import Data.List (intercalate, isPrefixOf) import Data.List.Split @@ -24,7 +41,6 @@ import qualified Data.Map as Map import Data.Maybe import Prelude hiding (readFile, writeFile) --- import System.Console.GetOpt import System.Environment import System.Exit import System.FilePath @@ -38,10 +54,18 @@ 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 +-- | Current Music Suite version. +#ifndef GHCI +version = Paths.version +#else +version = undefined +#endif + +-- | Current Music Suite version as a string. versionString :: String versionString = showVersion version +-- Note that Paths_music_preludes must be in other-modules for executables +-- See haskell/cabal#1759 data ConverterOptions = ConverterOptions { @@ -56,9 +80,13 @@ (optional $ strOption $ mconcat [short 'o', long "output", metavar ""]) (argument str $ metavar "") --- A basic converter program --- Used for music2ly, music2musicxml et al -converterMain :: String -> String -> IO () +-- | +-- Generates a basic converter program such as @music2ly@, @music2musicxml@ etc. +-- +converterMain + :: String -- ^ Name of converter function. + -> String -- ^ Extension of generated file. + -> IO () converterMain func ext = do pgmName <- getProgName options <- execParser (opts pgmName) @@ -84,9 +112,13 @@ (optional $ strOption $ mconcat [long "prelude", metavar ""]) (argument str $ metavar "") --- A converter program --- Used for music2ly, music2musicxml et al -lilypondConverterMain :: String -> IO () +-- | +-- Generates a basic converter program that invokes @lilypond@ to generate +-- music notation. Used for @music2pdf@ etc. +-- +lilypondConverterMain + :: String -- ^ A file extension (supported by Lilypond). + -> IO () lilypondConverterMain ext = do pgmName <- getProgName options <- execParser (opts pgmName) @@ -99,8 +131,9 @@ = translateFileAndRunLilypond ext prelude (Just inFile) - - +-- | +-- Translate an input file and invoke Lilypond on the resulting output file. +-- translateFileAndRunLilypond :: String -- ^ Output file suffix/format passed to Lilypond. -> Maybe String -- ^ Prelude to use. @@ -116,6 +149,9 @@ runCommand $ "rm -f " ++ takeBaseName inFile ++ "-*.tex " ++ takeBaseName inFile ++ "-*.texi " ++ takeBaseName inFile ++ "-*.count " ++ takeBaseName inFile ++ "-*.eps " ++ takeBaseName inFile ++ "-*.pdf " ++ takeBaseName inFile ++ ".eps" return () +-- | +-- Translate an input file using the given paramters. +-- translateFile :: String -- ^ Translate function (of type @'FilePath' -> music -> 'IO' ()@). -> String -- ^ Output file suffix. @@ -124,17 +160,6 @@ -> Maybe FilePath -- ^ Output file. -> IO () translateFile translationFunction outSuffix preludeName' inFile' outFile' = do - let inFile = fromMaybe "test.music" inFile' - let preludeName = fromMaybe "basic" preludeName' - let outFile = fromMaybe ( - takeDirectory inFile ++ "/" - ++ takeBaseName inFile - ++ "." ++ outSuffix) - outFile' - - let prelude = "Music.Prelude." ++ toCamel preludeName - let scoreType = "Score " ++ toCamel preludeName ++ "Note" - let main = translationFunction code <- readFile inFile newScore <- return $ if isNotExpression code then expand declTempl (Map.fromList [ @@ -163,8 +188,20 @@ return () where - exprTempl = "module Main where { import $(prelude); main = $(main) \"$(outFile)\" ( $(score) :: $(scoreType) ) }" - declTempl = "module Main where \nimport $(prelude) \n$(code) \nmain = $(main) \"$(outFile)\" ( example :: $(scoreType) )" + inFile = fromMaybe "test.music" inFile' + preludeName = fromMaybe "basic" preludeName' + outFile = fromMaybe ( + takeDirectory inFile ++ "/" + ++ takeBaseName inFile + ++ "." ++ outSuffix) + outFile' + + prelude = "Music.Prelude." ++ toCamel preludeName + scoreType = "Score " ++ toCamel preludeName ++ "Note" + main = translationFunction + + exprTempl = "module Main where { import $(prelude); {-# LINE 1 \"" ++ inFile ++ "\" #-}\nmain = $(main) \"$(outFile)\" ( $(score) :: $(scoreType) ) }" + declTempl = "module Main where \nimport $(prelude) {-# LINE 1 \"" ++ inFile ++ "\" #-}\n$(code) \nmain = $(main) \"$(outFile)\" ( example :: $(scoreType) )" -- TODO hackish, preferably parse using haskell-src-exts or similar isNotExpression :: String -> Bool diff --git a/src/Music/Prelude/Instances.hs b/src/Music/Prelude/Instances.hs --- a/src/Music/Prelude/Instances.hs +++ b/src/Music/Prelude/Instances.hs @@ -18,7 +18,7 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- Provides orphan instances that does not fit into other packages. +-- Provides miscellaneous instances. -- ------------------------------------------------------------------------------------- @@ -69,6 +69,16 @@ instance (Transformable a, a ~ Score.Pitch a) => HasPitch Pitch a where pitch = ($) instance (Transformable a, a ~ Score.Pitch a) => HasPitches Pitch a where + pitches = ($) + +instance Transformable Hertz where + transform _ = id +type instance Score.Pitch Hertz = Hertz +type instance SetPitch a Hertz = a + +instance (Transformable a, a ~ Score.Pitch a) => HasPitch Hertz a where + pitch = ($) +instance (Transformable a, a ~ Score.Pitch a) => HasPitches Hertz a where pitches = ($) instance Tiable Pitch where diff --git a/src/Music/Prelude/Standard.hs b/src/Music/Prelude/Standard.hs --- a/src/Music/Prelude/Standard.hs +++ b/src/Music/Prelude/Standard.hs @@ -13,15 +13,16 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) -- --- A basic music representation. +-- Standard music representation. -- ------------------------------------------------------------------------------------- module Music.Prelude.Standard ( - module Music.Score, module Music.Pitch, module Music.Dynamics, + module Music.Articulation, module Music.Parts, + module Music.Score, StandardNote, asScore, asVoice, @@ -35,11 +36,11 @@ import Data.Default import Data.Typeable +import Music.Pitch import Music.Dynamics +import Music.Articulation import Music.Parts -import Music.Pitch -import Music.Score hiding (Fifths, Interval, Note, Part, - Pitch, pitch) +import Music.Score hiding (Fifths, Interval, Note, Part, Pitch, Dynamics, Articulation) import Music.Prelude.Instances () @@ -69,14 +70,10 @@ (TremoloT (HarmonicT (SlideT - (ArticulationT (Sum Double, Sum Double) - (DynamicT (Average Double) + (ArticulationT Articulation + (DynamicT Dynamics [TieT - (Behavior StandardPitch)])))))))) - -type StandardPitch = Music.Pitch.Pitch --- data StandardPitch = StandardPitch Music.Pitch.Pitch - -- deriving (HasMidi, HasLilypond, HasMusicXml, HasPitch) + (Behavior Pitch)])))))))) open = openLilypond . asScore