diff --git a/examples/duo.hs b/examples/duo.hs new file mode 100644 --- /dev/null +++ b/examples/duo.hs @@ -0,0 +1,42 @@ + +import System.Process (runCommand) +import Music.Prelude.StringQuartet + +main = do + -- writeMidi "test.mid" score + -- writeXml "test.xml" $ score^/4 + -- openXml score + openLy score + -- playMidiIO "Graphic MIDI" $ score^/10 + +score = piece + +subj1 = ((_p `cresc` mf |> mf `dim` _p)^*(duration subj1' - 2)) `dynamics` subj1' + +subj1' :: Score Note +subj1' = (^/2) $ + legato (b_ |> c) |> legato (c |> b_^*2) + |> legato (b_ |> c |> d) + |> b_ |> c |> b_^*2 + |> legato (e |> d |> b_ |> c) |> b_^*2 + |> d |> e |> b_ |> c^*2 |> b_ + +piece = part1 |> toLydian part2 + where + part1 = pres1 |> pres2 |> pres3 |> pres4 |> pres5 |> pres6 + part2 = pres1 |> pres2 |> pres3 |> pres4 |> pres5 |> pres6 + +pres1 = delay 0 (subj1^*(2/2)) +pres2 = delay 0 (subj1^*(2/2)) delay 2 (subj1^*(3/2)) +pres3 = delay 0 (subj1^*(2/2)) delay 2 (subj1^*(3/2)) +pres4 = delay 0 (subj1^*(2/3)) delay 2 (subj1^*(3/2)) +pres5 = delay 0 (subj1^*(2/3)) delay 4 (subj1^*(2/2)) +pres6 = delay 0 (subj1^*(2/3)) delay 4 (subj1^*(2/2)) + + +toLydian = modifyPitches (\p -> if p == c then cs else p) + +-- (|>) :: Score a -> Score a -> Score a +-- a |> b = mcatMaybes $ fmap Just a ||> fmap Just b + + diff --git a/examples/erlkonig.hs b/examples/erlkonig.hs new file mode 100644 --- /dev/null +++ b/examples/erlkonig.hs @@ -0,0 +1,31 @@ + +import System.Process (runCommand) +import Music.Prelude.Basic + +main = do + -- writeMidi "test.mid" score + -- writeXml "test.xml" $ score^/4 + -- openXml score + openLy score + -- playMidiIO "Graphic MIDI" $ score^/10 + +score :: Score Note +score = let + up x = fmap (modifyPitch (+ x)) + down x = fmap (modifyPitch (subtract x)) + triplet = group 3 + melody = scat + rest = return Nothing + octave = 12 + + a `x` b = a^*(3/4) |> b^*(1/4) + a `l` b = (a |> b)^/2 + + motive = (legato $ stretchTo 2 $ melody [g,a,bb,c',d',eb']) |> staccato (d' |> bb |> g) + bar = rest^*4 :: Score (Maybe Note) + + song = mempty + left = times 4 (times 4 $ removeRests $ triplet g) + right = removeRests $ times 2 (delay 4 motive |> rest^*3) + + in stretch (1/4) $ times 10 $ song left down octave right diff --git a/examples/triplets.hs b/examples/triplets.hs new file mode 100644 --- /dev/null +++ b/examples/triplets.hs @@ -0,0 +1,22 @@ + +import System.Process (runCommand) +import Music.Prelude.StringQuartet + +main = do + -- writeMidi "test.mid" score + -- writeXml "test.xml" $ score^/4 + -- openXml score + openLy score + -- playMidiIO "Graphic MIDI" $ score^/10 + +subject = legato $ accent $ scat [c',cs'^*2] + +score :: Score Note +score = + (times 5 $ subject ^*(2/3 * 1/4)) + + (times 5 $ subject ^*(1/4)) + + (times 5 $ subject ^*(2/3 * 1/2)) + + (times 5 $ subject ^*(1/2)) diff --git a/music-preludes.cabal b/music-preludes.cabal --- a/music-preludes.cabal +++ b/music-preludes.cabal @@ -1,7 +1,7 @@ name: music-preludes -version: 1.2.1 -cabal-version: >= 1.2 +version: 1.3 +cabal-version: >= 1.8 author: Hans Hoglund maintainer: Hans Hoglund license: BSD3 @@ -12,17 +12,20 @@ build-type: Simple description: - Some useful preludes for the Haskell Music Suite. + Some useful preludes for the Music Suite. - This library is part of the Haskell Music Suite, see . + This library is part of the Music Suite, see . library build-depends: base >= 4 && < 5, - music-score, - musicxml2, vector-space, + musicxml2, + process, semigroups, + monadplus, + reverse-apply, + music-score, music-pitch, music-pitch-literal, music-dynamics, @@ -30,5 +33,44 @@ hs-source-dirs: src exposed-modules: + Music.Prelude.Basic Music.Prelude.Piano - + Music.Prelude.StringQuartet + +executable "complex" + hs-source-dirs: src examples + main-is: duo.hs + +executable "duo" + hs-source-dirs: src examples + main-is: duo.hs + +executable "erlkonig" + hs-source-dirs: src examples + main-is: erlkonig.hs + +executable "triplets" + hs-source-dirs: src examples + main-is: triplets.hs + +executable "music2ly" + hs-source-dirs: src examples + main-is: music2ly.hs +executable "music2midi" + hs-source-dirs: src examples + main-is: music2midi.hs +executable "music2musicxml" + hs-source-dirs: src examples + main-is: music2musicxml.hs + +test-suite properties + type: exitcode-stdio-1.0 + main-is: properties.hs + hs-source-dirs: tests + ghc-options: -w -threaded -rtsopts -with-rtsopts=-N + build-depends: + HUnit >= 1.2, + QuickCheck >= 1.2 && < 1.3, + test-framework >= 0.6, + test-framework-th >= 0.2, + test-framework-quickcheck >= 0.3 diff --git a/src/Music/Prelude/Basic.hs b/src/Music/Prelude/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Music/Prelude/Basic.hs @@ -0,0 +1,33 @@ + +{-# LANGUAGE + GeneralizedNewtypeDeriving, + DeriveDataTypeable #-} + +module Music.Prelude.Basic ( + module Music.Score, + BasicPart, + Note, + asScore + ) where + +import Music.Score +import Data.Typeable + +asScore :: Score Note -> Score Note +asScore = id + +asVoice :: Voice Note -> Voice Note +asVoice = id + +asTrack :: Track Note -> Track Note +asTrack = id + +newtype BasicPart = BasicPart { getBasicPart :: Integer } + deriving (Eq, Ord, Enum, Typeable) + +instance Show BasicPart where + show _ = "" + +type Note = (PartT BasicPart (TieT + (TremoloT (HarmonicT (SlideT + (DynamicT (ArticulationT (TextT Integer)))))))) diff --git a/src/Music/Prelude/Piano.hs b/src/Music/Prelude/Piano.hs --- a/src/Music/Prelude/Piano.hs +++ b/src/Music/Prelude/Piano.hs @@ -1,41 +1,28 @@ +{-# LANGUAGE + GeneralizedNewtypeDeriving, + DeriveDataTypeable #-} + module Music.Prelude.Piano ( module Music.Score, - module Music.Score.Combinators, - module Music.Pitch.Literal, - module Data.Semigroup, - module Data.VectorSpace, - module Data.AffineSpace, - NotePart, + PianoPart, Note, - putXml, - showXml, asScore ) where import Music.Score -import Music.Score.Combinators -import Music.Pitch.Literal -import Music.Dynamics.Literal -import Data.Semigroup -import Data.VectorSpace hiding (Sum, getSum) -import Data.AffineSpace -import qualified Music.MusicXml as Xml - - -putXml = putStrLn . Xml.showXml . toXml . asScore -showXml = Xml.showXml . toXml . asScore +import Data.Typeable asScore :: Score Note -> Score Note asScore = id -data NotePart +data PianoPart = Pno deriving (Eq, Ord, Enum) -instance Show NotePart where +instance Show PianoPart where show Pno = "Piano" -type Note = (VoiceT NotePart (TieT +type Note = (PartT PianoPart (TieT (TremoloT (HarmonicT (SlideT (DynamicT (ArticulationT (TextT Integer)))))))) diff --git a/src/Music/Prelude/StringQuartet.hs b/src/Music/Prelude/StringQuartet.hs new file mode 100644 --- /dev/null +++ b/src/Music/Prelude/StringQuartet.hs @@ -0,0 +1,34 @@ + +{-# LANGUAGE + GeneralizedNewtypeDeriving, + DeriveDataTypeable #-} + +module Music.Prelude.StringQuartet ( + module Music.Score, + StringQuartetPart, + Note, + asScore + ) where + +import Music.Score +import Data.Typeable + +asScore :: Score Note -> Score Note +asScore = id + +data StringQuartetPart + = Vl1 + | Vl2 + | Vla + | Vc + deriving (Eq, Ord, Enum, Typeable) + +instance Show StringQuartetPart where + show Vl1 = "Violin I" + show Vl2 = "Violin II" + show Vla = "Viola" + show Vc = "Cello" + +type Note = (PartT StringQuartetPart (TieT + (TremoloT (HarmonicT (SlideT + (DynamicT (ArticulationT (TextT Integer)))))))) diff --git a/src/music2ly.hs b/src/music2ly.hs new file mode 100644 --- /dev/null +++ b/src/music2ly.hs @@ -0,0 +1,44 @@ + +import Control.Exception +import Control.Monad (when) +-- import Control.Monad.Error hiding (mapM) +-- import Control.Monad.Plus hiding (mapM) +-- import Data.Semigroup hiding (Option) +-- import Data.List (find) +-- import Data.Maybe (fromMaybe, maybeToList) +-- import Data.Traversable (mapM) +-- import Data.Typeable +import System.IO +import System.Exit +import System.Environment +import System.Console.GetOpt + +import Prelude hiding (readFile, writeFile) + +main :: IO () +main = do + (opts, args, optErrs) <- getOpt Permute options `fmap` getArgs + + let usage = usageInfo (header "music2ly") options + let printUsage = putStr (usage ++ "\n") >> exitSuccess + let printVersion = putStr (version "music2ly" ++ "\n") >> exitSuccess + + when (1 `elem` opts) printUsage + when (2 `elem` opts) printVersion + printVersion + +version name = name ++ "-0.8" +header name = "Usage: "++name++" [options]\n" ++ + "Usage: "++name++" [options] files...\n" ++ + "\n" ++ + "Options:" + +options = [ + Option ['h'] ["help"] (NoArg 1) "Print help and exit", + Option ['v'] ["version"] (NoArg 2) "Print version and exit" + ] + + +-- Load the file into the interpreter +-- Get the 'score' variable +-- Run (writeLy path score) diff --git a/src/music2midi.hs b/src/music2midi.hs new file mode 100644 --- /dev/null +++ b/src/music2midi.hs @@ -0,0 +1,2 @@ + +main = putStrLn "music2midi" diff --git a/src/music2musicxml.hs b/src/music2musicxml.hs new file mode 100644 --- /dev/null +++ b/src/music2musicxml.hs @@ -0,0 +1,2 @@ + +main = putStrLn "music2musicxml" diff --git a/tests/properties.hs b/tests/properties.hs new file mode 100644 --- /dev/null +++ b/tests/properties.hs @@ -0,0 +1,37 @@ + +{-# LANGUAGE + FlexibleInstances + #-} + +module Main where + +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck (testProperty) +import Test.QuickCheck + +import Music.Score + +import Data.List + +main = defaultMain tests + +tests = [ + testGroup "Sorting Group 1" [ + testProperty "duration :: Score" prop_durationScore, + testProperty "duration :: Track" prop_durationTrack + ] + ] + + +prop_durationScore a = offset a .-. onset a == duration a + where + types = ( + a :: Score () + ) + +prop_durationTrack a = offset a .-. onset a == duration a + where + types = ( + a :: Track () + ) +