music-score 1.2.2 → 1.3
raw patch · 31 files changed
+3606/−2471 lines, 31 filesdep +QuickCheckdep +data-defaultdep +lilypond
Dependencies added: QuickCheck, data-default, lilypond, monadplus, pointed, prettify, process
Files
- music-score.cabal +39/−13
- src/Music/Score.hs +97/−1201
- src/Music/Score/Articulation.hs +41/−76
- src/Music/Score/Chord.hs +72/−0
- src/Music/Score/Combinators.hs +469/−294
- src/Music/Score/Duration.hs +0/−85
- src/Music/Score/Dynamics.hs +49/−68
- src/Music/Score/Export/Lilypond.hs +254/−0
- src/Music/Score/Export/Midi.hs +186/−0
- src/Music/Score/Export/MusicXml.hs +277/−0
- src/Music/Score/Export/Util.hs +145/−0
- src/Music/Score/Instances.hs +750/−0
- src/Music/Score/Ornaments.hs +28/−51
- src/Music/Score/Part.hs +174/−65
- src/Music/Score/Pitch.hs +18/−15
- src/Music/Score/Rhythm.hs +75/−60
- src/Music/Score/Score.hs +119/−113
- src/Music/Score/Ties.hs +63/−63
- src/Music/Score/Time.hs +0/−120
- src/Music/Score/Track.hs +45/−32
- src/Music/Score/Voice.hs +68/−148
- src/Music/Score/Zip.hs +119/−0
- src/Music/Time.hs +47/−0
- src/Music/Time/Delayable.hs +44/−0
- src/Music/Time/Duration.hs +62/−0
- src/Music/Time/Onset.hs +113/−0
- src/Music/Time/Performable.hs +59/−0
- src/Music/Time/Pos.hs +70/−0
- src/Music/Time/Stretchable.hs +50/−0
- src/Music/Time/Time.hs +73/−0
- test/Main.hs +0/−67
music-score.cabal view
@@ -1,6 +1,6 @@ name: music-score-version: 1.2.2+version: 1.3 cabal-version: >= 1.2 author: Hans Hoglund maintainer: Hans Hoglund@@ -14,21 +14,28 @@ description: Musical score and part representation. - This library is part of the Haskell Music Suite, see <http://musicsuite.github.com>.+ This library is part of the Music Suite, see <http://musicsuite.github.com>. library build-depends: base >= 4 && < 5,+ QuickCheck >= 1.2 && < 1.3, unix, time,- random, + random,+ process,+ data-default, containers, parsec, transformers,+ monadplus,+ prettify, HCodecs, musicxml2,+ lilypond, semigroups,- nats,+ nats, + pointed, semigroupoids, vector-space, music-pitch-literal,@@ -37,21 +44,40 @@ hs-source-dirs: src exposed-modules:+ Music.Time+ Music.Time.Time+ Music.Time.Duration+ Music.Time.Delayable+ Music.Time.Stretchable+ Music.Time.Performable+ Music.Time.Onset+ Music.Time.Pos++ Music.Score.Rhythm+ Music.Score- Music.Score.Time- Music.Score.Duration+ Music.Score.Track- Music.Score.Part+ Music.Score.Voice Music.Score.Score- Music.Score.Rhythm+ Music.Score.Combinators- Music.Score.Pitch- Music.Score.Voice Music.Score.Ties+ Music.Score.Zip+ Music.Score.Part+ Music.Score.Chord+ Music.Score.Pitch Music.Score.Articulation Music.Score.Dynamics Music.Score.Ornaments++ Music.Score.Export.Midi+ Music.Score.Export.Lilypond+ Music.Score.Export.MusicXml+ other-modules:+ Music.Score.Instances+ Music.Score.Export.Util -executable "music-score-tests"- hs-source-dirs: src test- main-is: Main.hs+-- executable "music-score-tests"+-- hs-source-dirs: src test+-- main-is: Main.hs
src/Music/Score.hs view
@@ -1,1203 +1,99 @@ {-# LANGUAGE- CPP,- TypeFamilies,- DeriveFunctor,- DeriveFoldable, - GeneralizedNewtypeDeriving,- FlexibleInstances,- TypeOperators, - OverloadedStrings,- FlexibleContexts, -- for IsPitch stuff- NoMonomorphismRestriction #-}------------------------------------------------------------------------------------------ |--- Copyright : (c) Hans Hoglund 2012------ License : BSD-style------ Maintainer : hans@hanshoglund.se--- Stability : experimental--- Portability : non-portable (TF,GNTD)------ Provides a musical score represenation.-------------------------------------------------------------------------------------------module Music.Score (-- module Music.Score.Time,- module Music.Score.Duration,-- module Music.Score.Track,- module Music.Score.Part,- module Music.Score.Score,-- module Music.Score.Pitch,- module Music.Score.Voice,- module Music.Score.Ties,-- module Music.Score.Articulation,- module Music.Score.Dynamics,- module Music.Score.Ornaments,-- -- ** Constructors-#ifdef __HADDOCK__- rest,- note,- chord,- melody, -#endif-- -- ** Composing- (|>),- (<|),- scat,- -- pcat,- -- sustain,- -- overlap,- -- anticipate,- - -- ** Transforming- move,- moveBack,- startAt,- stopAt,- stretch,- compress,- stretchTo,- - -- ** Conversions- scoreToTrack,- scoreToPart,- scoreToParts,- partToScore,- trackToScore,-- -- * Export - -- ** MIDI - HasMidi(..),- toMidi,- writeMidi,- playMidi,- playMidiIO,-- -- ** MusicXML- XmlScore,- XmlMusic,- HasMusicXml(..),- toXml,- writeXml,- openXml,- toXmlPart,- writeXmlPart,- openXmlPart,-)-where--{-- TODO- Split and reverse- Zipper applicative (for appying dynamic and articulation transformations etc)--} --import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)--import Data.Semigroup-import Data.Ratio-import Data.String-import Control.Applicative-import Control.Monad (ap, mfilter, join, liftM, MonadPlus(..))-import Data.Maybe-import Data.Either-import Data.Foldable-import Data.Traversable-import Data.Function (on)-import Data.Ord (comparing)-import Data.VectorSpace-import Data.AffineSpace-import Data.Basis--import Control.Reactive-import Control.Reactive.Midi--import Music.Score.Time-import Music.Score.Duration-import Music.Score.Rhythm-import Music.Score.Track-import Music.Score.Part-import Music.Score.Score-import Music.Score.Combinators-import Music.Score.Pitch-import Music.Score.Ties-import Music.Score.Voice-import Music.Score.Articulation-import Music.Score.Dynamics-import Music.Score.Ornaments--import qualified Codec.Midi as Midi-import qualified Music.MusicXml.Simple as Xml-import qualified Data.Map as Map-import qualified Data.List as List--import System.Posix-import System.IO.Unsafe-import Music.Pitch.Literal-import Music.Dynamics.Literal-------------------------------------------------------------------------------------------- |--- Class of types that can be converted to MIDI.------ Numeric types are interpreted as notes with a default velocity, pairs are--- interpreted as @(pitch, velocity)@ pairs.------ Minimal definition: 'getMidi'. Given 'getMidiScore', 'getMidi' can be implemented--- as @getMidiScore . return@.----class HasMidi a where- - -- | Convert a value to a MIDI score.- -- Typically, generates an /on/ event using 'note' followed by an optional /off/ event.- getMidi :: a -> Score Midi.Message-- -- | Convert a score to a MIDI score.- -- The default definition can be overriden for efficiency.- getMidiScore :: Score a -> Score Midi.Message- getMidiScore = (>>= getMidi)---instance HasMidi Double where getMidi = getMidi . toInteger . round-instance HasMidi Float where getMidi = getMidi . toInteger . round-instance HasMidi Int where getMidi = getMidi . toInteger -instance Integral a => HasMidi (Ratio a) where getMidi = getMidi . toInteger . round -instance HasMidi Midi.Message where getMidi = return-instance HasMidi Integer where getMidi = \x -> getMidi (x,100::Integer)--instance HasMidi (Integer, Integer) where- getMidi (p,v) = mempty- |> note (Midi.NoteOn 0 (fromIntegral p) (fromIntegral v)) - |> note (Midi.NoteOff 0 (fromIntegral p) (fromIntegral v))----- |--- Convert a score to a MIDI file representaiton.--- -toMidi :: HasMidi a => Score a -> Midi.Midi-toMidi score = Midi.Midi fileType divisions' [controlTrack, eventTrack]- where - endPos = 10000- fileType = Midi.MultiTrack - divisions = 1024- divisions' = Midi.TicksPerBeat divisions- controlTrack = [(0, Midi.TempoChange 1000000), (endPos, Midi.TrackEnd)]- eventTrack = events <> [(endPos, Midi.TrackEnd)] -- events :: [(Midi.Ticks, Midi.Message)]- events = (\(t,_,x) -> (round (t * divisions), x)) <$> performance-- performance :: [(Time, Duration, Midi.Message)]- performance = performRelative (getMidiScore score)-- -- FIXME arbitrary endTime (files won't work without this...)- -- TODO handle voice---- |--- Convert a score MIDI and write to a file.--- -writeMidi :: HasMidi a => FilePath -> Score a -> IO ()-writeMidi path sc = Midi.exportFile path (toMidi sc)---- |--- Convert a score to a MIDI event.--- -playMidi :: HasMidi a => String -> Score a -> Event MidiMessage-playMidi dest x = midiOut midiDest $ playback trig (pure $ toTrack $ rest^*0.2 |> x)- where- trig = accumR 0 ((+ 0.005) <$ pulse 0.005) - toTrack = fmap (\(t,_,m) -> (t,m)) . perform . getMidiScore- midiDest = fromJust $ unsafeGetReactive (findDestination $ pure dest)---- |--- Convert a score to a MIDI event and run it.--- -playMidiIO :: HasMidi a => String -> Score a -> IO ()-playMidiIO dest = runLoop . playMidi dest-- ------------------------------------------------------------------------------------------type XmlScore = Xml.Score-type XmlMusic = Xml.Music---- |--- Class of types that can be converted to MusicXML.----class Tiable a => HasMusicXml a where - -- | - -- Convert a value to MusicXML.- --- -- Typically, generates a 'XmlMusic' value using 'Xml.note' or 'Xml.chord', and transforms it - -- to add beams, slurs, dynamics, articulation etc.- --- getMusicXml :: Duration -> a -> XmlMusic--instance HasMusicXml Double where getMusicXml d = getMusicXml d . (toInteger . round)-instance HasMusicXml Float where getMusicXml d = getMusicXml d . (toInteger . round)-instance HasMusicXml Int where getMusicXml d = getMusicXml d . toInteger -instance Integral a => HasMusicXml (Ratio a) where getMusicXml d = getMusicXml d . (toInteger . round) ---- FIXME arbitrary spelling, please modularize...-instance HasMusicXml Integer where- getMusicXml d p = Xml.note (spell (fromIntegral p)) d'- where- d' = (fromRational . toRational $ d) - - step xs p = xs !! (p `mod` length xs)- fromStep xs p = fromMaybe (length xs - 1) $ List.findIndex (>= p) xs- scaleFromSteps = snd . List.mapAccumL add 0- where- add a x = (a + x, a + x)- major = scaleFromSteps [0,2,2,1,2,2,2,1]-- spell :: Int -> Xml.Pitch- spell p = (toEnum pitchClass, if (alteration == 0) then Nothing else Just (fromIntegral alteration), fromIntegral octave) - where- octave = (p `div` 12) - 1- semitone = p `mod` 12- pitchClass = fromStep major semitone- alteration = semitone - step major pitchClass----- |--- Convert a score to MusicXML and write to a file. --- -writeXml :: (HasMusicXml a, HasVoice a, v ~ Voice a, Ord v, Show v) => FilePath -> Score a -> IO ()-writeXml path sc = writeFile path (Xml.showXml $ toXml sc)---- |--- Convert a score to MusicXML and open it. --- -openXml :: (HasMusicXml a, HasVoice a, v ~ Voice a, Ord v, Show v) => Score a -> IO ()-openXml sc = do- writeXml "test.xml" sc- execute "open" ["-a", "/Applications/Sibelius 6.app/Contents/MacOS/Sibelius 6", "test.xml"]- -- FIXME hardcode---- |--- Convert a score to MusicXML and write to a file. --- -writeXmlPart :: HasMusicXml a => FilePath -> Score a -> IO ()-writeXmlPart path sc = writeFile path (Xml.showXml $ toXmlPart sc)---- |--- Convert a score to MusicXML and open it. --- -openXmlPart :: HasMusicXml a => Score a -> IO ()-openXmlPart sc = do- writeXmlPart "test.xml" sc- execute "open" ["-a", "/Applications/Sibelius 6.app/Contents/MacOS/Sibelius 6", "test.xml"]- -- FIXME hardcode----- |--- Convert a score to a MusicXML representaiton. --- -toXml :: (HasMusicXml a, HasVoice a, v ~ Voice a, Ord v, Show v) => Score a -> XmlScore-toXml sc = Xml.fromParts "Title" "Composer" pl . fmap toXmlPart' . voices $ sc- where- pl = Xml.partList (fmap show $ getVoices sc)---- |--- Convert a single-part score to a MusicXML representaiton. --- -toXmlPart :: HasMusicXml a => Score a -> XmlScore-toXmlPart = Xml.fromPart "Title" "Composer" "Part" . toXmlPart'---toXmlPart' :: HasMusicXml a => Score a -> [XmlMusic]-toXmlPart' = id - . prelims- . fmap barToXml - . separateBars - . splitTiesSingle- . addRests- . perform - where- prelims [] = []- prelims (bar1 : rest) = (pre <> bar1) : rest- pre = mempty- <> Xml.defaultKey- <> Xml.defaultDivisions - <> Xml.metronome (1/4) 60- <> Xml.commonTime---- | --- Given a rest-free single-part score (such as those produced by perform), add explicit rests.--- The result will have no empty space.----addRests :: [(Time, Duration, a)] -> Score a-addRests = Score . concat . snd . mapAccumL g 0- where- g prevTime (t, d, x) - | prevTime == t = (t .+^ d, [(t, d, Just x)])- | prevTime < t = (t .+^ d, [(prevTime, t .-. prevTime, Nothing), (t, d, Just x)])- | otherwise = error "addRests: Strange prevTime"--addRests' :: [(Time, Duration, a)] -> [(Time, Duration, Maybe a)]-addRests' = concat . snd . mapAccumL g 0- where- g prevTime (t, d, x) - | prevTime == t = (t .+^ d, [(t, d, Just x)])- | prevTime < t = (t .+^ d, [(prevTime, t .-. prevTime, Nothing), (t, d, Just x)])- | otherwise = error "addRests: Strange prevTime"- --- |--- Given a set of absolute-time occurences, separate at each zero-time occurence.--- Note that this require every bar to start with a zero-time occurence.--- -separateBars :: HasMusicXml a => Score a -> [[(Duration, Maybe a)]]-separateBars = fmap removeTime . fmap (fmap discardBarNumber) . splitAtTimeZero . fmap separateTime . getScore- where - separateTime (t,d,x) = ((bn,bt),d,x) where (bn,bt) = properFraction (toRational t)- splitAtTimeZero = splitWhile ((== 0) . getBarTime) where getBarTime ((bn,bt),_,_) = bt- discardBarNumber ((bn,bt),d,x) = (fromRational bt, d, x)- removeTime = fmap g where g (t,d,x) = (d,x)---barToXml :: HasMusicXml a => [(Duration, Maybe a)] -> Xml.Music-barToXml bar = case quantize bar of- Left e -> error $ "barToXml: Could not quantize this bar: " ++ show e- Right rh -> rhythmToXml rh---- FIXME dotted rests does not work...-rhythmToXml :: HasMusicXml a => Rhythm (Maybe a) -> Xml.Music-rhythmToXml (Beat d x) = noteRestToXml (d, x)-rhythmToXml (Dotted n (Beat d x)) = noteRestToXml (dotMod n * d, x)-rhythmToXml (Tuplet m r) = Xml.tuplet (fromIntegral $ denominator $ getDuration $ m) (fromIntegral $ numerator $ getDuration m) (rhythmToXml r)-rhythmToXml (Bound d r) = noteRestToXml (fromRational $ getDuration d, x) <> rhythmToXml r2- where- (x,r2) = toTiedRhythm r-rhythmToXml (Rhythms rs) = mconcat $ map rhythmToXml rs--toTiedRhythm :: HasMusicXml a => Rhythm (Maybe a) -> (Maybe a, Rhythm (Maybe a))-toTiedRhythm (Beat d a) = (b, Beat d c) where (b,c) = toTied a-toTiedRhythm (Dotted n a) = (b, Dotted n c) where (b,c) = toTiedRhythm a-toTiedRhythm (Tuplet m a) = (b, Tuplet m c) where (b,c) = toTiedRhythm a -toTiedRhythm (Bound d r) = error "toXml: Nested bounded rhytms"-toTiedRhythm (Rhythms []) = error "toXml: Bound empty rhythm"-toTiedRhythm (Rhythms (a:as)) = (b, Rhythms (c:as)) where (b,c) = toTiedRhythm a--noteRestToXml :: HasMusicXml a => (Duration, Maybe a) -> Xml.Music-noteRestToXml (d, Nothing) = Xml.rest d' where d' = (fromRational . toRational $ d) -noteRestToXml (d, Just p) = getMusicXml d p------------------------------------------------------------------------------------------ Transformer instances (TODO move)------------------------------------------------------------------------------------------ PitchT---- instance HasMidi a => HasMidi (PitchT p a) where--- getMidi (PitchT (_,x)) = getMidi x--- instance HasMusicXml a => HasMusicXml (PitchT p a) where--- getMusicXml d (PitchT (_,x)) = getMusicXml d x--- instance (IsPitch a, IsString n) => IsPitch (PitchT p a) where--- fromPitch l = PitchT ("", fromPitch l)--- instance (IsDynamics a, IsString n) => IsDynamics (PitchT p a) where--- fromDynamics l = PitchT ("", fromDynamics l)--- instance HasDynamic a => HasDynamic (PitchT p a) where--- setBeginCresc n (PitchT (v,x)) = PitchT (v, setBeginCresc n x)--- setEndCresc n (PitchT (v,x)) = PitchT (v, setEndCresc n x)--- setBeginDim n (PitchT (v,x)) = PitchT (v, setBeginDim n x)--- setEndDim n (PitchT (v,x)) = PitchT (v, setEndDim n x)--- setLevel n (PitchT (v,x)) = PitchT (v, setLevel n x)--- instance HasArticulation a => HasArticulation (PitchT p a) where--- setEndSlur n (PitchT (v,x)) = PitchT (v, setEndSlur n x)--- setContSlur n (PitchT (v,x)) = PitchT (v, setContSlur n x)--- setBeginSlur n (PitchT (v,x)) = PitchT (v, setBeginSlur n x)--- setAccLevel n (PitchT (v,x)) = PitchT (v, setAccLevel n x)--- setStaccLevel n (PitchT (v,x)) = PitchT (v, setStaccLevel n x)--- instance HasTremolo a => HasTremolo (PitchT p a) where--- setTrem n (PitchT (v,x)) = PitchT (v, setTrem n x)--- ---- VoiceT---instance HasMidi a => HasMidi (VoiceT n a) where- getMidi (VoiceT (_,x)) = getMidi x-instance HasMusicXml a => HasMusicXml (VoiceT n a) where- getMusicXml d (VoiceT (_,x)) = getMusicXml d x-instance HasVoice (VoiceT n a) where - type Voice (VoiceT n a) = n- getVoice (VoiceT (v,_)) = v- modifyVoice f (VoiceT (v,x)) = VoiceT (f v, x)-instance HasPitch a => HasPitch (VoiceT n a) where - type Pitch (VoiceT n a) = Pitch a- getPitch (VoiceT (v,a)) = getPitch a- modifyPitch f (VoiceT (v,x)) = VoiceT (v, modifyPitch f x)--- TODO IsPitch/IsDynamic with mempty/def as default as well?-instance (IsPitch a, Enum n) => IsPitch (VoiceT n a) where- fromPitch l = VoiceT (toEnum 0, fromPitch l)-instance (IsDynamics a, Enum n) => IsDynamics (VoiceT n a) where- fromDynamics l = VoiceT (toEnum 0, fromDynamics l)-instance Tiable a => Tiable (VoiceT n a) where- toTied (VoiceT (v,a)) = (VoiceT (v,b), VoiceT (v,c)) where (b,c) = toTied a-instance HasDynamic a => HasDynamic (VoiceT n a) where- setBeginCresc n (VoiceT (v,x)) = VoiceT (v, setBeginCresc n x)- setEndCresc n (VoiceT (v,x)) = VoiceT (v, setEndCresc n x)- setBeginDim n (VoiceT (v,x)) = VoiceT (v, setBeginDim n x)- setEndDim n (VoiceT (v,x)) = VoiceT (v, setEndDim n x)- setLevel n (VoiceT (v,x)) = VoiceT (v, setLevel n x)-instance HasArticulation a => HasArticulation (VoiceT n a) where- setEndSlur n (VoiceT (v,x)) = VoiceT (v, setEndSlur n x)- setContSlur n (VoiceT (v,x)) = VoiceT (v, setContSlur n x)- setBeginSlur n (VoiceT (v,x)) = VoiceT (v, setBeginSlur n x)- setAccLevel n (VoiceT (v,x)) = VoiceT (v, setAccLevel n x)- setStaccLevel n (VoiceT (v,x)) = VoiceT (v, setStaccLevel n x)-instance HasTremolo a => HasTremolo (VoiceT n a) where- setTrem n (VoiceT (v,x)) = VoiceT (v, setTrem n x)-instance HasHarmonic a => HasHarmonic (VoiceT n a) where- setHarmonic n (VoiceT (v,x)) = VoiceT (v, setHarmonic n x)-instance HasSlide a => HasSlide (VoiceT n a) where- setBeginGliss n (VoiceT (v,x)) = VoiceT (v, setBeginGliss n x)- setBeginSlide n (VoiceT (v,x)) = VoiceT (v, setBeginSlide n x)- setEndGliss n (VoiceT (v,x)) = VoiceT (v, setEndGliss n x)- setEndSlide n (VoiceT (v,x)) = VoiceT (v, setEndSlide n x)-instance HasText a => HasText (VoiceT n a) where- addText s (VoiceT (v,x)) = VoiceT (v, addText s x)----- TieT--instance HasMidi a => HasMidi (TieT a) where- getMidi (TieT (_,x,_)) = getMidi x-instance HasMusicXml a => HasMusicXml (TieT a) where- getMusicXml d (TieT (ta,x,tb)) = addTies $ getMusicXml d x- where- addTies | ta && tb = Xml.endTie . Xml.beginTie- | tb = Xml.beginTie- | ta = Xml.endTie- | otherwise = id-instance HasVoice a => HasVoice (TieT a) where - type Voice (TieT a) = Voice a- getVoice (TieT (_,x,_)) = getVoice x- modifyVoice f (TieT (b,x,e)) = TieT (b,modifyVoice f x,e)-instance HasPitch a => HasPitch (TieT a) where - type Pitch (TieT a) = Pitch a- getPitch (TieT (_,x,_)) = getPitch x- modifyPitch f (TieT (b,x,e)) = TieT (b,modifyPitch f x,e)-instance IsPitch a => IsPitch (TieT a) where- fromPitch l = TieT (False, fromPitch l, False)-instance IsDynamics a => IsDynamics (TieT a) where- fromDynamics l = TieT (False, fromDynamics l, False)-instance HasDynamic a => HasDynamic (TieT a) where- setBeginCresc n (TieT (b,x,e)) = TieT (b,setBeginCresc n x,e)- setEndCresc n (TieT (b,x,e)) = TieT (b,setEndCresc n x,e)- setBeginDim n (TieT (b,x,e)) = TieT (b,setBeginDim n x,e)- setEndDim n (TieT (b,x,e)) = TieT (b,setEndDim n x,e)- setLevel n (TieT (b,x,e)) = TieT (b,setLevel n x,e)-instance HasArticulation a => HasArticulation (TieT a) where- setEndSlur n (TieT (b,x,e)) = TieT (b,setEndSlur n x,e)- setContSlur n (TieT (b,x,e)) = TieT (b,setContSlur n x,e)- setBeginSlur n (TieT (b,x,e)) = TieT (b,setBeginSlur n x,e)- setAccLevel n (TieT (b,x,e)) = TieT (b,setAccLevel n x,e)- setStaccLevel n (TieT (b,x,e)) = TieT (b,setStaccLevel n x,e)-instance HasTremolo a => HasTremolo (TieT a) where- setTrem n (TieT (b,x,e)) = TieT (b,setTrem n x,e)-instance HasHarmonic a => HasHarmonic (TieT a) where- setHarmonic n (TieT (b,x,e)) = TieT (b,setHarmonic n x,e)-instance HasSlide a => HasSlide (TieT a) where- setBeginGliss n (TieT (b,x,e)) = TieT (b,setBeginGliss n x,e)- setBeginSlide n (TieT (b,x,e)) = TieT (b,setBeginSlide n x,e)- setEndGliss n (TieT (b,x,e)) = TieT (b,setEndGliss n x,e)- setEndSlide n (TieT (b,x,e)) = TieT (b,setEndSlide n x,e)-instance HasText a => HasText (TieT a) where- addText s (TieT (b,x,e)) = TieT (b, addText s x, e)----- DynamicT---- end cresc/dim, level, begin cresc/dim--- newtype DynamicT a = DynamicT { getDynamicT :: (Bool, Bool, Maybe Double, a, Bool, Bool) }--instance HasMidi a => HasMidi (DynamicT a) where- getMidi (DynamicT (ec,ed,l,a,bc,bd)) = getMidi a--instance HasMusicXml a => HasMusicXml (DynamicT a) where- getMusicXml d (DynamicT (ec,ed,l,a,bc,bd)) = notate $ getMusicXml d a- where- notate x = nec <> ned <> nl <> nbc <> nbd <> x- nec = if ec then Xml.endCresc else mempty- ned = if ed then Xml.endDim else mempty- nbc = if bc then Xml.beginCresc else mempty- nbd = if bd then Xml.beginDim else mempty- nl = case l of - Nothing -> mempty- Just lvl -> Xml.dynamic (fromDynamics (DynamicsL (Just lvl, Nothing)))--instance Tiable a => Tiable (DynamicT a) where- toTied (DynamicT (ec,ed,l,a,bc,bd)) = (DynamicT (ec,ed,l,b,bc,bd),- DynamicT (False,False,Nothing,c,False,False)) where (b,c) = toTied a-instance HasVoice a => HasVoice (DynamicT a) where - type Voice (DynamicT a) = Voice a- getVoice (DynamicT (ec,ed,l,a,bc,bd)) = getVoice a- modifyVoice f (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,modifyVoice f a,bc,bd)-instance HasPitch a => HasPitch (DynamicT a) where - type Pitch (DynamicT a) = Pitch a- getPitch (DynamicT (ec,ed,l,a,bc,bd)) = getPitch a- modifyPitch f (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,modifyPitch f a,bc,bd)-instance IsPitch a => IsPitch (DynamicT a) where- fromPitch l = DynamicT (False,False,Nothing,fromPitch l,False,False)-instance IsDynamics a => IsDynamics (DynamicT a) where- fromDynamics l = DynamicT (False,False,Nothing,fromDynamics l,False,False)-instance HasDynamic (DynamicT a) where- setBeginCresc bc (DynamicT (ec,ed,l,a,_ ,bd)) = DynamicT (ec,ed,l,a,bc,bd)- setEndCresc ec (DynamicT (_ ,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,a,bc,bd)- setBeginDim bd (DynamicT (ec,ed,l,a,bc,_ )) = DynamicT (ec,ed,l,a,bc,bd)- setEndDim ed (DynamicT (ec,_ ,l,a,bc,bd)) = DynamicT (ec,ed,l,a,bc,bd)- setLevel l (DynamicT (ec,ed,_,a,bc,bd)) = DynamicT (ec,ed,Just l,a,bc,bd)-instance HasArticulation a => HasArticulation (DynamicT a) where- setEndSlur n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setEndSlur n a,bc,bd)- setContSlur n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setContSlur n a,bc,bd)- setBeginSlur n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setBeginSlur n a,bc,bd)- setAccLevel n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setAccLevel n a,bc,bd)- setStaccLevel n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setStaccLevel n a,bc,bd)-instance HasTremolo a => HasTremolo (DynamicT a) where- setTrem n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setTrem n a,bc,bd)-instance HasHarmonic a => HasHarmonic (DynamicT a) where- setHarmonic n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setHarmonic n a,bc,bd)-instance HasSlide a => HasSlide (DynamicT a) where- setBeginGliss n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setBeginGliss n a,bc,bd)- setBeginSlide n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setBeginSlide n a,bc,bd)- setEndGliss n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setEndGliss n a,bc,bd)- setEndSlide n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setEndSlide n a,bc,bd)-instance HasText a => HasText (DynamicT a) where- addText s (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,addText s a,bc,bd)----- ArticulationT---- end slur, cont slur, acc level, stacc level, begin slur--- newtype ArticulationT a = ArticulationT { getArticulationT :: (Bool, Bool, Int, Int, a, Bool) }--instance HasMidi a => HasMidi (ArticulationT a) where- getMidi (ArticulationT (es,us,al,sl,a,bs)) = getMidi a-instance HasMusicXml a => HasMusicXml (ArticulationT a) where- getMusicXml d (ArticulationT (es,us,al,sl,a,bs)) = notate $ getMusicXml d a- where- notate = nes . nal . nsl . nbs- nes = if es then Xml.endSlur else id- nal = case al of- 0 -> id- 1 -> Xml.accent- 2 -> Xml.strongAccent- nsl = case sl of- (-2) -> Xml.tenuto- (-1) -> Xml.tenuto . Xml.staccato- 0 -> id- 1 -> Xml.staccato- 2 -> Xml.staccatissimo- nbs = if bs then Xml.beginSlur else id- -instance Tiable a => Tiable (ArticulationT a) where- toTied (ArticulationT (es,us,al,sl,a,bs)) = (ArticulationT (False,us,al,sl,b,bs),- ArticulationT (es, us,0,0,c,False)) where (b,c) = toTied a-instance HasVoice a => HasVoice (ArticulationT a) where - type Voice (ArticulationT a) = Voice a- getVoice (ArticulationT (es,us,al,sl,a,bs)) = getVoice a- modifyVoice f (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,modifyVoice f a,bs)-instance HasPitch a => HasPitch (ArticulationT a) where - type Pitch (ArticulationT a) = Pitch a- getPitch (ArticulationT (es,us,al,sl,a,bs)) = getPitch a- modifyPitch f (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,modifyPitch f a,bs)-instance IsPitch a => IsPitch (ArticulationT a) where- fromPitch l = ArticulationT (False,False,0,0,fromPitch l,False)-instance IsDynamics a => IsDynamics (ArticulationT a) where- fromDynamics l = ArticulationT (False,False,0,0,fromDynamics l,False)-instance HasDynamic a => HasDynamic (ArticulationT a) where- setBeginCresc n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setBeginCresc n a,bs)- setEndCresc n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setEndCresc n a,bs)- setBeginDim n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setBeginDim n a,bs)- setEndDim n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setEndDim n a,bs)- setLevel n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setLevel n a,bs)-instance HasArticulation (ArticulationT a) where- setEndSlur es (ArticulationT (_ ,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,a,bs)- setContSlur us (ArticulationT (es,_ ,al,sl,a,bs)) = ArticulationT (es,us,al,sl,a,bs)- setBeginSlur bs (ArticulationT (es,us,al,sl,a,_ )) = ArticulationT (es,us,al,sl,a,bs)- setAccLevel al (ArticulationT (es,us,_ ,sl,a,bs)) = ArticulationT (es,us,al,sl,a,bs)- setStaccLevel sl (ArticulationT (es,us,al,_ ,a,bs)) = ArticulationT (es,us,al,sl,a,bs)-instance HasTremolo a => HasTremolo (ArticulationT a) where- setTrem n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setTrem n a,bs)-instance HasHarmonic a => HasHarmonic (ArticulationT a) where- setHarmonic n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setHarmonic n a,bs)-instance HasSlide a => HasSlide (ArticulationT a) where- setBeginGliss n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setBeginGliss n a,bs)- setBeginSlide n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setBeginSlide n a,bs)- setEndGliss n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setEndGliss n a,bs)- setEndSlide n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setEndSlide n a,bs)-instance HasText a => HasText (ArticulationT a) where- addText s (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,addText s a,bs)- - --- TremoloT---- newtype TremoloT a = TremoloT { getTremoloT :: (Int, a) }--instance HasMidi a => HasMidi (TremoloT a) where- getMidi (TremoloT (_,x)) = getMidi x-instance HasMusicXml a => HasMusicXml (TremoloT a) where- getMusicXml d (TremoloT (n,x)) = notate $ getMusicXml d x- where- notate = Xml.tremolo n- -instance Tiable a => Tiable (TremoloT a) where- toTied (TremoloT (n,a)) = (TremoloT (n,b), TremoloT (n,c)) where (b,c) = toTied a-instance HasVoice a => HasVoice (TremoloT a) where - type Voice (TremoloT a) = Voice a- getVoice (TremoloT (_,a)) = getVoice a- modifyVoice f (TremoloT (n,x)) = TremoloT (n, modifyVoice f x)-instance HasPitch a => HasPitch (TremoloT a) where - type Pitch (TremoloT a) = Pitch a- getPitch (TremoloT (_,a)) = getPitch a- modifyPitch f (TremoloT (n,x)) = TremoloT (n, modifyPitch f x)-instance IsPitch a => IsPitch (TremoloT a) where- fromPitch l = TremoloT (0, fromPitch l)-instance IsDynamics a => IsDynamics (TremoloT a) where- fromDynamics l = TremoloT (0, fromDynamics l)-instance HasDynamic a => HasDynamic (TremoloT a) where- setBeginCresc n (TremoloT (v,x)) = TremoloT (v, setBeginCresc n x)- setEndCresc n (TremoloT (v,x)) = TremoloT (v, setEndCresc n x)- setBeginDim n (TremoloT (v,x)) = TremoloT (v, setBeginDim n x)- setEndDim n (TremoloT (v,x)) = TremoloT (v, setEndDim n x)- setLevel n (TremoloT (v,x)) = TremoloT (v, setLevel n x)-instance HasArticulation a => HasArticulation (TremoloT a) where- setEndSlur n (TremoloT (v,x)) = TremoloT (v, setEndSlur n x)- setContSlur n (TremoloT (v,x)) = TremoloT (v, setContSlur n x)- setBeginSlur n (TremoloT (v,x)) = TremoloT (v, setBeginSlur n x)- setAccLevel n (TremoloT (v,x)) = TremoloT (v, setAccLevel n x)- setStaccLevel n (TremoloT (v,x)) = TremoloT (v, setStaccLevel n x)-instance HasTremolo (TremoloT a) where- setTrem n (TremoloT (_,x)) = TremoloT (n,x)-instance HasHarmonic a => HasHarmonic (TremoloT a) where- setHarmonic n (TremoloT (v,x)) = TremoloT (v, setHarmonic n x)-instance HasSlide a => HasSlide (TremoloT a) where- setBeginGliss n (TremoloT (v,x)) = TremoloT (v, setBeginGliss n x)- setBeginSlide n (TremoloT (v,x)) = TremoloT (v, setBeginSlide n x)- setEndGliss n (TremoloT (v,x)) = TremoloT (v, setEndGliss n x)- setEndSlide n (TremoloT (v,x)) = TremoloT (v, setEndSlide n x)-instance HasText a => HasText (TremoloT a) where- addText s (TremoloT (n,x)) = TremoloT (n,addText s x)----- TextT---- newtype TextT a = TextT { getTextT :: (Int, a) }--instance HasMidi a => HasMidi (TextT a) where- getMidi (TextT (_,x)) = getMidi x-instance HasMusicXml a => HasMusicXml (TextT a) where- getMusicXml d (TextT (s,x)) = notate s $ getMusicXml d x- where - notate ts a = (mconcat $ fmap Xml.text ts) <> a- -instance Tiable a => Tiable (TextT a) where- toTied (TextT (n,a)) = (TextT (n,b), TextT (mempty,c)) where (b,c) = toTied a-instance HasVoice a => HasVoice (TextT a) where - type Voice (TextT a) = Voice a- getVoice (TextT (_,a)) = getVoice a- modifyVoice f (TextT (n,x)) = TextT (n, modifyVoice f x)-instance HasPitch a => HasPitch (TextT a) where - type Pitch (TextT a) = Pitch a- getPitch (TextT (_,a)) = getPitch a- modifyPitch f (TextT (n,x)) = TextT (n, modifyPitch f x)-instance IsPitch a => IsPitch (TextT a) where- fromPitch l = TextT (mempty, fromPitch l)-instance IsDynamics a => IsDynamics (TextT a) where- fromDynamics l = TextT (mempty, fromDynamics l)-instance HasDynamic a => HasDynamic (TextT a) where- setBeginCresc n (TextT (v,x)) = TextT (v, setBeginCresc n x)- setEndCresc n (TextT (v,x)) = TextT (v, setEndCresc n x)- setBeginDim n (TextT (v,x)) = TextT (v, setBeginDim n x)- setEndDim n (TextT (v,x)) = TextT (v, setEndDim n x)- setLevel n (TextT (v,x)) = TextT (v, setLevel n x)-instance HasArticulation a => HasArticulation (TextT a) where- setEndSlur n (TextT (v,x)) = TextT (v, setEndSlur n x)- setContSlur n (TextT (v,x)) = TextT (v, setContSlur n x)- setBeginSlur n (TextT (v,x)) = TextT (v, setBeginSlur n x)- setAccLevel n (TextT (v,x)) = TextT (v, setAccLevel n x)- setStaccLevel n (TextT (v,x)) = TextT (v, setStaccLevel n x)-instance HasTremolo a => HasTremolo (TextT a) where- setTrem n (TextT (s,x)) = TextT (s,setTrem n x)-instance HasHarmonic a => HasHarmonic (TextT a) where- setHarmonic n (TextT (v,x)) = TextT (v, setHarmonic n x)-instance HasSlide a => HasSlide (TextT a) where- setBeginGliss n (TextT (v,x)) = TextT (v, setBeginGliss n x)- setBeginSlide n (TextT (v,x)) = TextT (v, setBeginSlide n x)- setEndGliss n (TextT (v,x)) = TextT (v, setEndGliss n x)- setEndSlide n (TextT (v,x)) = TextT (v, setEndSlide n x)-instance HasText (TextT a) where- addText s (TextT (t,x)) = TextT (t ++ [s],x)- ---- HarmonicT--instance HasMidi a => HasMidi (HarmonicT a) where- getMidi (HarmonicT (_,x)) = getMidi x-instance HasMusicXml a => HasMusicXml (HarmonicT a) where- getMusicXml d (HarmonicT (n,x)) = notate $ getMusicXml d x- where - notate | n /= 0 = Xml.setNoteHead Xml.DiamondNoteHead- | otherwise = id- -- TODO adjust pitch etc- -instance Tiable a => Tiable (HarmonicT a) where- toTied (HarmonicT (n,a)) = (HarmonicT (n,b), HarmonicT (n,c)) where (b,c) = toTied a-instance HasVoice a => HasVoice (HarmonicT a) where - type Voice (HarmonicT a) = Voice a- getVoice (HarmonicT (_,a)) = getVoice a- modifyVoice f (HarmonicT (n,x)) = HarmonicT (n, modifyVoice f x)-instance HasPitch a => HasPitch (HarmonicT a) where - type Pitch (HarmonicT a) = Pitch a- getPitch (HarmonicT (_,a)) = getPitch a- modifyPitch f (HarmonicT (n,x)) = HarmonicT (n, modifyPitch f x)-instance IsPitch a => IsPitch (HarmonicT a) where- fromPitch l = HarmonicT (0, fromPitch l)-instance IsDynamics a => IsDynamics (HarmonicT a) where- fromDynamics l = HarmonicT (0, fromDynamics l)-instance HasDynamic a => HasDynamic (HarmonicT a) where- setBeginCresc n (HarmonicT (v,x)) = HarmonicT (v, setBeginCresc n x)- setEndCresc n (HarmonicT (v,x)) = HarmonicT (v, setEndCresc n x)- setBeginDim n (HarmonicT (v,x)) = HarmonicT (v, setBeginDim n x)- setEndDim n (HarmonicT (v,x)) = HarmonicT (v, setEndDim n x)- setLevel n (HarmonicT (v,x)) = HarmonicT (v, setLevel n x)-instance HasArticulation a => HasArticulation (HarmonicT a) where- setEndSlur n (HarmonicT (v,x)) = HarmonicT (v, setEndSlur n x)- setContSlur n (HarmonicT (v,x)) = HarmonicT (v, setContSlur n x)- setBeginSlur n (HarmonicT (v,x)) = HarmonicT (v, setBeginSlur n x)- setAccLevel n (HarmonicT (v,x)) = HarmonicT (v, setAccLevel n x)- setStaccLevel n (HarmonicT (v,x)) = HarmonicT (v, setStaccLevel n x)-instance HasTremolo a => HasTremolo (HarmonicT a) where- setTrem n (HarmonicT (s,x)) = HarmonicT (s,setTrem n x)-instance HasHarmonic (HarmonicT a) where- setHarmonic n (HarmonicT (_,x)) = HarmonicT (n,x)-instance HasSlide a => HasSlide (HarmonicT a) where- setBeginGliss n (HarmonicT (s,x)) = HarmonicT (s,setBeginGliss n x)- setBeginSlide n (HarmonicT (s,x)) = HarmonicT (s,setBeginSlide n x)- setEndGliss n (HarmonicT (s,x)) = HarmonicT (s,setEndGliss n x)- setEndSlide n (HarmonicT (s,x)) = HarmonicT (s,setEndSlide n x)-instance HasText a => HasText (HarmonicT a) where- addText s (HarmonicT (n,x)) = HarmonicT (n,addText s x)----- SlideT--instance HasMidi a => HasMidi (SlideT a) where- getMidi (SlideT (_,_,a,_,_)) = getMidi a-instance HasMusicXml a => HasMusicXml (SlideT a) where- getMusicXml d (SlideT (eg,es,a,bg,bs)) = notate $ getMusicXml d a- where- notate = neg . nes . nbg . nbs- neg = if es then Xml.endGliss else id- nes = if es then Xml.endSlide else id- nbg = if es then Xml.beginGliss else id- nbs = if es then Xml.beginSlide else id-- -instance Tiable a => Tiable (SlideT a) where- toTied (SlideT (eg,es,a,bg,bs)) = (SlideT (eg, es, b,False,False),- SlideT (False,False,c,bg, bs)) where (b,c) = toTied a-instance HasVoice a => HasVoice (SlideT a) where - type Voice (SlideT a) = Voice a- getVoice (SlideT (eg,es,a,bg,bs)) = getVoice a- modifyVoice f (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,modifyVoice f a,bg,bs)-instance HasPitch a => HasPitch (SlideT a) where - type Pitch (SlideT a) = Pitch a- getPitch (SlideT (eg,es,a,bg,bs)) = getPitch a- modifyPitch f (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,modifyPitch f a,bg,bs)-instance IsPitch a => IsPitch (SlideT a) where- fromPitch l = SlideT (False,False,fromPitch l,False,False)-instance IsDynamics a => IsDynamics (SlideT a) where- fromDynamics l = SlideT (False,False,fromDynamics l,False,False)-instance HasDynamic a => HasDynamic (SlideT a) where- setBeginCresc n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setBeginCresc n a,bg,bs)- setEndCresc n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setEndCresc n a,bg,bs)- setBeginDim n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setBeginDim n a,bg,bs)- setEndDim n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setEndDim n a,bg,bs)- setLevel n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setLevel n a,bg,bs)-instance HasArticulation a => HasArticulation (SlideT a) where- setEndSlur n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setEndSlur n a,bg,bs)- setContSlur n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setContSlur n a,bg,bs)- setBeginSlur n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setBeginSlur n a,bg,bs)- setAccLevel n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setAccLevel n a,bg,bs)- setStaccLevel n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setStaccLevel n a,bg,bs)-instance HasTremolo a => HasTremolo (SlideT a) where- setTrem n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setTrem n a,bg,bs)-instance HasHarmonic a => HasHarmonic (SlideT a) where- setHarmonic n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setHarmonic n a,bg,bs)-instance HasSlide (SlideT a) where- setBeginGliss bg (SlideT (eg,es,a,_,bs)) = SlideT (eg,es,a,bg,bs)- setBeginSlide bs (SlideT (eg,es,a,bg,_)) = SlideT (eg,es,a,bg,bs)- setEndGliss eg (SlideT (_,es,a,bg,bs)) = SlideT (eg,es,a,bg,bs)- setEndSlide es (SlideT (eg,_,a,bg,bs)) = SlideT (eg,es,a,bg,bs)-instance HasText a => HasText (SlideT a) where- addText s (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,addText s a,bg,bs)- ------------------------------------------------------------------------------------------ Num, Integral, Enum and Bounded------------------------------------------------------------------------------------------ VoiceT--instance (Enum v, Eq v, Num a) => Num (VoiceT v a) where- VoiceT (v,a) + VoiceT (_,b) = VoiceT (v,a+b)- VoiceT (v,a) * VoiceT (_,b) = VoiceT (v,a*b)- VoiceT (v,a) - VoiceT (_,b) = VoiceT (v,a-b)- abs (VoiceT (v,a)) = VoiceT (v,abs a)- signum (VoiceT (v,a)) = VoiceT (v,signum a)- fromInteger a = VoiceT (toEnum 0,fromInteger a)- -instance (Enum v, Enum a) => Enum (VoiceT v a) where- toEnum a = VoiceT (toEnum 0, toEnum a) -- TODO use def, mempty or minBound?- fromEnum (VoiceT (v,a)) = fromEnum a--instance (Enum v, Bounded a) => Bounded (VoiceT v a) where- minBound = VoiceT (toEnum 0, minBound)- maxBound = VoiceT (toEnum 0, maxBound)--instance (Enum v, Ord v, Num a, Ord a, Real a) => Real (VoiceT v a) where- toRational (VoiceT (v,a)) = toRational a--instance (Enum v, Ord v, Real a, Enum a, Integral a) => Integral (VoiceT v a) where- VoiceT (v,a) `quotRem` VoiceT (_,b) = (VoiceT (v,q), VoiceT (v,r)) where (q,r) = a `quotRem` b- toInteger (VoiceT (v,a)) = toInteger a----- TieT--instance Num a => Num (TieT a) where- TieT (et,a,bt) + TieT (_,b,_) = TieT (et,a+b,bt)- TieT (et,a,bt) * TieT (_,b,_) = TieT (et,a*b,bt)- TieT (et,a,bt) - TieT (_,b,_) = TieT (et,a-b,bt)- abs (TieT (et,a,bt)) = TieT (et,abs a,bt)- signum (TieT (et,a,bt)) = TieT (et,signum a,bt)- fromInteger a = TieT (False,fromInteger a,False)- -instance Enum a => Enum (TieT a) where- toEnum a = TieT (False,toEnum a,False) - fromEnum (TieT (_,a,_)) = fromEnum a--instance Bounded a => Bounded (TieT a) where- minBound = TieT (False,minBound,False)- maxBound = TieT (False,maxBound,False)--instance (Num a, Ord a, Real a) => Real (TieT a) where- toRational (TieT (_,a,_)) = toRational a--instance (Real a, Enum a, Integral a) => Integral (TieT a) where- TieT (et,a,bt) `quotRem` TieT (_,b,_) = (TieT (et,q,bt), TieT (et,r,bt)) where (q,r) = a `quotRem` b- toInteger (TieT (_,a,_)) = toInteger a----- DynamicT--instance Num a => Num (DynamicT a) where- DynamicT (p,q,r,a,s,t) + DynamicT (_,_,_,b,_,_) = DynamicT (p,q,r,a+b,s,t)- DynamicT (p,q,r,a,s,t) * DynamicT (_,_,_,b,_,_) = DynamicT (p,q,r,a*b,s,t)- DynamicT (p,q,r,a,s,t) - DynamicT (_,_,_,b,_,_) = DynamicT (p,q,r,a-b,s,t)- abs (DynamicT (p,q,r,a,s,t)) = DynamicT (p,q,r,abs a,s,t)- signum (DynamicT (p,q,r,a,s,t)) = DynamicT (p,q,r,signum a,s,t)- fromInteger a = DynamicT (False,False,Nothing,fromInteger a,False,False)- -instance Enum a => Enum (DynamicT a) where- toEnum a = DynamicT (False,False,Nothing,toEnum a,False,False) - fromEnum (DynamicT (_,_,_,a,_,_)) = fromEnum a--instance Bounded a => Bounded (DynamicT a) where- minBound = DynamicT (False,False,Nothing,minBound,False,False)- maxBound = DynamicT (False,False,Nothing,maxBound,False,False)--instance (Num a, Ord a, Real a) => Real (DynamicT a) where- toRational (DynamicT (_,_,_,a,_,_)) = toRational a--instance (Real a, Enum a, Integral a) => Integral (DynamicT a) where- DynamicT (p,q,r,a,s,t) `quotRem` DynamicT (_,_,_,b,_,_) = (DynamicT (p,q,r,q',s,t), DynamicT (p,q,r,r',s,t)) where (q',r') = a `quotRem` b- toInteger (DynamicT (_,_,_,a,_,_)) = toInteger a----- ArticulationT--instance Num a => Num (ArticulationT a) where- ArticulationT (p,q,r,s,a,t) + ArticulationT (_,_,_,_,b,_) = ArticulationT (p,q,r,s,a+b,t)- ArticulationT (p,q,r,s,a,t) * ArticulationT (_,_,_,_,b,_) = ArticulationT (p,q,r,s,a*b,t)- ArticulationT (p,q,r,s,a,t) - ArticulationT (_,_,_,_,b,_) = ArticulationT (p,q,r,s,a-b,t)- abs (ArticulationT (p,q,r,s,a,t)) = ArticulationT (p,q,r,s,abs a,t)- signum (ArticulationT (p,q,r,s,a,t)) = ArticulationT (p,q,r,s,signum a,t)- fromInteger a = ArticulationT (False,False,0,0,fromInteger a,False)- -instance Enum a => Enum (ArticulationT a) where- toEnum a = ArticulationT (False,False,0,0,toEnum a,False) - fromEnum (ArticulationT (_,_,_,_,a,_)) = fromEnum a--instance Bounded a => Bounded (ArticulationT a) where- minBound = ArticulationT (False,False,0,0,minBound,False)- maxBound = ArticulationT (False,False,0,0,maxBound,False)--instance (Num a, Ord a, Real a) => Real (ArticulationT a) where- toRational (ArticulationT (_,_,_,_,a,_)) = toRational a--instance (Real a, Enum a, Integral a) => Integral (ArticulationT a) where- ArticulationT (p,q,r,s,a,t) `quotRem` ArticulationT (_,_,_,_,b,_) = (ArticulationT (p,q,r,s,q',t), ArticulationT (p,q,r,s,r',t)) where (q',r') = a `quotRem` b- toInteger (ArticulationT (_,_,_,_,a,_)) = toInteger a----- TremoloT--instance Num a => Num (TremoloT a) where- TremoloT (v,a) + TremoloT (_,b) = TremoloT (v,a+b)- TremoloT (v,a) * TremoloT (_,b) = TremoloT (v,a*b)- TremoloT (v,a) - TremoloT (_,b) = TremoloT (v,a-b)- abs (TremoloT (v,a)) = TremoloT (v,abs a)- signum (TremoloT (v,a)) = TremoloT (v,signum a)- fromInteger a = TremoloT (toEnum 0,fromInteger a)- -instance Enum a => Enum (TremoloT a) where- toEnum a = TremoloT (0, toEnum a) -- TODO use def, mempty or minBound?- fromEnum (TremoloT (v,a)) = fromEnum a--instance Bounded a => Bounded (TremoloT a) where- minBound = TremoloT (0, minBound)- maxBound = TremoloT (0, maxBound)--instance (Num a, Real a) => Real (TremoloT a) where- toRational (TremoloT (_,a)) = toRational a--instance (Real a, Enum a, Integral a) => Integral (TremoloT a) where- TremoloT (v,a) `quotRem` TremoloT (_,b) = (TremoloT (v,q), TremoloT (v,r)) where (q,r) = a `quotRem` b- toInteger (TremoloT (_,a)) = toInteger a----- TextT--instance Num a => Num (TextT a) where- TextT (v,a) + TextT (_,b) = TextT (v,a+b)- TextT (v,a) * TextT (_,b) = TextT (v,a*b)- TextT (v,a) - TextT (_,b) = TextT (v,a-b)- abs (TextT (v,a)) = TextT (v,abs a)- signum (TextT (v,a)) = TextT (v,signum a)- fromInteger a = TextT (mempty,fromInteger a)- -instance Enum a => Enum (TextT a) where- toEnum a = TextT (mempty, toEnum a) -- TODO use def, mempty or minBound?- fromEnum (TextT (v,a)) = fromEnum a--instance Bounded a => Bounded (TextT a) where- minBound = TextT (mempty, minBound)- maxBound = TextT (mempty, maxBound)--instance (Num a, Ord a, Real a) => Real (TextT a) where- toRational (TextT (v,a)) = toRational a--instance (Real a, Enum a, Integral a) => Integral (TextT a) where- TextT (v,a) `quotRem` TextT (_,b) = (TextT (v,q), TextT (v,r)) where (q,r) = a `quotRem` b- toInteger (TextT (v,a)) = toInteger a----- HarmonicT--instance Num a => Num (HarmonicT a) where- HarmonicT (v,a) + HarmonicT (_,b) = HarmonicT (v,a+b)- HarmonicT (v,a) * HarmonicT (_,b) = HarmonicT (v,a*b)- HarmonicT (v,a) - HarmonicT (_,b) = HarmonicT (v,a-b)- abs (HarmonicT (v,a)) = HarmonicT (v,abs a)- signum (HarmonicT (v,a)) = HarmonicT (v,signum a)- fromInteger a = HarmonicT (toEnum 0,fromInteger a)- -instance Enum a => Enum (HarmonicT a) where- toEnum a = HarmonicT (0, toEnum a) -- TODO use def, mempty or minBound?- fromEnum (HarmonicT (v,a)) = fromEnum a--instance Bounded a => Bounded (HarmonicT a) where- minBound = HarmonicT (0, minBound)- maxBound = HarmonicT (0, maxBound)--instance (Num a, Ord a, Real a) => Real (HarmonicT a) where- toRational (HarmonicT (v,a)) = toRational a--instance (Real a, Enum a, Integral a) => Integral (HarmonicT a) where- HarmonicT (v,a) `quotRem` HarmonicT (_,b) = (HarmonicT (v,q), HarmonicT (v,r)) where (q,r) = a `quotRem` b- toInteger (HarmonicT (v,a)) = toInteger a----- SlideT--instance Num a => Num (SlideT a) where- SlideT (eg,es,a,bg,bs) + SlideT (_,_,b,_,_) = SlideT (eg,es,a+b,bg,bs)- SlideT (eg,es,a,bg,bs) * SlideT (_,_,b,_,_) = SlideT (eg,es,a*b,bg,bs)- SlideT (eg,es,a,bg,bs) - SlideT (_,_,b,_,_) = SlideT (eg,es,a-b,bg,bs)- abs (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,abs a,bg,bs)- signum (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,signum a,bg,bs)- fromInteger a = SlideT (False,False,fromInteger a,False,False)- -instance Enum a => Enum (SlideT a) where- toEnum a = SlideT (False,False,toEnum a,False,False)- fromEnum (SlideT (_,_,a,_,_)) = fromEnum a--instance Bounded a => Bounded (SlideT a) where- minBound = SlideT (False,False,minBound,False,False)- maxBound = SlideT (False,False,maxBound,False,False) --instance (Num a, Ord a, Real a) => Real (SlideT a) where- toRational (SlideT (_,_,a,_,_)) = toRational a--instance (Real a, Enum a, Integral a) => Integral (SlideT a) where- SlideT (eg,es,a,bg,bs) `quotRem` SlideT (_,_,b,_,_) = (SlideT (eg,es,q',bg,bs), SlideT (eg,es,r',bg,bs)) where (q',r') = a `quotRem` b- toInteger (SlideT (_,_,a,_,_)) = toInteger a------------------------------------------------------------------------------------------- Literals----------------------------------------------------------------------------------------instance IsPitch Double where- fromPitch (PitchL (pc, sem, oct)) = fromIntegral $ semitones sem + diatonic pc + (oct+1) * 12- where- semitones = maybe 0 round- diatonic pc = case pc of- 0 -> 0- 1 -> 2- 2 -> 4- 3 -> 5- 4 -> 7- 5 -> 9- 6 -> 11--instance IsPitch Integer where- fromPitch (PitchL (pc, sem, oct)) = fromIntegral $ semitones sem + diatonic pc + (oct+1) * 12- where- semitones = maybe 0 round- diatonic pc = case pc of- 0 -> 0- 1 -> 2- 2 -> 4- 3 -> 5- 4 -> 7- 5 -> 9- 6 -> 11--instance IsDynamics Double where- fromDynamics (DynamicsL (Just x, _)) = x- fromDynamics (DynamicsL (Nothing, _)) = error "IsDynamics Double: No dynamics"---data Alteration = Sh | Fl-sharp = Sh-flat = Fl-instance IsPitch (Alteration -> Double) where- fromPitch l Sh = fromPitch l + 1- fromPitch l Fl = fromPitch l - 1-instance IsPitch (Alteration -> Integer) where- fromPitch l Sh = fromPitch l + 1- fromPitch l Fl = fromPitch l - 1-instance IsPitch (Alteration -> a) => IsPitch (Alteration -> Score a) where- fromPitch l a = (pure . fromPitch l) a-- ----------------------------------------------------------------------------------------- Test stuff-----------------------------------------------------------------------------------------type Fun a = a -> a-type Sc a = Score (VoiceT Int (TieT (TremoloT (DynamicT (ArticulationT a)))))--score :: Fun (Sc Double)-score = id --open = openXml . score-----------------------------------------------------------------------------------------list z f [] = z-list z f xs = f xs--first f (x,y) = (f x, y)-second f (x,y) = (x, f y)--sep :: a -> [a] -> [a]-sep = List.intersperse--concatSep :: [a] -> [[a]] -> [a]-concatSep x = List.concat . sep x---- Score filtering generalized to MonadPlus (TODO move!)---- | --- Generalizes the 'remove' function.--- -mremove :: MonadPlus m => (a -> Bool) -> m a -> m a-mremove p = mfilter (not . p)---- | --- Generalizes the 'partition' function.--- -mpartition :: MonadPlus m => (a -> Bool) -> m a -> (m a, m a)-mpartition p a = (mfilter p a, mremove p a)---- | --- Pass through @Just@ occurrences.--- Generalizes the 'catMaybes' function.--- -mcatMaybes :: MonadPlus m => m (Maybe a) -> m a-mcatMaybes = (>>= maybe mzero return)---- | --- Modify or discard a value.--- Generalizes the 'mapMaybe' function.--- -mmapMaybe :: MonadPlus m => (a -> Maybe b) -> m a -> m b-mmapMaybe f = mcatMaybes . liftM f ---- | --- Group a list into sublists whereever a predicate holds. The matched element--- is the first in the sublist.------ > splitWhile isSpace "foo bar baz"--- > ===> ["foo"," bar"," baz"]--- >--- > splitWhile (> 3) [1,5,4,7,0,1,2]--- > ===> [[1],[5],[4],[7,0,1,2]]----splitWhile :: (a -> Bool) -> [a] -> [[a]]-splitWhile p xs = case splitWhile' p xs of- []:xss -> xss- xss -> xss- where- splitWhile' p [] = [[]]- splitWhile' p (x:xs) = case splitWhile' p xs of- (xs:xss) -> if p x then []:(x:xs):xss else (x:xs):xss--execute :: FilePath -> [String] -> IO ()-execute program args = do- forkProcess $ executeFile program True args Nothing- return ()--single x = [x] -fmap2 = fmap . fmap-fmap3 = fmap . fmap . fmap--dump = mapM putStrLn . fmap show--left f (Left x) = Left (f x)-left f (Right y) = Right y--mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]-mergeBy f as bs = List.sortBy f $ as <> bs-+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ DeriveDataTypeable,+ GeneralizedNewtypeDeriving,+ FlexibleInstances,+ FlexibleContexts,+ ConstraintKinds,+ TypeOperators,+ OverloadedStrings,+ NoMonomorphismRestriction #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Provides a musical score representation.+--+-------------------------------------------------------------------------------------++module Music.Score (+ -- * Prerequisites+ module Control.Monad,+ module Control.Monad.Plus,+ module Data.Semigroup,+ module Data.VectorSpace,+ module Data.AffineSpace,++ -- * Basic types+ module Music.Pitch.Literal,+ module Music.Dynamics.Literal,+ module Music.Time,++ -- * Musical container types+ module Music.Score.Track,+ module Music.Score.Voice,+ module Music.Score.Score,++ -- * Manipulation+ module Music.Score.Combinators,+ module Music.Score.Zip,+ module Music.Score.Part,+ module Music.Score.Ties,+ module Music.Score.Pitch,+ module Music.Score.Dynamics,+ module Music.Score.Articulation,+ module Music.Score.Ornaments,++ -- * Export+ module Music.Score.Export.Midi,+ module Music.Score.Export.Lilypond,+ module Music.Score.Export.MusicXml,+)+where++import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)++import Data.Semigroup+import Data.Ratio+import Control.Applicative+import Control.Monad hiding (mapM)+import Control.Monad.Plus+import Data.Maybe+import Data.Either+import Data.Foldable+import Data.Typeable+import Data.Traversable+import Data.VectorSpace hiding (Sum, getSum)+import Data.AffineSpace+import Data.Basis++import Music.Time+import Music.Pitch.Literal+import Music.Dynamics.Literal++import Music.Score.Rhythm+import Music.Score.Track+import Music.Score.Voice+import Music.Score.Score+import Music.Score.Combinators+import Music.Score.Zip+import Music.Score.Pitch+import Music.Score.Ties+import Music.Score.Part+import Music.Score.Articulation+import Music.Score.Dynamics+import Music.Score.Ornaments+import Music.Score.Instances+import Music.Score.Export.Midi+import Music.Score.Export.Lilypond+import Music.Score.Export.MusicXml
src/Music/Score/Articulation.hs view
@@ -1,10 +1,14 @@- + {-# LANGUAGE TypeFamilies, DeriveFunctor, DeriveFoldable,+ DeriveDataTypeable, FlexibleInstances,- GeneralizedNewtypeDeriving #-} + FlexibleContexts,+ ConstraintKinds,+ GeneralizedNewtypeDeriving,+ NoMonomorphismRestriction #-} ------------------------------------------------------------------------------------- -- |@@ -16,7 +20,7 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) ----- Provides a musical score represenation.+-- Provides articulation. -- ------------------------------------------------------------------------------------- @@ -24,10 +28,10 @@ module Music.Score.Articulation ( HasArticulation(..), ArticulationT(..),- + -- ** Accents accent,- marcato, + marcato, accentLast, marcatoLast, accentAll,@@ -40,24 +44,24 @@ portato, legato, spiccato,- + -- ** Miscellaneous resetArticulation,- + ) where import Data.Ratio import Data.Foldable+import Data.Typeable import Data.Semigroup import qualified Data.List as List import Data.VectorSpace import Data.AffineSpace -import Music.Score.Part-import Music.Score.Score-import Music.Score.Duration-import Music.Score.Time import Music.Score.Voice+import Music.Score.Score+import Music.Time+import Music.Score.Part import Music.Score.Combinators class HasArticulation a where@@ -66,9 +70,9 @@ setEndSlur :: Bool -> a -> a setAccLevel :: Int -> a -> a setStaccLevel :: Int -> a -> a- + newtype ArticulationT a = ArticulationT { getArticulationT :: (Bool, Bool, Int, Int, a, Bool) }- deriving (Eq, Show, Ord, Functor, Foldable)+ deriving (Eq, Show, Ord, Functor, Foldable, Typeable) -------------------------------------------------------------------------------- -- Articulation@@ -76,74 +80,35 @@ -- Accents -accent :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a-accent = mapSep (setAccLevel 1) id id--marcato :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a-marcato = mapSep (setAccLevel 2) id id--accentAll :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a-accentAll = mapSep (setAccLevel 1) (setAccLevel 1) (setAccLevel 1)--marcatoAll :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a-marcatoAll = mapSep (setAccLevel 2) (setAccLevel 2) (setAccLevel 2)--accentLast :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a-accentLast = mapSep id id (setAccLevel 1)--marcatoLast :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a-marcatoLast = mapSep id id (setAccLevel 2)+accent :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a+marcato :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a+accentAll :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a+marcatoAll :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a+accentLast :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a+marcatoLast :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a+accent = mapPhrase (setAccLevel 1) id id+marcato = mapPhrase (setAccLevel 2) id id+accentAll = mapPhrase (setAccLevel 1) (setAccLevel 1) (setAccLevel 1)+marcatoAll = mapPhrase (setAccLevel 2) (setAccLevel 2) (setAccLevel 2)+accentLast = mapPhrase id id (setAccLevel 1)+marcatoLast = mapPhrase id id (setAccLevel 2) -- Phrasing -tenuto :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a-tenuto = mapSep (setStaccLevel (-2)) (setStaccLevel (-2)) (setStaccLevel (-2)) --separated :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a-separated = mapSep (setStaccLevel (-1)) (setStaccLevel (-1)) (setStaccLevel (-1)) --staccato :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a-staccato = mapSep (setStaccLevel 1) (setStaccLevel 1) (setStaccLevel 1) --portato :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a-portato = staccato . legato --legato :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a-legato = mapSep (setBeginSlur True) id (setEndSlur True) --spiccato :: (HasArticulation a, HasVoice a, Ord v, v ~ Voice a) => Score a -> Score a-spiccato = mapSep (setStaccLevel 2) (setStaccLevel 2) (setStaccLevel 2) +tenuto :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a+separated :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a+staccato :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a+portato :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a+legato :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a+spiccato :: (HasEvents s, HasPart' a, HasArticulation a) => s a -> s a+tenuto = mapPhrase (setStaccLevel (-2)) (setStaccLevel (-2)) (setStaccLevel (-2))+separated = mapPhrase (setStaccLevel (-1)) (setStaccLevel (-1)) (setStaccLevel (-1))+staccato = mapPhrase (setStaccLevel 1) (setStaccLevel 1) (setStaccLevel 1)+portato = staccato . legato+legato = mapPhrase (setBeginSlur True) id (setEndSlur True)+spiccato = mapPhrase (setStaccLevel 2) (setStaccLevel 2) (setStaccLevel 2) resetArticulation :: HasArticulation c => c -> c resetArticulation = setBeginSlur False . setContSlur False . setEndSlur False . setAccLevel 0 . setStaccLevel 0------ FIXME consolidate---- | --- Map over first, middle and last elements of list.--- Biased on first, then on first and last for short lists.--- -mapSepL :: (a -> b) -> (a -> b) -> (a -> b) -> [a] -> [b]-mapSepL f g h [] = []-mapSepL f g h [a] = [f a]-mapSepL f g h [a,b] = [f a, h b]-mapSepL f g h xs = [f $ head xs] ++ (map g $ tail $ init xs) ++ [h $ last xs]--mapSep :: (HasVoice a, Ord v, v ~ Voice a) => (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b-mapSep f g h sc = fixDur . mapVoices (fmap $ mapSepPart f g h) $ sc- where- fixDur a = padAfter (duration sc - duration a) a--mapSepPart :: (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b-mapSepPart f g h sc = mconcat . mapSepL (fmap f) (fmap g) (fmap h) . fmap toSc . perform $ sc- where - fixDur a = padAfter (duration sc - duration a) a- toSc (t,d,x) = delay (t .-. 0) . stretch d $ note x- third f (a,b,c) = (a,b,f c)--padAfter :: Duration -> Score a -> Score a-padAfter d a = a |> (rest^*d)
+ src/Music/Score/Chord.hs view
@@ -0,0 +1,72 @@++{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ DeriveDataTypeable,+ FlexibleInstances,+ FlexibleContexts,+ ConstraintKinds,+ GeneralizedNewtypeDeriving,+ NoMonomorphismRestriction #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Provides articulation.+--+-------------------------------------------------------------------------------------+++module Music.Score.Chord (+ HasChord(..),+ ChordT(..),+ flatten,+ ) where++import Data.Ratio+import Data.Foldable+import Data.Typeable+import Data.Semigroup+import Data.VectorSpace+import Data.AffineSpace+import Control.Monad.Plus++import Music.Score.Voice+import Music.Score.Score+import Music.Time+import Music.Score.Part+import Music.Score.Pitch+import Music.Score.Combinators++class HasChord a where+ type ChordNote a :: *+ getChord :: a -> [ChordNote a]++-- Actually we should use NonEmpty here+-- Empty chords will cause error with HasPitch, among others+newtype ChordT a = ChordT { getChordT :: [a] }+ deriving (Eq, Show, Ord, Functor, Foldable, Typeable)++-- instance HasChord ++-- Score a -> Score (ChordT a)++-- Note: +--+-- The HasChord instance (for various types) takes care to transform strucuture *above* the chord representation+-- In particular, getChord will extract the chord from below and transform each note (or only the first etc) +-- as appropriate for the given type.+-- The ChordT instances transforms structure *below* the chord representation++flatten :: (MonadPlus m, HasChord a) => m a -> m (ChordNote a)+flatten = mscatter . liftM getChord++
src/Music/Score/Combinators.hs view
@@ -1,11 +1,16 @@- + {-# LANGUAGE+ CPP, TypeFamilies, DeriveFunctor, DeriveFoldable, FlexibleInstances,+ FlexibleContexts,+ ConstraintKinds, OverloadedStrings,- GeneralizedNewtypeDeriving #-} + MultiParamTypeClasses,+ NoMonomorphismRestriction,+ GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------------- -- |@@ -17,29 +22,29 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) ----- Provides a musical score represenation.+-- Combinators for manipulating scores. -- ------------------------------------------------------------------------------------- module Music.Score.Combinators (- -- ** Constructing scores- rest,- note,- chord,- melody,+ -- ** Preliminaries+ Monoid',+ Transformable1,+ Transformable,+ Composable,+ HasEvents, -- ** Composing scores (|>), (<|), scat, pcat,- + -- *** Special composition sustain,- overlap, anticipate,- + -- ** Transforming scores -- *** Moving in time move,@@ -51,157 +56,272 @@ stretch, compress, stretchTo,- - -- ** Zipper- apply,- sample,- trig,- applySingle,- sampleSingle, - - -- *** Structure- - repTimes,- repWith,- repWithIndex,- repWithTime,++ -- *** Rests+ rest,+ removeRests,++ -- *** Repetition+ times,+ repeated, group,- groupWith,- scatMap,- rev, - before,- first,- butFirst,+ -- triplet,+ -- quadruplet,+ -- quintuplet, - + -- *** Transformations+ perform,+ compose,+ retrograde,+ mapEvents,+ filterEvents,+ mapFilterEvents,+ mapAllEvents,+ mapEventsSingle,+ mapFirst,+ mapLast,+ mapPhrase,+ mapPhraseSingle,+ -- ** Conversion- scoreToTrack,- scoreToPart,- scoreToParts,- partToScore,- trackToScore,+ scoreToVoice,+ voiceToScore,+ voiceToScore',+ eventToScore, ) where -import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)--import Control.Monad (ap, mfilter, join, liftM, MonadPlus(..))+import Control.Monad+import Control.Monad.Plus import Data.Semigroup import Data.String-import Data.Foldable+import Data.Foldable (Foldable) import Data.Traversable-import qualified Data.List as List import Data.VectorSpace import Data.AffineSpace-import Data.Ratio +import Data.Ratio+import Data.Pointed import Data.Ord import Music.Score.Track-import Music.Score.Part-import Music.Score.Score-import Music.Score.Duration-import Music.Score.Time-import Music.Score.Ties import Music.Score.Voice+import Music.Score.Score+import Music.Score.Part+import Music.Time +import qualified Data.List as List +-- |+-- This pseudo-class can be used in place of 'Monoid' whenever an additional 'Semigroup'+-- constraint is needed.+--+-- Ideally, 'Monoid' should be changed to extend 'Semigroup' instead.+--+type Monoid' a = (Monoid a, Semigroup a)++-- TODO names?+type Scalable t d a = (+ Stretchable a, Delayable a,+ AdditiveGroup t,+ AffineSpace t,+ Diff t ~ d,+ Time a ~ t,+ Duration a ~ d+ )++-- |+-- This class includes time-based structures that can be scaled and moved in time.+--+class (+ Stretchable s, Delayable s,+ AdditiveGroup (Time s), AffineSpace (Time s)+ ) => Transformable1 s where++instance Transformable1 Score+instance Transformable1 Track+instance (Transformable1 a, t ~ Time a) => Transformable1 (AddOffset t a)++++-- |+-- This class includes time-based structures with a known position in time.+--+class (+ HasOnset s, HasOffset s,+ Transformable1 s+ ) => Transformable s where++{-+type Transformable t d a = (+ Stretchable a, Delayable a,+ AdditiveGroup t,+ AffineSpace t,+ HasOnset a, HasOffset a,+ Time a ~ t,+ Duration a ~ d+ )+-}++instance Transformable Score+instance (Transformable a, t ~ Time a) => Transformable (AddOffset t a)++-- |+-- This class includes time-based structures that can be transcribed.+--+class (+ MonadPlus s,+ Transformable s+ ) => Composable s where++instance Composable Score+-- instance Composable Track++-- |+-- This class includes time-based structures that can be perfomed /and/ transcribed.+--+-- The combined power of 'perform' and 'compose' give us the power to traverse and+-- the entire event structure, as per 'mapEvents'.+--+class (+ Performable s,+ Composable s+ ) => HasEvents s where++{-+type HasEvents t d s a = (+ Performable s,+ MonadPlus s,+ Transformable t d (s a)+ )+-}++instance HasEvents Score++ ------------------------------------------------------------------------------------- -- Constructors ------------------------------------------------------------------------------------- --- | Creates a score containing the given elements, composed in sequence.-melody :: [a] -> Score a-melody = scat . map note+-- |+-- Create a score containing a single event.+--+-- This function uses the unit position (0, 1).+--+-- > a -> Score a+--+note :: Monad s => a -> s a+note = return --- | Creates a score containing the given elements, composed in parallel.-chord :: [a] -> Score a-chord = pcat . map note+-- |+-- Create a score containing a rest at time zero of duration one.+--+-- This function uses the unit position (0, 1).+--+-- > Score (Maybe a)+--+rest :: MonadPlus s => s (Maybe a)+rest = note Nothing --- | Creates a score from a the given melodies, composed in parallel.-melodies :: [[a]] -> Score a-melodies = pcat . map melody+-- |+-- Create a note or a rest. This is an alias for 'mfromMaybe' with a nicer reading.+--+-- This function uses the unit position (0, 1).+--+-- > a -> Score a+--+noteRest :: MonadPlus s => Maybe a -> s a+noteRest = mfromMaybe --- | Creates a score from a the given chords, composed in sequence.-chords :: [[a]] -> Score a-chords = scat . map chord+-- | Creates a score containing a chord.+--+-- This function uses the unit position (0, 1).+--+-- > [a] -> Score a+--+-- chord :: (Pointed s, Monoid (s a)) => [a] -> s a+chord :: (MonadPlus s, Monoid' (s a)) => [a] -> s a+chord = pcat . map note +-- | Creates a score containing the given elements, composed in sequence.+--+-- > [a] -> Score a+--+melody :: (MonadPlus s, Monoid' (s a), Transformable s) => [a] -> s a+melody = scat . map note+ -- | Like 'melody', but stretching each note by the given factors.-melodyStretch :: [(Duration, a)] -> Score a+--+-- > [(Duration, a)] -> Score a+--+melodyStretch :: (MonadPlus s, Monoid' (s a), Transformable s, d ~ Duration s) => [(d, a)] -> s a melodyStretch = scat . map ( \(d, x) -> stretch d $ note x ) -- | Like 'chord', but delays each note the given amounts.-chordDelay :: [(Duration, a)] -> Score a-chordDelay = pcat . map ( \(t, x) -> delay t $ note x )+--+-- > [(Time, a)] -> Score a+--+chordDelay :: (MonadPlus s, Monoid (s a), Transformable s, t ~ Time s) => [(t, a)] -> s a+chordDelay = pcat . map (\(t, x) -> delay' t $ note x) -- | Like 'chord', but delays and stretches each note the given amounts.-chordDelayStretch :: [(Duration, Duration, a)] -> Score a-chordDelayStretch = pcat . map ( \(t, d, x) -> delay t . stretch d $ note x )---- -- | Like chord, but delaying each note the given amount.--- arpeggio :: t -> [a] -> Score a--- arpeggio t xs = chordDelay (zip [0, t ..] xs)-+--+-- > [(Time, Duration, a)] -> Score a+--+chordDelayStretch :: (MonadPlus s, Monoid (s a), Transformable s, d ~ Duration s, t ~ Time s) => [(t, d, a)] -> s a+chordDelayStretch = pcat . map (\(t, d, x) -> delay' t . stretch d $ note x) ------------------------------------------------------------------------------------- -- Transformations ------------------------------------------------------------------------------------- -- |--- Move a score move in time. Equivalent to 'delay'.--- +-- Move a score forward in time. Equivalent to 'delay'.+-- -- > Duration -> Score a -> Score a--- -move :: Delayable a => Duration -> a -> a+--+move :: (Delayable s, d ~ Duration s) => d -> s a -> s a move = delay -- |--- Move a score moveBack in time. Negated verison of 'delay'--- +-- Move a score backward in time. Negated verison of 'delay'+-- -- > Duration -> Score a -> Score a--- -moveBack :: Delayable a => Duration -> a -> a-moveBack t = delay (negate t)+--+moveBack :: (Delayable s, AdditiveGroup d, d ~ Duration s) => d -> s a -> s a+moveBack t = delay (negateV t) -- |--- Stretch a score. Equivalent to '*^'.--- +-- Move a score so that its onset is at the specific time.+-- -- > Duration -> Score a -> Score a--- -stretch :: VectorSpace v => Scalar v -> v -> v-stretch = (*^)+--+startAt :: (HasOnset s, Delayable s, AffineSpace t, t ~ Time s) => t -> s a -> s a+t `startAt` x = (t .-. onset x) `delay` x -- |--- Move a score to start at a specific time.--- +-- Move a score so that its offset is at the specific time.+-- -- > Duration -> Score a -> Score a--- -startAt :: (Delayable a, HasOnset a) => Time -> a -> a-t `startAt` x = delay d x where d = t .-. onset x+--+stopAt :: (HasOffset s, Delayable s, AffineSpace t, t ~ Time s) => t -> s a -> s a+t `stopAt` x = (t .-. offset x) `delay` x -- |--- Move a score to stop at a specific time.--- +-- Compress (diminish) a score. Flipped version of '^/'.+-- -- > Duration -> Score a -> Score a--- -stopAt :: (Delayable a, HasOnset a) => Time -> a -> a-t `stopAt` x = delay d x where d = t .-. offset x+--+compress :: (Stretchable s, Fractional d, d ~ Duration s) => d -> s a -> s a+compress x = stretch (recip x) -- |--- Compress a score. Flipped version of '^/'.--- +-- Stretch a score to fit into the given duration.+-- -- > Duration -> Score a -> Score a--- -compress :: (VectorSpace v, s ~ Scalar v, Fractional s) => s -> v -> v-compress = flip (^/)+--+stretchTo :: (Stretchable s, HasDuration s, Fractional d, d ~ Duration s) => d -> s a -> s a+t `stretchTo` x = (t / duration x) `stretch` x --- | --- Stretch to the given duration. --- --- > Duration -> Score a -> Score a--- -stretchTo :: (VectorSpace a, HasDuration a, Scalar a ~ Duration) => Duration -> a -> a-t `stretchTo` x = (t / duration x) `stretch` x - ------------------------------------------------------------------------------------- -- Composition -------------------------------------------------------------------------------------@@ -215,26 +335,25 @@ -- To compose in parallel, use '<>'. -- -- > Score a -> Score a -> Score a-(|>) :: (Semigroup a, Delayable a, HasOnset a) => a -> a -> a+(|>) :: (Semigroup (s a), AffineSpace (Time s), HasOnset s, HasOffset s, Delayable s) => s a -> s a -> s a a |> b = a <> startAt (offset a) b--- a |< b = a <> stopAt (onset a) b -- |--- Compose in reverse sequence. +-- Compose in reverse sequence. -- -- To compose in parallel, use '<>'. -- -- > Score a -> Score a -> Score a-(<|) :: (Semigroup a, Delayable a, HasOnset a) => a -> a -> a+(<|) :: (Semigroup (s a), AffineSpace (Time s), HasOnset s, HasOffset s, Delayable s) => s a -> s a -> s a a <| b = b |> a -- | -- Sequential concatentation. -- -- > [Score t] -> Score t-scat :: (Monoid a, Delayable a, HasOnset a) => [a] -> a-scat = unwrapMonoid . foldr (|>) mempty . fmap WrapMonoid+scat :: (Monoid' (s a), AffineSpace (Time s), HasOnset s, HasOffset s, Delayable s) => [s a] -> s a+scat = foldr (|>) mempty -- | -- Parallel concatentation. A synonym for 'mconcat'.@@ -243,281 +362,337 @@ pcat :: Monoid a => [a] -> a pcat = mconcat --- infixr 7 <<|--- infixr 7 |>>--- infixr 7 <||--- infixr 7 ||> --- (<||) = sustain--- (||>) = flip sustain--- (|>>) = overlap--- (<<|) = flip overlap ---- | +-- | -- Like '<>', but scaling the second agument to the duration of the first.--- +-- -- > Score a -> Score a -> Score a ---sustain :: (Semigroup a, VectorSpace a, HasDuration a, Scalar a ~ Duration) => a -> a -> a-x `sustain` y = x <> (duration x) `stretchTo` y+sustain :: (Fractional (Duration s), Semigroup (s a), Stretchable s, HasDuration s) => s a -> s a -> s a+x `sustain` y = x <> duration x `stretchTo` y -- Like '<>', but truncating the second agument to the duration of the first. -- prolong x y = x <> before (duration x) y -- |--- Like '|>', but moving second argument halfway to the offset of the first.+-- Like '|>' but with a negative delay on the second element. ----- > Score a -> Score a -> Score a+-- > Duration -> Score a -> Score a -> Score a ---overlap :: (Semigroup a, Delayable a, HasDuration a) => a -> a -> a-x `overlap` y = x <> delay t y where t = duration x / 2 +anticipate :: (Semigroup (s a), Transformable s, d ~ Duration s, Ord d) => d -> s a -> s a -> s a+anticipate t a b = a <> startAt (offset a .-^ t) b --- |--- Like '|>' but with a negative delay on the second element.--- --- > Duration -> Score a -> Score a -> Score a--- -anticipate :: (Semigroup a, Delayable a, HasDuration a, HasOnset a) => Duration -> a -> a -> a-anticipate t x y = x |> delay t' y where t' = (duration x - t) `max` 0 ----------------------------------------------------------------------------------------- Analysis--apply :: (Ord v, v ~ Voice a, HasVoice a) => Part (Score a -> Score b) -> Score a -> Score b-apply x = mapVoices (fmap $ applySingle x)--sample :: (Ord v, v ~ Voice a, HasVoice a) => Score b -> Score a -> Score (b, Score a)-sample x = mapVoices (fmap $ sampleSingle x)--trig :: Score a -> Score b -> Score b-trig p as = mconcat $ toList $ fmap snd $ sampleSingle p as+--------------------------------------------------------------------------------+-- Structure+-------------------------------------------------------------------------------- -applySingle :: Part (Score a -> Score b) -> Score a -> Score b-applySingle fs as = notJoin $ fmap (\(f,s) -> f s) $ sampled- where - -- This is not join; we simply concatenate all inner scores in parallel- notJoin = mconcat . toList- sampled = sampleSingle (partToScore fs) as+-- |+-- Repeat exact amount of times.+--+-- > Duration -> Score Note -> Score Note+--+times :: (Monoid' (s a), Transformable s) => Int -> s a -> s a+times n a = replicate (0 `max` n) () `repeated` const a -- |--- Get all notes that start during a given note.+-- Repeat once for each element in the list. ---sampleSingle :: Score a -> Score b -> Score (a, Score b)-sampleSingle as bs = Score . fmap (\(t,d,a) -> (t,d,g a (onsetIn t d bs))) . getScore $ as- where- g Nothing z = Nothing- g (Just a) z = Just (a,z)+-- Example:+--+-- > repeated [1,2,1] (c^*)+--+-- Simple type:+--+-- > [a] -> (a -> Score Note) -> Score Note+--+repeated :: (Monoid' (s b), Transformable s) => [a] -> (a -> s b) -> s b+repeated = flip (\f -> scat . fmap f) --- | Filter out events that has its onset in the given time interval (inclusive start).--- For example, onset in 1 2 filters events such that (1 <= onset x < 3)-onsetIn :: Time -> Duration -> Score a -> Score a-onsetIn a b = Score . filt (\(t,d,x) -> a <= t && t < a .+^ b) . getScore - where- -- filt = mfilter- filt = takeUntil- -- more lazy than mfilter- --- Take until predicate goes from True to False.-takeUntil :: (a -> Bool) -> [a] -> [a]-takeUntil p as = List.takeWhile p (List.dropWhile (not . p) as)+{-+repeatedIndex n = repeated [0..n-1]+repeatedTime n = repeated $ fmap (/ n) [0..(n - 1)]+-} ----------------------------------------------------------------------------------------- Conversion- -- |--- Convert a score to a track by throwing away durations.+-- Remove rests from a score. ---scoreToTrack :: Score a -> Track a-scoreToTrack = Track . fmap g . perform- where- g (t,d,x) = (t,x)---- |--- Convert a single-part score to a part.+-- This is just an alias for 'mcatMaybes' which reads better in certain contexts. ---scoreToPart :: Score a -> Part (Maybe a)-scoreToPart = Part . fmap g . addRests' . perform- where- g (t,d,x) = (d,x)---- |--- Convert a score to a list of parts.+-- > Score (Maybe a) -> Score a ---scoreToParts :: (HasVoice a, Voice a ~ v, Ord v) => Score a -> [Part (Maybe a)]-scoreToParts = fmap scoreToPart . voices+removeRests :: MonadPlus m => m (Maybe a) -> m a+removeRests = mcatMaybes +-- -- |+-- -- Repeat three times and scale down by three.+-- --+-- -- > Score a -> Score a+-- --+-- triplet :: (Monoid' (s a), Transformable t d s, Time s ~ TimeT) => s a -> s a+-- triplet = group 3+-- +-- -- |+-- -- Repeat three times and scale down by three.+-- --+-- -- > Score a -> Score a+-- --+-- quadruplet :: (Monoid' (s a), Transformable t d s, Time s ~ TimeT) => s a -> s a+-- quadruplet = group 4+-- +-- -- |+-- -- Repeat three times and scale down by three.+-- --+-- -- > Score a -> Score a+-- --+-- quintuplet :: (Monoid' (s a), Transformable t d s, Time s ~ TimeT) => s a -> s a+-- quintuplet = group 5+ -- |--- Convert a part to a score.+-- Repeat a number of times and scale down by the same amount. ---partToScore :: Part a -> Score a-partToScore = scat . fmap g . getPart- where- g (d,x) = stretch d (note x)+-- > Duration -> Score a -> Score a+--+group :: (Monoid' (s a), Transformable s, Time s ~ TimeT) => Int -> s a -> s a+group n a = times n (toDurationT n `compress` a) -- |--- Convert a track to a score. Each note gets an arbitrary duration of one.+-- Reverse a score around its middle point (TODO not correct documentation w.r.t to start). ---trackToScore :: Track a -> Score a-trackToScore = pcat . fmap g . getTrack- where- g (t,x) = delay (t .-. 0) (note x)+-- > onset a = onset (retrograde a)+-- > duration a = duration (retrograde a)+-- > offset a = offset (retrograde a)+--+-- > Score a -> Score a +retrograde :: (HasEvents s, t ~ Time s, Num t, Ord t) => s a -> s a+retrograde = startAt 0 . (mapAllEvents $ List.sortBy (comparing fst3) . fmap g)+ where+ g (t,d,x) = (-(t.+^d),d,x) ----------------------------------------------------------------------------------- Structure+-- Mapping and recomposition -------------------------------------------------------------------------------- --- |--- Repeat exact amount of times.+#define MAP_CONSTRAINT \+ HasPart' a, \+ HasEvents s++-- | Recompose a score. ----- > Duration -> Score Note -> Score Note+-- This is the inverse of 'perform' ---repTimes :: (Enum a, Monoid c, HasOnset c, Delayable c) => a -> c -> c-repTimes n a = replicate (0 `max` fromEnum n) () `repWith` (const a)+-- > [(Time, Duration, a)] -> Score a+--+compose :: (Composable s, d ~ Duration s, t ~ Time s) => [(t, d, a)] -> s a+compose = msum . liftM eventToScore +-- retrograde :: (HasEvents s, t ~ Time s, Num t, Ord t) => s a -> s a+mapAllEvents :: (HasEvents s, d ~ Duration s, t ~ Time s) => ([(t, d, a)] -> [(t, d, b)]) -> s a -> s b+mapAllEvents f = compose . f . perform++{-+mapFilterAllEvents :: (HasEvents s, d ~ Duration s, t ~ Time s) => ([(t, d, a)] -> [(t, d, Maybe b)]) -> s a -> s b+mapFilterAllEvents f = mcatMaybes . mapAllEvents f+-}+ -- |--- Repeat once for each element in the list.+-- Map over the events in a score. ----- > [a] -> (a -> Score Note) -> Score Note+-- > (Time -> Duration -> a -> b) -> Score a -> Score b ----- Example:+filterEvents :: (MAP_CONSTRAINT, t ~ Time s, d ~ Duration s) => (t -> d -> a -> Bool) -> s a -> s a+filterEvents f = mapFilterEvents (partial3 f)+-- TODO Maybe this could be optimized by using mapEventsSingle?++-- |+-- Map over the events in a score. ----- > repWith [1,2,1] (c^*)+-- > (Time -> Duration -> a -> b) -> Score a -> Score b ---repWith :: (Monoid c, HasOnset c, Delayable c) => [a] -> (a -> c) -> c-repWith = flip (\f -> scat . fmap f)+mapFilterEvents :: (MAP_CONSTRAINT, t ~ Time s, d ~ Duration s) => (t -> d -> a -> Maybe b) -> s a -> s b+mapFilterEvents f = mcatMaybes . mapAllParts (liftM $ mapEventsSingle f) -- |--- Combination of 'scat' and 'fmap'. Note that+-- Map over the events in a score. ----- > scatMap = flip repWith+-- > (Time -> Duration -> a -> b) -> Score a -> Score b ---scatMap f = scat . fmap f+mapEvents :: (MAP_CONSTRAINT, t ~ Time s, d ~ Duration s) => (t -> d -> a -> b) -> s a -> s b+mapEvents f = mapAllParts (liftM $ mapEventsSingle f) -- |--- Repeat exact amount of times with an index.+-- Equivalent to 'mapEvents' for single-voice scores.+-- Fails if the score contains overlapping events. ----- > Duration -> (Duration -> Score Note) -> Score Note+-- > (Time -> Duration -> a -> b) -> Score a -> Score b ---repWithIndex :: (Enum a, Num a, Monoid c, HasOnset c, Delayable c) => a -> (a -> c) -> c-repWithIndex n = repWith [0..n-1]+mapEventsSingle :: (HasEvents s, t ~ Time s, d ~ Duration s) => (t -> d -> a -> b) -> s a -> s b+mapEventsSingle f sc = compose . fmap (third' f) . perform $ sc -- |--- Repeat exact amount of times with relative time.+-- Equivalent to 'mapEvents' for single-voice scores.+-- Fails if the score contains overlapping events. ----- > Duration -> (Time -> Score Note) -> Score Note+-- > ([(Time,Duration,a)] -> [b]) -> Score a -> Score b ---repWithTime :: (Enum a, Fractional a, Monoid c, HasOnset c, Delayable c) => a -> (a -> c) -> c-repWithTime n = repWith $ fmap (/ n') [0..(n' - 1)]- where- n' = n+-- mapAllEventsSingle :: (HasEvents s, t ~ Time s, d ~ Duration s) => ([(t,d,a)] -> b) -> s a -> s b+-- mapAllEventsSingle f sc = compose . fmap trd3 . f . perform $ sc+-- mapAllEventsSingle' :: (HasEvents s, t ~ Time s, d ~ Duration s) => ([(t,d,a)] -> [b]) -> s a -> s b+-- mapAllEventsSingle' f = compose . fmap trd3 . f . perform +trd3 (a,b,c) = c++mapAllEventsSingle' :: (HasEvents s, t ~ Time s, d ~ Duration s) => ([(t,d,a)] -> [(t,d,b)]) -> s a -> s b+mapAllEventsSingle' f = compose . f . perform+ -- |--- Repeat a number of times and scale down by the same amount.+-- Map over the first, and remaining notes in each part. ----- > Duration -> Score a -> Score a+-- If a part has only one notes, the first function is applied.+-- If a part has no notes, the given score is returned unchanged. ---group :: (Enum a, Fractional a, a ~ Scalar c, Monoid c, Semigroup c, VectorSpace c, HasOnset c, Delayable c) => a -> c -> c-group n a = repTimes n (a^/n)+-- > (a -> b) -> (a -> b) -> Score a -> Score b+--+mapFirst :: (MAP_CONSTRAINT) => (a -> b) -> (a -> b) -> s a -> s b+mapFirst f g = mapPhrase f g g -- |--- Repeat a number of times and scale down by the same amount.+-- Map over the last, and preceding notes in each part. ----- > [Duration] -> Score a -> Score a+-- If a part has only one notes, the first function is applied.+-- If a part has no notes, the given score is returned unchanged. ---groupWith :: (Enum a, Fractional a, a ~ Scalar c, Monoid c, Semigroup c, VectorSpace c, HasOnset c, Delayable c) => [a] -> c -> c-groupWith = flip $ \p -> scat . fmap (flip group $ p)+-- > (a -> b) -> (a -> b) -> Score a -> Score b+--+mapLast :: (MAP_CONSTRAINT) => (a -> b) -> (a -> b) -> s a -> s b+mapLast f g = mapPhrase g g f -- |--- Reverse a score around its middle point.+-- Map over the first, middle and last note in each part. ----- > onset a = onset (rev a)--- > duration a = duration (rev a)--- > offset a = offset (rev a)+-- If a part has fewer than three notes the first takes precedence over the last,+-- and last takes precedence over the middle. ---rev :: Score a -> Score a-rev = startAt 0 . rev'- where- rev' = Score . List.sortBy (comparing getT) . fmap g . getScore- g (t,d,x) = (-(t.+^d),d,x)- getT (t,d,x) = t+-- > (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b+--+mapPhrase :: (MAP_CONSTRAINT) => (a -> b) -> (a -> b) -> (a -> b) -> s a -> s b+mapPhrase f g h = mapAllParts (liftM $ mapPhraseSingle f g h) -- |--- Repeat indefinately, like repeat for lists.+-- Equivalent to 'mapPhrase' for single-voice scores.+-- Fails if the score contains overlapping events. ----- > Score Note -> Score Note+-- > (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b ---rep :: Score a -> Score a-rep a = a `plus` delay (duration a) (rep a)- where- Score as `plus` Score bs = Score (as <> bs)+mapPhraseSingle :: HasEvents s => (a -> b) -> (a -> b) -> (a -> b) -> s a -> s b+mapPhraseSingle f g h sc = compose . mapFirstMiddleLast (third f) (third g) (third h) . perform $ sc +-- eventToScore :: Scalable t d a => (t, d, a) -> m a -infixl 6 ||>-a ||> b = padToBar a |> b-bar = rest^*4+eventToScore+ :: (Monad s, + Transformable1 s,+ Time s ~ t, Duration s ~ d+ ) => (t, d, a) -> s a -padToBar a = a |> (rest ^* (d' * 4))- where- d = snd $ properFraction $ duration a / 4- d' = if (d == 0) then 0 else (1-d)+eventToScore (t,d,x) = delay' t . stretch d $ return x +--------------------------------------------------------------------------------+-- Conversion+-------------------------------------------------------------------------------- -rotl [] = []-rotl (x:xs) = xs ++ [x]+-- |+-- Convert a score into a voice.+--+-- This function fails if the score contain overlapping events.+--+scoreToVoice :: Score a -> Voice (Maybe a)+scoreToVoice = Voice . fmap throwTime . addRests' . perform+ where+ throwTime (t,d,x) = (d,x) -rotr [] = []-rotr xs = (last xs:init xs)+-- |+-- Convert a voice into a score.+--+voiceToScore :: Voice a -> Score a+voiceToScore = scat . fmap g . getVoice+ where+ g (d,x) = stretch d (note x) -rotated n as | n >= 0 = iterate rotr as !! n- | n < 0 = iterate rotl as !! (abs n)+-- |+-- Convert a voice which may contain rests into a score.+--+voiceToScore' :: Voice (Maybe a) -> Score a+voiceToScore' = mcatMaybes . voiceToScore +-- TODO move this instance+instance Performable Voice where+ perform = perform . voiceToScore -before :: Duration -> Score a -> Score a-before d = trig (on^*d)--first :: Score a -> a-first = get3 . head . perform- where get3 (a,b,c) = c--butFirst :: Score a -> Score a-butFirst = Score . tail . getScore--on :: Score ()-on = note ()+-------------------------------------------------------------------------------- -off :: Score ()-off = rest+addRests' :: [(TimeT, DurationT, a)] -> [(TimeT, DurationT, Maybe a)]+addRests' = concat . snd . mapAccumL g 0+ where+ g u (t, d, x)+ | u == t = (t .+^ d, [(t, d, Just x)])+ | u < t = (t .+^ d, [(u, t .-. u, Nothing), (t, d, Just x)])+ | otherwise = error "addRests: Strange prevTime" +-- |+-- Map over first, middle and last elements of list.+-- Biased on first, then on first and last for short lists.+--+mapFirstMiddleLast :: (a -> b) -> (a -> b) -> (a -> b) -> [a] -> [b]+mapFirstMiddleLast f g h = go+ where+ go [] = []+ go [a] = [f a]+ go [a,b] = [f a, h b]+ go xs = [f $ head xs] ++ + map g (tail $ init xs) ++ + [h $ last xs] -tau = pi*2+delay' t = delay (t .-. zeroV) -splitWhile :: (a -> Bool) -> [a] -> [[a]]-splitWhile p xs = case splitWhile' p xs of- []:xss -> xss- xss -> xss- where- splitWhile' p [] = [[]]- splitWhile' p (x:xs) = case splitWhile' p xs of- (xs:xss) -> if p x then []:(x:xs):xss else (x:xs):xss +fst3 (t, d, x) = t +third f (a,b,c) = (a,b,f c)+third' f (a,b,c) = (a,b,f a b c) +rotl [] = []+rotl (x:xs) = xs ++ [x] +rotr [] = []+rotr xs = last xs : init xs +curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d+curry3 = curry . curry . (. trip) +uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 = (. untrip) . uncurry . uncurry +untrip (a,b,c) = ((a,b),c)+trip ((a,b),c) = (a,b,c) +{-+partial :: (a -> Bool) -> a -> Maybe a +-}+partial2 :: (a -> b -> Bool) -> a -> b -> Maybe b+partial3 :: (a -> b -> c -> Bool) -> a -> b -> c -> Maybe c+partial2 f = curry (fmap snd . partial (uncurry f))+partial3 f = curry3 (fmap trd3 . partial (uncurry3 f)) --- FIXME consolidate-addRests' :: [(Time, Duration, a)] -> [(Time, Duration, Maybe a)]-addRests' = concat . snd . mapAccumL g 0+rotated :: Int -> [a] -> [a]+rotated = go where- g prevTime (t, d, x) - | prevTime == t = (t .+^ d, [(t, d, Just x)])- | prevTime < t = (t .+^ d, [(prevTime, t .-. prevTime, Nothing), (t, d, Just x)])- | otherwise = error "addRests: Strange prevTime"+ go n as + | n >= 0 = iterate rotr as !! n+ | n < 0 = iterate rotl as !! abs n+
− src/Music/Score/Duration.hs
@@ -1,85 +0,0 @@- -{-# LANGUAGE- TypeFamilies,- DeriveFunctor,- DeriveFoldable,- GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------------------ |--- Copyright : (c) Hans Hoglund 2012------ License : BSD-style------ Maintainer : hans@hanshoglund.se--- Stability : experimental--- Portability : non-portable (TF,GNTD)------ Provides a musical score represenation.-------------------------------------------------------------------------------------------module Music.Score.Duration where--import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)--import Data.Semigroup-import Control.Applicative-import Data.Traversable-import Data.Maybe-import Data.Either-import Data.Function (on)-import Data.Ord (comparing)-import Data.Ratio-import Data.VectorSpace-import Data.AffineSpace------------------------------------------------------------------------------------------- Duration type------------------------------------------------------------------------------------------ |--- This type represents relative time in seconds.----newtype Duration = Duration { getDuration::Rational } - deriving (Eq, Ord, Num, Enum, Real, Fractional, RealFrac)- -- Note: no Floating as we want to be able to switch to rational--instance Show Duration where - show = show . getDuration--instance AdditiveGroup Duration where- zeroV = 0- (^+^) = (+)- negateV = negate--instance VectorSpace Duration where- type Scalar Duration = Duration- (*^) = (*)--instance InnerSpace Duration where (<.>) = (*)---class HasDuration a where- duration :: a -> Duration------------------------------------------------------------------------------------------- Delayable class------------------------------------------------------------------------------------------ |--- Delayable values. This is really similar to 'AffineSpace', except that there--- is no '.-.'.--- -class Delayable a where-- -- |- -- Delay a score.- -- > Duration -> Score a -> Score a- -- - delay :: Duration -> a -> a--instance Delayable a => Delayable (WrappedMonoid a) where - delay t = WrapMonoid . delay t . unwrapMonoid
src/Music/Score/Dynamics.hs view
@@ -1,10 +1,13 @@- + {-# LANGUAGE TypeFamilies, DeriveFunctor, DeriveFoldable,+ DeriveDataTypeable, FlexibleInstances,- GeneralizedNewtypeDeriving #-} + FlexibleContexts,+ ConstraintKinds,+ GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------------- -- |@@ -16,7 +19,7 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) ----- Provides a musical score represenation.+-- Provides functions for manipulating dynamics. -- ------------------------------------------------------------------------------------- @@ -31,8 +34,9 @@ dim, -- ** Application- dynamicSingle, dynamics,+ dynamicVoice,+ dynamicSingle, -- ** Miscellaneous resetDynamics,@@ -42,16 +46,17 @@ import Data.Semigroup import Data.Ratio import Data.Foldable+import Data.Typeable import qualified Data.List as List import Data.VectorSpace import Data.AffineSpace -import Music.Score.Part-import Music.Score.Score-import Music.Score.Duration-import Music.Score.Time import Music.Score.Voice+import Music.Score.Score+import Music.Time+import Music.Score.Part import Music.Score.Combinators+import Music.Score.Zip import Music.Dynamics.Literal @@ -64,7 +69,7 @@ -- end cresc/dim, level, begin cresc/dim newtype DynamicT a = DynamicT { getDynamicT :: (Bool, Bool, Maybe Double, a, Bool, Bool) }- deriving (Eq, Show, Ord, Functor, Foldable)+ deriving (Eq, Show, Ord, Functor, Foldable, Typeable) @@ -73,31 +78,36 @@ -------------------------------------------------------------------------------- -- Apply a constant level over the whole score.--- dynamic :: (HasDynamic a, HasVoice a, Ord v, v ~ Voice a) => Double -> Score a -> Score a--- dynamic n = mapSep (setLevel n) id id +-- dynamic :: (HasDynamic a, HasPart a, Ord v, v ~ Part a) => Double -> Score a -> Score a+-- dynamic n = mapPhrase (setLevel n) id id --- | Apply a dynamic level over the score.--- The dynamic score is assumed to have duration one.+-- |+-- Apply a dynamic level over the score.+-- The dynamic score is assumed to have duration one. ---dynamics :: (HasDynamic a, HasVoice a, Ord v, v ~ Voice a) => Score (Levels Double) -> Score a -> Score a+dynamics :: (HasDynamic a, HasPart' a) => Score (Levels Double) -> Score a -> Score a dynamics d a = (duration a `stretchTo` d) `dyns` a --- | Apply a dynamic level over a single-part score.--- Equivalent to `dynamics` for single part scores but more efficient.+-- |+-- Equivalent to `splitTies` for single-voice scores.+-- Fails if the score contains overlapping events. -- dynamicSingle :: HasDynamic a => Score (Levels Double) -> Score a -> Score a dynamicSingle d a = (duration a `stretchTo` d) `dyn` a +-- |+-- Apply a dynamic level over a voice.+--+dynamicVoice :: HasDynamic a => Score (Levels Double) -> Voice (Maybe a) -> Voice (Maybe a)+dynamicVoice d = scoreToVoice . dynamicSingle d . voiceToScore' --- | Apply a variable level over the score.-dyns :: (HasDynamic a, HasVoice a, Ord v, v ~ Voice a) => Score (Levels Double) -> Score a -> Score a-dyns ds = mapVoices (fmap $ applyDynSingle (fmap fromJust $ scoreToPart ds))+dyns :: (HasDynamic a, HasPart a, Ord v, v ~ Part a) => Score (Levels Double) -> Score a -> Score a+dyns ds = mapAllParts (fmap $ applyDynSingle (fmap fromJust $ scoreToVoice ds)) --- | Apply a variable level over a single-part score. dyn :: HasDynamic a => Score (Levels Double) -> Score a -> Score a-dyn ds = applyDynSingle (fmap fromJust . scoreToPart $ ds)+dyn ds = applyDynSingle (fmap fromJust . scoreToVoice $ ds) resetDynamics :: HasDynamic c => c -> c resetDynamics = setBeginCresc False . setEndCresc False . setBeginDim False . setEndDim False@@ -114,13 +124,13 @@ instance Fractional a => IsDynamics (Levels a) where fromDynamics (DynamicsL (Just a, Nothing)) = Level (toFrac a) fromDynamics (DynamicsL (Just a, Just b)) = Change (toFrac a) (toFrac b)- fromDynamics x = error $ "fromDynamics: Invalid dynamics literal " {- ++ show x-}+ fromDynamics x = error $ "fromDynamics: Invalid dynamics literal " ++ show x cresc :: IsDynamics a => Double -> Double -> a-cresc a b = fromDynamics $ DynamicsL ((Just a), (Just b))+cresc a b = fromDynamics $ DynamicsL (Just a, Just b) dim :: IsDynamics a => Double -> Double -> a-dim a b = fromDynamics $ DynamicsL ((Just a), (Just b))+dim a b = fromDynamics $ DynamicsL (Just a, Just b) -- end cresc, end dim, level, begin cresc, begin dim@@ -132,68 +142,37 @@ g (Nothing, False, False) (Level b) = ((Just b, False, False), (False, False, Just b, False, False)) g (Nothing, False, False) (Change b c) = ((Just b, b < c, b > c), (False, False, Just b, b < c, b > c)) - g (Just a , cr, dm) (Level b) + g (Just a , cr, dm) (Level b) | a == b = ((Just b, False, False), (cr, dm, Nothing, False, False)) | a /= b = ((Just b, False, False), (cr, dm, Just b, False, False))- g (Just a , cr, dm) (Change b c) + g (Just a , cr, dm) (Change b c) | a == b = ((Just b, b < c, b > c), (cr, dm, Nothing, b < c, b > c)) | a /= b = ((Just b, b < c, b > c), (cr, dm, Just b, b < c, b > c)) -transf :: ([a] -> [b]) -> Part a -> Part b-transf f = Part . uncurry zip . second f . unzip . getPart+transf :: ([a] -> [b]) -> Voice a -> Voice b+transf f = Voice . uncurry zip . second f . unzip . getVoice -applyDynSingle :: HasDynamic a => Part (Levels Double) -> Score a -> Score a-applyDynSingle ds as = applySingle ds3 as+applyDynSingle :: HasDynamic a => Voice (Levels Double) -> Score a -> Score a+applyDynSingle ds = applySingle ds3 where- -- ds2 :: Part (Dyn2 Double)+ -- ds2 :: Voice (Dyn2 Double) ds2 = transf dyn2 ds- -- ds3 :: Part (Score a -> Score a)- ds3 = (flip fmap) ds2 g- + -- ds3 :: Voice (Score a -> Score a)+ ds3 = fmap g ds2+ g (ec,ed,l,bc,bd) = id . (if ec then map1 (setEndCresc True) else id) . (if ed then map1 (setEndDim True) else id) . (if bc then map1 (setBeginCresc True) else id) . (if bd then map1 (setBeginDim True) else id)- . (maybe id (\x -> map1 (setLevel x)) $ l)- map1 f = mapSepPart f id id--------- FIXME consolidate---- | --- Map over first, middle and last elements of list.--- Biased on first, then on first and last for short lists.--- -mapSepL :: (a -> b) -> (a -> b) -> (a -> b) -> [a] -> [b]-mapSepL f g h [] = []-mapSepL f g h [a] = [f a]-mapSepL f g h [a,b] = [f a, h b]-mapSepL f g h xs = [f $ head xs] ++ (map g $ tail $ init xs) ++ [h $ last xs]--mapSep :: (HasVoice a, Ord v, v ~ Voice a) => (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b-mapSep f g h sc = fixDur . mapVoices (fmap $ mapSepPart f g h) $ sc- where- fixDur a = padAfter (duration sc - duration a) a--mapSepPart :: (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b-mapSepPart f g h sc = mconcat . mapSepL (fmap f) (fmap g) (fmap h) . fmap toSc . perform $ sc- where - fixDur a = padAfter (duration sc - duration a) a- toSc (t,d,x) = delay (t .-. 0) . stretch d $ note x- third f (a,b,c) = (a,b,f c)--padAfter :: Duration -> Score a -> Score a-padAfter d a = a |> (rest^*d) + . maybe id (map1 . setLevel) l+ map1 f = mapPhraseSingle f id id +------------------------------------------------------------------------------------- second :: (a -> b) -> (c,a) -> (c,b) second f (a,b) = (a,f b)@@ -202,3 +181,5 @@ toFrac = fromRational . toRational fromJust (Just x) = x++
+ src/Music/Score/Export/Lilypond.hs view
@@ -0,0 +1,254 @@++{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ DeriveDataTypeable,+ GeneralizedNewtypeDeriving,+ FlexibleContexts,+ ConstraintKinds,+ TypeOperators,+ OverloadedStrings,+ NoMonomorphismRestriction #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Score.Export.Lilypond (+ Lilypond,+ HasLilypond(..),+ toLy,+ writeLy,+ openLy,+ -- toLySingle,+ -- writeLySingle,+ -- openLySingle,+ ) where++import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)++import Data.Semigroup+import Data.Ratio+import Data.String+import Control.Applicative+import Control.Monad hiding (mapM)+import Control.Monad.Plus+import Data.Maybe+import Data.Either+import Data.Foldable+import Data.Typeable+import Data.Traversable+import Data.Function (on)+import Data.Ord (comparing)+import Data.VectorSpace+import Data.AffineSpace+import Data.Basis+import System.Process++import Music.Time+import Music.Pitch.Literal+import Music.Dynamics.Literal+import Music.Score.Rhythm+import Music.Score.Track+import Music.Score.Voice+import Music.Score.Score+import Music.Score.Combinators+import Music.Score.Zip+import Music.Score.Pitch+import Music.Score.Ties+import Music.Score.Part+import Music.Score.Articulation+import Music.Score.Dynamics+import Music.Score.Ornaments+import Music.Score.Instances+import Music.Score.Export.Util++import qualified Codec.Midi as Midi+import qualified Music.MusicXml.Simple as Xml+import qualified Music.Lilypond as Lilypond+import qualified Text.Pretty as Pretty+import qualified Data.Map as Map+import qualified Data.List as List+++type Lilypond = Lilypond.Music++-- |+-- Class of types that can be converted to Lilypond.+--+class Tiable a => HasLilypond a where+ -- |+ -- Convert a value to a Lilypond music expression.+ --+ getLilypond :: DurationT -> a -> Lilypond++instance HasLilypond Int where getLilypond d = getLilypond d . toInteger+instance HasLilypond Float where getLilypond d = getLilypond d . toInteger . round+instance HasLilypond Double where getLilypond d = getLilypond d . toInteger . round+instance Integral a => HasLilypond (Ratio a) where getLilypond d = getLilypond d . toInteger . round++instance HasLilypond Integer where+ getLilypond d p = Lilypond.note (spellLy $ p+12) ^*(fromDurationT $ d*4)++instance HasLilypond a => HasLilypond (PartT n a) where+ getLilypond d (PartT (_,x)) = getLilypond d x++instance HasLilypond a => HasLilypond (TieT a) where+ getLilypond d (TieT (ta,x,tb)) = addTies $ getLilypond d x+ where+ addTies | ta && tb = id . Lilypond.beginTie+ | tb = Lilypond.beginTie+ | ta = id+ | otherwise = id++instance HasLilypond a => HasLilypond (DynamicT a) where+ getLilypond d (DynamicT (ec,ed,l,a,bc,bd)) = notate $ getLilypond d a+ where+ notate x = nec . ned . nl . nbc . nbd $ x+ nec = if ec then Lilypond.endCresc else id+ ned = if ed then Lilypond.endDim else id+ nbc = if bc then Lilypond.beginCresc else id+ nbd = if bd then Lilypond.beginDim else id+ nl = case l of+ Nothing -> id+ Just lvl -> Lilypond.addDynamics (fromDynamics (DynamicsL (Just lvl, Nothing)))++instance HasLilypond a => HasLilypond (ArticulationT a) where+ getLilypond d (ArticulationT (es,us,al,sl,a,bs)) = notate $ getLilypond d a+ where+ notate = nes . nal . nsl . nbs+ nes = if es then Lilypond.endSlur else id+ nal = case al of+ 0 -> id+ 1 -> Lilypond.addAccent+ 2 -> Lilypond.addMarcato+ nsl = case sl of+ (-2) -> Lilypond.addTenuto+ (-1) -> Lilypond.addPortato+ 0 -> id+ 1 -> Lilypond.addStaccato+ 2 -> Lilypond.addStaccatissimo+ nbs = if bs then Lilypond.beginSlur else id++instance HasLilypond a => HasLilypond (TremoloT a) where+ getLilypond d (TremoloT (n,x)) = notate $ getLilypond d x+ where+ notate = case n of+ 0 -> id+ _ -> Lilypond.Tremolo n+ -- FIXME wrong number?++instance HasLilypond a => HasLilypond (TextT a) where+ getLilypond d (TextT (s,x)) = notate s $ getLilypond d x+ where+ notate ts = foldr (.) id (fmap Lilypond.addText ts)++instance HasLilypond a => HasLilypond (HarmonicT a) where+ getLilypond d (HarmonicT (n,x)) = notate $ getLilypond d x+ where+ notate = id+ -- FIXME++instance HasLilypond a => HasLilypond (SlideT a) where+ getLilypond d (SlideT (eg,es,a,bg,bs)) = notate $ getLilypond d a+ where+ notate = id+ -- FIXME+++++-- TODO rename+pcatLy :: [Lilypond] -> Lilypond+pcatLy = foldr Lilypond.pcat (Lilypond.Simultaneous False [])++scatLy :: [Lilypond] -> Lilypond+scatLy = foldr Lilypond.scat (Lilypond.Sequential [])+++-- |+-- Convert a score to a Lilypond representation and write to a file.+--+writeLy :: (HasLilypond a, HasPart' a, Show (Part a)) => FilePath -> Score a -> IO ()+writeLy path sc = writeFile path ((header ++) $ show $ Pretty.pretty $ toLy sc)+ where+ header = mempty +++ "\\include \"lilypond-book-preamble.ly\"\n" +++ "\\paper {\n" +++ " #(define dump-extents #t)\n" +++ "\n" +++ " indent = 0\\mm\n" +++ " line-width = 210\\mm - 2.0 * 0.4\\in\n" +++ " ragged-right = ##t\n" +++ " force-assignment = #\"\"\n" +++ " line-width = #(- line-width (* mm 3.000000))\n" +++ "}\n" +++ "\\layout {\n" +++ "}\n"++-- |+-- Typeset a score using Lilypond and open it.+--+openLy :: (HasLilypond a, HasPart' a, Show (Part a)) => Score a -> IO ()+openLy sc = do+ writeLy "test.ly" sc+ runLy+ cleanLy+ openLy'++runLy = runCommand "lilypond -f pdf test.ly" >>= waitForProcess >> return ()+cleanLy = runCommand "rm -f test-*.tex test-*.texi test-*.count test-*.eps test-*.pdf test.eps"+openLy' = runCommand "open test.pdf" >> return ()+ -- FIXME hardcoded++-- |+-- Convert a score to a Lilypond representation.+--+toLy :: (HasLilypond a, HasPart' a, Show (Part a)) => Score a -> Lilypond+toLy sc = pcatLy . fmap (addStaff . scatLy . prependName . second toLyVoice' . second scoreToVoice) . extractParts $ sc+ where+ addStaff x = Lilypond.New "Staff" Nothing x+ prependName (v,x) = [Lilypond.Set "Staff.instrumentName" (Lilypond.toValue $ show v)] ++ x++-- |+-- Convert a voice score to a list of bars.+--+toLyVoice' :: HasLilypond a => Voice (Maybe a) -> [Lilypond]+toLyVoice' = fmap barToLy . voiceToBars++barToLy :: HasLilypond a => [(DurationT, Maybe a)] -> Lilypond+barToLy bar = case quantize bar of+ Left e -> error $ "barToLy: Could not quantize this bar: " ++ show e+ Right rh -> rhythmToLy rh++rhythmToLy :: HasLilypond a => Rhythm (Maybe a) -> Lilypond+rhythmToLy (Beat d x) = noteRestToLy d x+rhythmToLy (Group rs) = foldr Lilypond.scat (Lilypond.Sequential []) $ map rhythmToLy rs+rhythmToLy (Dotted n (Beat d x)) = noteRestToLy (dotMod n * d) x+rhythmToLy (Tuplet m r) = Lilypond.Times (fromDurationT m) (rhythmToLy r)+ where (a,b) = both fromIntegral fromIntegral $ unRatio $ fromDurationT m++noteRestToLy :: HasLilypond a => DurationT -> Maybe a -> Lilypond+noteRestToLy d Nothing = Lilypond.rest^*(fromDurationT $ d*4)+noteRestToLy d (Just p) = getLilypond d p++spellLy :: Integer -> Lilypond.Note+spellLy a = Lilypond.NotePitch (spellLy' a) Nothing++spellLy' :: Integer -> Lilypond.Pitch+spellLy' p = Lilypond.Pitch (+ toEnum $ fromIntegral pc,+ fromIntegral alt,+ fromIntegral oct+ )+ where (pc,alt,oct) = spellPitch p+
+ src/Music/Score/Export/Midi.hs view
@@ -0,0 +1,186 @@++{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ DeriveDataTypeable,+ GeneralizedNewtypeDeriving,+ FlexibleInstances,+ FlexibleContexts,+ ConstraintKinds,+ TypeOperators,+ OverloadedStrings,+ NoMonomorphismRestriction #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Score.Export.Midi (+ HasMidi(..),+ toMidi,+ toMidiTrack,+ writeMidi,+ playMidi,+ playMidiIO,+ ) where++import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)++import Data.Semigroup+import Data.Ratio+import Data.String+import Control.Applicative+import Control.Monad hiding (mapM)+import Control.Monad.Plus+import Data.Maybe+import Data.Either+import Data.Foldable+import Data.Typeable+import Data.Traversable+import Data.Function (on)+import Data.Ord (comparing)+import Data.VectorSpace+import Data.AffineSpace+import Data.Basis++import Control.Reactive+import Control.Reactive.Midi++import Music.Time+import Music.Pitch.Literal+import Music.Dynamics.Literal+import Music.Score.Rhythm+import Music.Score.Track+import Music.Score.Voice+import Music.Score.Score+import Music.Score.Combinators+import Music.Score.Zip+import Music.Score.Pitch+import Music.Score.Ties+import Music.Score.Part+import Music.Score.Articulation+import Music.Score.Dynamics+import Music.Score.Ornaments+import Music.Score.Export.Util++import qualified Codec.Midi as Midi+import qualified Music.MusicXml.Simple as Xml+import qualified Music.Lilypond as Lilypond+import qualified Text.Pretty as Pretty+import qualified Data.Map as Map+import qualified Data.List as List+++-- |+-- Class of types that can be converted to MIDI.+--+-- Numeric types are interpreted as notes with a default velocity, pairs are+-- interpreted as @(pitch, velocity)@ pairs.+--+-- Minimal definition: 'getMidi'. Given 'getMidiScore', 'getMidi' can be implemented+-- as @getMidiScore . return@.+--+class HasMidi a where++ -- | Convert a value to a MIDI score.+ -- Typically, generates an /on/ event using 'note' followed by an optional /off/ event.+ getMidi :: a -> Score Midi.Message++ -- | Convert a score to a MIDI score.+ -- The default definition can be overriden for efficiency.+ getMidiScore :: Score a -> Score Midi.Message+ getMidiScore = (>>= getMidi)+++instance HasMidi (Integer, Integer) where+ getMidi (p,v) = mempty+ |> return (Midi.NoteOn 0 (fromIntegral p) (fromIntegral v))+ |> return (Midi.NoteOff 0 (fromIntegral p) (fromIntegral v))++instance HasMidi Midi.Message where getMidi = return+instance HasMidi Int where getMidi = getMidi . toInteger+instance HasMidi Integer where getMidi = \x -> getMidi (x,100::Integer)+instance HasMidi Float where getMidi = getMidi . toInteger . round+instance HasMidi Double where getMidi = getMidi . toInteger . round+instance Integral a => HasMidi (Ratio a) where getMidi = getMidi . toInteger . round+instance HasMidi a => HasMidi (Maybe a) where getMidi = getMidiScore . mfromMaybe++instance HasMidi a => HasMidi (PartT n a) where+ getMidi (PartT (_,a)) = getMidi a+instance HasMidi a => HasMidi (TieT a) where+ getMidi (TieT (_,a,_)) = getMidi a+instance HasMidi a => HasMidi (DynamicT a) where+ getMidi (DynamicT (ec,ed,l,a,bc,bd)) = getMidi a+instance HasMidi a => HasMidi (ArticulationT a) where+ getMidi (ArticulationT (es,us,al,sl,a,bs)) = getMidi a+instance HasMidi a => HasMidi (TremoloT a) where+ getMidi (TremoloT (_,a)) = getMidi a+instance HasMidi a => HasMidi (TextT a) where+ getMidi (TextT (_,a)) = getMidi a+instance HasMidi a => HasMidi (HarmonicT a) where+ getMidi (HarmonicT (_,a)) = getMidi a+instance HasMidi a => HasMidi (SlideT a) where+ getMidi (SlideT (_,_,a,_,_)) = getMidi a++++-- |+-- Convert a score to a MIDI file representation.+--+toMidi :: HasMidi a => Score a -> Midi.Midi+toMidi score = Midi.Midi fileType divisions' [controlTrack, eventTrack]+ where+ endPos = 10000+ fileType = Midi.MultiTrack+ divisions = 1024+ divisions' = Midi.TicksPerBeat divisions+ controlTrack = [(0, Midi.TempoChange 1000000), (endPos, Midi.TrackEnd)]+ eventTrack = events <> [(endPos, Midi.TrackEnd)]++ events :: [(Midi.Ticks, Midi.Message)]+ events = (\(t,_,x) -> (round (t * divisions), x)) <$> performance++ performance :: [(TimeT, DurationT, Midi.Message)]+ performance = (toRelative . perform) (getMidiScore score)++ -- FIXME arbitrary endTimeT (files won't work without this...)+ -- TODO render voices separately++-- |+-- Convert a score to a track of MIDI messages.+--+toMidiTrack :: HasMidi a => Score a -> Track Message+toMidiTrack = Track . fmap (\(t,_,m) -> (t,m)) . perform . getMidiScore++-- |+-- Convert a score MIDI and write to a file.+--+writeMidi :: HasMidi a => FilePath -> Score a -> IO ()+writeMidi path sc = Midi.exportFile path (toMidi sc)++-- |+-- Convert a score to a MIDI event.+--+playMidi :: HasMidi a => String -> Score a -> Event MidiMessage+playMidi dest x = midiOut midiDest $ playback trig (pure $ toTrack $ delay 0.2 x)+ where+ -- trig = accumR 0 ((+ 0.005) <$ pulse 0.005)+ trig = time+ toTrack = fmap (\(t,_,m) -> (t,m)) . perform . getMidiScore+ midiDest = fromJust $ unsafeGetReactive (findDestination $ pure dest)++-- |+-- Convert a score to a MIDI event and run it.+--+playMidiIO :: HasMidi a => String -> Score a -> IO ()+playMidiIO dest = runLoop . playMidi dest+
+ src/Music/Score/Export/MusicXml.hs view
@@ -0,0 +1,277 @@++{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ DeriveDataTypeable,+ GeneralizedNewtypeDeriving,+ FlexibleContexts,+ ConstraintKinds,+ TypeOperators,+ OverloadedStrings,+ NoMonomorphismRestriction #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Score.Export.MusicXml (+ XmlScore,+ XmlMusic,+ HasMusicXml(..),+ toXml,+ writeXml,+ openXml,+ toXmlVoice,+ toXmlSingle,+ writeXmlSingle,+ openXmlSingle,+) where++import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)++import Data.Semigroup+import Data.Ratio+import Data.String+import Control.Applicative+import Control.Monad hiding (mapM)+import Control.Monad.Plus+import Data.Maybe+import Data.Either+import Data.Foldable+import Data.Typeable+import Data.Traversable+import Data.Function (on)+import Data.Ord (comparing)+import Data.VectorSpace+import Data.AffineSpace+import Data.Basis++import Music.Time+import Music.Pitch.Literal+import Music.Dynamics.Literal+import Music.Score.Rhythm+import Music.Score.Track+import Music.Score.Voice+import Music.Score.Score+import Music.Score.Combinators+import Music.Score.Zip+import Music.Score.Pitch+import Music.Score.Ties+import Music.Score.Part+import Music.Score.Articulation+import Music.Score.Dynamics+import Music.Score.Ornaments+import Music.Score.Instances+import Music.Score.Export.Util++import qualified Codec.Midi as Midi+import qualified Music.MusicXml.Simple as Xml+import qualified Music.Lilypond as Lilypond+import qualified Text.Pretty as Pretty+import qualified Data.Map as Map+import qualified Data.List as List+++type XmlScore = Xml.Score+type XmlMusic = Xml.Music++-- |+-- Class of types that can be converted to MusicXML.+--+class Tiable a => HasMusicXml a where+ -- |+ -- Convert a value to MusicXML.+ --+ -- Typically, generates a 'XmlMusic' value using 'Xml.note' or 'Xml.chord', and transforms it+ -- to add beams, slurs, dynamics, articulation etc.+ --+ getMusicXml :: DurationT -> a -> XmlMusic++instance HasMusicXml Int where getMusicXml d = getMusicXml d . toInteger+instance HasMusicXml Float where getMusicXml d = getMusicXml d . toInteger . round+instance HasMusicXml Double where getMusicXml d = getMusicXml d . toInteger . round+instance Integral a => HasMusicXml (Ratio a) where getMusicXml d = getMusicXml d . toInteger . round+-- instance HasMusicXml a => HasMusicXml (Maybe a) where getMusicXml d = ?++instance HasMusicXml Integer where+ getMusicXml d p = Xml.note (spellXml (fromIntegral p)) . fromDurationT $ d++instance HasMusicXml a => HasMusicXml (PartT n a) where+ getMusicXml d (PartT (_,x)) = getMusicXml d x++instance HasMusicXml a => HasMusicXml (TieT a) where+ getMusicXml d (TieT (ta,x,tb)) = addTies $ getMusicXml d x+ where+ addTies | ta && tb = Xml.endTie . Xml.beginTie+ | tb = Xml.beginTie+ | ta = Xml.endTie+ | otherwise = id++instance HasMusicXml a => HasMusicXml (DynamicT a) where+ getMusicXml d (DynamicT (ec,ed,l,a,bc,bd)) = notate $ getMusicXml d a+ where+ notate x = nec <> ned <> nl <> nbc <> nbd <> x+ nec = if ec then Xml.endCresc else mempty+ ned = if ed then Xml.endDim else mempty+ nbc = if bc then Xml.beginCresc else mempty+ nbd = if bd then Xml.beginDim else mempty+ nl = case l of+ Nothing -> mempty+ Just lvl -> Xml.dynamic (fromDynamics (DynamicsL (Just lvl, Nothing)))++instance HasMusicXml a => HasMusicXml (ArticulationT a) where+ getMusicXml d (ArticulationT (es,us,al,sl,a,bs)) = notate $ getMusicXml d a+ where+ notate = nes . nal . nsl . nbs+ nes = if es then Xml.endSlur else id+ nal = case al of+ 0 -> id+ 1 -> Xml.accent+ 2 -> Xml.strongAccent+ nsl = case sl of+ (-2) -> Xml.tenuto+ (-1) -> Xml.tenuto . Xml.staccato+ 0 -> id+ 1 -> Xml.staccato+ 2 -> Xml.staccatissimo+ nbs = if bs then Xml.beginSlur else id++instance HasMusicXml a => HasMusicXml (TremoloT a) where+ getMusicXml d (TremoloT (n,x)) = notate $ getMusicXml d x+ where+ notate = case n of+ 0 -> id+ _ -> Xml.tremolo n++instance HasMusicXml a => HasMusicXml (TextT a) where+ getMusicXml d (TextT (s,x)) = notate s $ getMusicXml d x+ where+ notate ts a = mconcat (fmap Xml.text ts) <> a++instance HasMusicXml a => HasMusicXml (HarmonicT a) where+ getMusicXml d (HarmonicT (n,x)) = notate $ getMusicXml d x+ where+ notate | n /= 0 = Xml.setNoteHead Xml.DiamondNoteHead+ | otherwise = id+ -- TODO adjust pitch etc++instance HasMusicXml a => HasMusicXml (SlideT a) where+ getMusicXml d (SlideT (eg,es,a,bg,bs)) = notate $ getMusicXml d a+ where+ notate = neg . nes . nbg . nbs+ neg = if es then Xml.endGliss else id+ nes = if es then Xml.endSlide else id+ nbg = if es then Xml.beginGliss else id+ nbs = if es then Xml.beginSlide else id+++-- |+-- Convert a score to MusicXML and write to a file.+--+writeXml :: (HasMusicXml a, HasPart' a, Show (Part a)) => FilePath -> Score a -> IO ()+writeXml path sc = writeFile path (Xml.showXml $ toXml sc)++-- |+-- Convert a score to MusicXML and open it.+--+openXml :: (HasMusicXml a, HasPart' a, Show (Part a)) => Score a -> IO ()+openXml sc = do+ writeXml "test.xml" sc+ execute "open" ["-a", "/Applications/Sibelius 6.app/Contents/MacOS/Sibelius 6", "test.xml"]+ -- FIXME hardcoded++-- |+-- Convert a score to MusicXML and write to a file.+--+writeXmlSingle :: HasMusicXml a => FilePath -> Score a -> IO ()+writeXmlSingle path sc = writeFile path (Xml.showXml $ toXmlSingle sc)++-- |+-- Convert a score to MusicXML and open it.+--+openXmlSingle :: HasMusicXml a => Score a -> IO ()+openXmlSingle sc = do+ writeXmlSingle "test.xml" sc+ execute "open" ["-a", "/Applications/Sibelius 6.app/Contents/MacOS/Sibelius 6", "test.xml"]+ -- FIXME hardcoded+++-- |+-- Convert a score to a MusicXML representation.+--+toXml :: (HasMusicXml a, HasPart' a, Show (Part a)) => Score a -> XmlScore+toXml sc = Xml.fromParts "Title" "Composer" pl . fmap (toXmlVoice' . scoreToVoice) . extract $ sc+ where+ pl = Xml.partList (fmap show $ getParts sc)++-- |+-- Convert a single-voice score to a MusicXML representation.+--+toXmlSingle :: HasMusicXml a => Score a -> XmlScore+toXmlSingle = toXmlVoice . scoreToVoice++-- |+-- Convert a single-voice score to a MusicXML representation.+--+toXmlVoice :: HasMusicXml a => Voice (Maybe a) -> XmlScore+toXmlVoice = Xml.fromPart "Title" "Composer" "Voice" . toXmlVoice'++-- |+-- Convert a voice score to a list of bars.+--+toXmlVoice' :: HasMusicXml a => Voice (Maybe a) -> [XmlMusic]+toXmlVoice' =+ addDefaultSignatures . fmap barToXml . voiceToBars+ where+ addDefaultSignatures [] = []+ addDefaultSignatures (x:xs) = (defaultSignatures <> x):xs+ defaultSignatures = mempty+ <> Xml.defaultKey+ <> Xml.defaultDivisions+ <> Xml.metronome (1/4) 60+ <> Xml.commonTime+++barToXml :: HasMusicXml a => [(DurationT, Maybe a)] -> Xml.Music+barToXml bar = case quantize bar of+ Left e -> error $ "barToXml: Could not quantize this bar: " ++ show e+ Right rh -> rhythmToXml rh++rhythmToXml :: HasMusicXml a => Rhythm (Maybe a) -> Xml.Music+rhythmToXml (Beat d x) = noteRestToXml d x+rhythmToXml (Group rs) = mconcat $ map rhythmToXml rs+rhythmToXml (Dotted n (Beat d x)) = noteRestToXml (dotMod n * d) x+rhythmToXml (Tuplet m r) = Xml.tuplet b a (rhythmToXml r)+ where (a,b) = both fromIntegral fromIntegral $ unRatio $ fromDurationT m++noteRestToXml :: HasMusicXml a => DurationT -> Maybe a -> Xml.Music+noteRestToXml d Nothing = setDefaultVoice $ Xml.rest $ fromDurationT d+noteRestToXml d (Just p) = setDefaultVoice $ getMusicXml d p++-- FIXME only works for single-voice parts+setDefaultVoice :: Xml.Music -> Xml.Music+setDefaultVoice = Xml.setVoice 1++-- FIXME arbitrary spelling, please modularize...+spellXml :: Integer -> Xml.Pitch+spellXml p = (+ toEnum $ fromIntegral pc,+ if alt == 0 then Nothing else Just (fromIntegral alt),+ fromIntegral oct+ )+ where (pc,alt,oct) = spellPitch p++++++
+ src/Music/Score/Export/Util.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ GeneralizedNewtypeDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Score.Export.Util -- (+-- )+where++import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)++import Data.Semigroup+import Data.Ratio+import Data.String+import Control.Applicative+import Control.Monad hiding (mapM)+import Control.Monad.Plus+import Data.Maybe+import Data.Either+import Data.Foldable+import Data.Typeable+import Data.Traversable+import Data.Function (on)+import Data.Ord (comparing)+import Data.VectorSpace+import Data.AffineSpace+import Data.Basis++import Music.Time+import Music.Score.Rhythm+import Music.Score.Track+import Music.Score.Voice+import Music.Score.Score+import Music.Score.Combinators+import Music.Score.Zip+import Music.Score.Pitch+import Music.Score.Ties+import Music.Score.Part+import Music.Score.Articulation+import Music.Score.Dynamics+import Music.Score.Ornaments++import qualified Codec.Midi as Midi+import qualified Music.MusicXml.Simple as Xml+import qualified Music.Lilypond as Lilypond+import qualified Text.Pretty as Pretty+import qualified Data.Map as Map+import qualified Data.List as List++import System.Posix+import System.IO.Unsafe+import Music.Pitch.Literal+import Music.Dynamics.Literal++-- |+-- Convert a single-voice score to a list of bars.+--+voiceToBars :: Tiable a => Voice (Maybe a) -> [[(DurationT, Maybe a)]]+voiceToBars = separateBars . splitTiesVoice++-- |+-- Given a set of absolute-time occurences, separate at each zero-time occurence.+-- Note that this require every bar to start with a zero-time occurence.+--+separateBars :: Voice (Maybe a) -> [[(DurationT, Maybe a)]]+separateBars =+ fmap (removeTime . fmap discardBarNumber) .+ splitAtTimeZero . fmap separateTime . perform+ where+ separateTime (t,d,x) = ((bn,bt),d,x) where (bn,bt) = properFraction (toRational t * 1)+ splitAtTimeZero = splitWhile ((== 0) . getBarTime) where getBarTime ((bn,bt),_,_) = bt+ discardBarNumber ((bn,bt),d,x) = (fromRational bt / 1, d, x)+ removeTime = fmap g where g (t,d,x) = (d,x)++-- |+-- Convert absolute to relative durations.+--+toRelative :: [(TimeT, DurationT, b)] -> [(TimeT, DurationT, b)]+toRelative = snd . mapAccumL g 0+ where+ g now (t,d,x) = (t, (t-now,d,x))+++-- FIXME arbitrary spelling, please modularize...+spellPitch :: Integral a => a -> (a, a, a)+spellPitch p = (+ pitchClass,+ alteration,+ octave+ )+ where+ octave = (p `div` 12) - 1+ semitone = p `mod` 12+ pitchClass = fromStep major semitone+ alteration = semitone - step major pitchClass++ step xs p = xs !! ((fromIntegral p) `mod` length xs)+ fromStep xs p = fromIntegral $ fromMaybe (length xs - 1) $ List.findIndex (>= p) xs+ scaleFromSteps = snd . List.mapAccumL add 0+ where+ add a x = (a + x, a + x)+ major = scaleFromSteps [0,2,2,1,2,2,2,1]+++-- |+-- Group a list into sublists whereever a predicate holds. The matched element+-- is the first in the sublist.+--+-- > splitWhile isSpace "foo bar baz"+-- > ===> ["foo"," bar"," baz"]+-- >+-- > splitWhile (> 3) [1,5,4,7,0,1,2]+-- > ===> [[1],[5],[4],[7,0,1,2]]+--+splitWhile :: (a -> Bool) -> [a] -> [[a]]+splitWhile p xs = case splitWhile' p xs of+ []:xss -> xss+ xss -> xss+ where+ splitWhile' p [] = [[]]+ splitWhile' p (x:xs) = case splitWhile' p xs of+ (xs:xss) -> if p x then []:(x:xs):xss else (x:xs):xss++execute :: FilePath -> [String] -> IO ()+execute program args = do+ forkProcess $ executeFile program True args Nothing+ return ()++unRatio x = (numerator x, denominator x)+first f (x, y) = (f x, y)+second f (x, y) = (x, f y)+both f g = first f . second g
+ src/Music/Score/Instances.hs view
@@ -0,0 +1,750 @@++{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ DeriveDataTypeable,+ FlexibleInstances,+ FlexibleContexts,+ ConstraintKinds,+ GeneralizedNewtypeDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : non-portable (TF,GNTD)+--+-- To be written.+--+-------------------------------------------------------------------------------------++module Music.Score.Instances (+ ) where++import Control.Monad+import Data.Semigroup+import Data.Ratio+import Data.Maybe+import Data.Foldable+import Data.Typeable+import qualified Data.List as List+import Data.VectorSpace+import Data.AffineSpace++import Music.Time+import Music.Pitch.Literal+import Music.Dynamics.Literal++import Music.Score.Rhythm+import Music.Score.Track+import Music.Score.Voice+import Music.Score.Score+import Music.Score.Combinators+import Music.Score.Zip+import Music.Score.Pitch+import Music.Score.Ties+import Music.Score.Part+import Music.Score.Chord+import Music.Score.Articulation+import Music.Score.Dynamics+import Music.Score.Ornaments++-------------------------------------------------------------------------------------+++instance (IsPitch a, Enum n) => IsPitch (PartT n a) where+ fromPitch l = PartT (toEnum 0, fromPitch l)+instance (IsDynamics a, Enum n) => IsDynamics (PartT n a) where+ fromDynamics l = PartT (toEnum 0, fromDynamics l)++instance IsPitch a => IsPitch (TieT a) where+ fromPitch l = TieT (False, fromPitch l, False)+instance IsDynamics a => IsDynamics (TieT a) where+ fromDynamics l = TieT (False, fromDynamics l, False)++instance IsPitch a => IsPitch (DynamicT a) where+ fromPitch l = DynamicT (False,False,Nothing,fromPitch l,False,False)+instance IsDynamics a => IsDynamics (DynamicT a) where+ fromDynamics l = DynamicT (False,False,Nothing,fromDynamics l,False,False)++instance IsPitch a => IsPitch (ArticulationT a) where+ fromPitch l = ArticulationT (False,False,0,0,fromPitch l,False)+instance IsDynamics a => IsDynamics (ArticulationT a) where+ fromDynamics l = ArticulationT (False,False,0,0,fromDynamics l,False)++instance IsPitch a => IsPitch (TremoloT a) where+ fromPitch l = TremoloT (0, fromPitch l)+instance IsDynamics a => IsDynamics (TremoloT a) where+ fromDynamics l = TremoloT (0, fromDynamics l)++instance IsPitch a => IsPitch (TextT a) where+ fromPitch l = TextT (mempty, fromPitch l)+instance IsDynamics a => IsDynamics (TextT a) where+ fromDynamics l = TextT (mempty, fromDynamics l)++instance IsPitch a => IsPitch (HarmonicT a) where+ fromPitch l = HarmonicT (0, fromPitch l)+instance IsDynamics a => IsDynamics (HarmonicT a) where+ fromDynamics l = HarmonicT (0, fromDynamics l)++instance IsPitch a => IsPitch (SlideT a) where+ fromPitch l = SlideT (False,False,fromPitch l,False,False)+instance IsDynamics a => IsDynamics (SlideT a) where+ fromDynamics l = SlideT (False,False,fromDynamics l,False,False)+++-------------------------------------------------------------------------------------+-------------------------------------------------------------------------------------++-- Maybe++-- TODO this instance may be problematic with mapPhrase+instance HasArticulation a => HasArticulation (Maybe a) where+ setEndSlur n (Just x) = Just (setEndSlur n x)+ setEndSlur n Nothing = Nothing+ setContSlur n (Just x) = Just (setContSlur n x)+ setContSlur n Nothing = Nothing+ setBeginSlur n (Just x) = Just (setBeginSlur n x)+ setBeginSlur n Nothing = Nothing+ setAccLevel n (Just x) = Just (setAccLevel n x)+ setAccLevel n Nothing = Nothing+ setStaccLevel n (Just x) = Just (setStaccLevel n x)+ setStaccLevel n Nothing = Nothing+instance HasPart a => HasPart (Maybe a) where+ type Part (Maybe a) = Maybe (Part a) -- !+ getPart Nothing = Nothing+ getPart (Just a) = Just (getPart a)+ modifyPart f (Nothing) = Nothing+ modifyPart f (Just a) = Just (modifyPart (fromJust . f . Just) a) -- TODO use cofunctor+instance HasPitch a => HasPitch (Maybe a) where+ type Pitch (Maybe a) = Maybe (Pitch a) -- !+ getPitch Nothing = Nothing+ getPitch (Just a) = Just (getPitch a)+ modifyPitch f (Nothing) = Nothing+ modifyPitch f (Just a) = Just (modifyPitch (fromJust . f . Just) a)+++-- PitchT+++-- PartT+++instance HasPart (PartT n a) where+ type Part (PartT n a) = n+ getPart (PartT (v,_)) = v+ modifyPart f (PartT (v,x)) = PartT (f v, x)+instance HasChord a => HasChord (PartT n a) where+ type ChordNote (PartT n a) = PartT n (ChordNote a)+ getChord (PartT (v,x)) = fmap (\x -> PartT (v,x)) (getChord x)+instance HasPitch a => HasPitch (PartT n a) where+ type Pitch (PartT n a) = Pitch a+ getPitch (PartT (v,a)) = getPitch a+ modifyPitch f (PartT (v,x)) = PartT (v, modifyPitch f x)+instance Tiable a => Tiable (PartT n a) where+ beginTie = fmap beginTie+ endTie = fmap endTie+ toTied (PartT (v,a)) = (PartT (v,b), PartT (v,c)) where (b,c) = toTied a+instance HasDynamic a => HasDynamic (PartT n a) where+ setBeginCresc n (PartT (v,x)) = PartT (v, setBeginCresc n x)+ setEndCresc n (PartT (v,x)) = PartT (v, setEndCresc n x)+ setBeginDim n (PartT (v,x)) = PartT (v, setBeginDim n x)+ setEndDim n (PartT (v,x)) = PartT (v, setEndDim n x)+ setLevel n (PartT (v,x)) = PartT (v, setLevel n x)+instance HasArticulation a => HasArticulation (PartT n a) where+ setEndSlur n (PartT (v,x)) = PartT (v, setEndSlur n x)+ setContSlur n (PartT (v,x)) = PartT (v, setContSlur n x)+ setBeginSlur n (PartT (v,x)) = PartT (v, setBeginSlur n x)+ setAccLevel n (PartT (v,x)) = PartT (v, setAccLevel n x)+ setStaccLevel n (PartT (v,x)) = PartT (v, setStaccLevel n x)+instance HasTremolo a => HasTremolo (PartT n a) where+ setTrem n (PartT (v,x)) = PartT (v, setTrem n x)+instance HasHarmonic a => HasHarmonic (PartT n a) where+ setHarmonic n (PartT (v,x)) = PartT (v, setHarmonic n x)+instance HasSlide a => HasSlide (PartT n a) where+ setBeginGliss n (PartT (v,x)) = PartT (v, setBeginGliss n x)+ setBeginSlide n (PartT (v,x)) = PartT (v, setBeginSlide n x)+ setEndGliss n (PartT (v,x)) = PartT (v, setEndGliss n x)+ setEndSlide n (PartT (v,x)) = PartT (v, setEndSlide n x)+instance HasText a => HasText (PartT n a) where+ addText s (PartT (v,x)) = PartT (v, addText s x)+++-- ChordT++instance Tiable a => Tiable (ChordT a) where+ beginTie = fmap beginTie+ endTie = fmap endTie+ toTied (ChordT as) = (ChordT bs, ChordT cs) where (bs,cs) = (unzip . fmap toTied) as+-- No HasPart instance, PartT must be outside ChordT+-- This restriction assures all chord notes are in the same part+instance HasChord (ChordT a) where+ type ChordNote (ChordT a) = a+ getChord (ChordT as) = as+-- Derived form the [a] instance+instance HasPitch a => HasPitch (ChordT a) where+ type Pitch (ChordT a) = Pitch a+ getPitch (ChordT as) = getPitch as+ modifyPitch f (ChordT as) = ChordT (modifyPitch f as)+instance HasDynamic a => HasDynamic (ChordT a) where+ setBeginCresc n (ChordT as) = ChordT (fmap (setBeginCresc n) as)+ setEndCresc n (ChordT as) = ChordT (fmap (setEndCresc n) as)+ setBeginDim n (ChordT as) = ChordT (fmap (setBeginDim n) as)+ setEndDim n (ChordT as) = ChordT (fmap (setEndDim n) as)+ setLevel n (ChordT as) = ChordT (fmap (setLevel n) as)+instance HasArticulation a => HasArticulation (ChordT a) where+ setEndSlur n (ChordT as) = ChordT (fmap (setEndSlur n) as)+ setContSlur n (ChordT as) = ChordT (fmap (setContSlur n) as)+ setBeginSlur n (ChordT as) = ChordT (fmap (setBeginSlur n) as)+ setAccLevel n (ChordT as) = ChordT (fmap (setAccLevel n) as)+ setStaccLevel n (ChordT as) = ChordT (fmap (setStaccLevel n) as)+instance HasTremolo a => HasTremolo (ChordT a) where+ setTrem n (ChordT as) = ChordT (fmap (setTrem n) as)+instance HasHarmonic a => HasHarmonic (ChordT a) where+ setHarmonic n (ChordT as) = ChordT (fmap (setHarmonic n) as)+instance HasSlide a => HasSlide (ChordT a) where+ setBeginGliss n (ChordT as) = ChordT (fmap (setBeginGliss n) as)+ setBeginSlide n (ChordT as) = ChordT (fmap (setBeginSlide n) as)+ setEndGliss n (ChordT as) = ChordT (fmap (setEndGliss n) as)+ setEndSlide n (ChordT as) = ChordT (fmap (setEndSlide n) as)+instance HasText a => HasText (ChordT a) where+ addText s (ChordT as) = ChordT (mapFirstL (addText s) as)+++-- TieT++instance HasPart a => HasPart (TieT a) where+ type Part (TieT a) = Part a+ getPart (TieT (_,x,_)) = getPart x+ modifyPart f (TieT (b,x,e)) = TieT (b,modifyPart f x,e)+instance HasChord a => HasChord (TieT a) where+ type ChordNote (TieT a ) = TieT (ChordNote a)+ getChord (TieT (b,x,e)) = fmap (\x -> TieT (b,x,e)) (getChord x)+instance HasPitch a => HasPitch (TieT a) where+ type Pitch (TieT a) = Pitch a+ getPitch (TieT (_,x,_)) = getPitch x+ modifyPitch f (TieT (b,x,e)) = TieT (b,modifyPitch f x,e)+instance HasDynamic a => HasDynamic (TieT a) where+ setBeginCresc n (TieT (b,x,e)) = TieT (b,setBeginCresc n x,e)+ setEndCresc n (TieT (b,x,e)) = TieT (b,setEndCresc n x,e)+ setBeginDim n (TieT (b,x,e)) = TieT (b,setBeginDim n x,e)+ setEndDim n (TieT (b,x,e)) = TieT (b,setEndDim n x,e)+ setLevel n (TieT (b,x,e)) = TieT (b,setLevel n x,e)+instance HasArticulation a => HasArticulation (TieT a) where+ setEndSlur n (TieT (b,x,e)) = TieT (b,setEndSlur n x,e)+ setContSlur n (TieT (b,x,e)) = TieT (b,setContSlur n x,e)+ setBeginSlur n (TieT (b,x,e)) = TieT (b,setBeginSlur n x,e)+ setAccLevel n (TieT (b,x,e)) = TieT (b,setAccLevel n x,e)+ setStaccLevel n (TieT (b,x,e)) = TieT (b,setStaccLevel n x,e)+instance HasTremolo a => HasTremolo (TieT a) where+ setTrem n (TieT (b,x,e)) = TieT (b,setTrem n x,e)+instance HasHarmonic a => HasHarmonic (TieT a) where+ setHarmonic n (TieT (b,x,e)) = TieT (b,setHarmonic n x,e)+instance HasSlide a => HasSlide (TieT a) where+ setBeginGliss n (TieT (b,x,e)) = TieT (b,setBeginGliss n x,e)+ setBeginSlide n (TieT (b,x,e)) = TieT (b,setBeginSlide n x,e)+ setEndGliss n (TieT (b,x,e)) = TieT (b,setEndGliss n x,e)+ setEndSlide n (TieT (b,x,e)) = TieT (b,setEndSlide n x,e)+instance HasText a => HasText (TieT a) where+ addText s (TieT (b,x,e)) = TieT (b, addText s x, e)+++-- DynamicT++-- end cresc/dim, level, begin cresc/dim+-- newtype DynamicT a = DynamicT { getDynamicT :: (Bool, Bool, Maybe Double, a, Bool, Bool) }++instance Tiable a => Tiable (DynamicT a) where+ beginTie = fmap beginTie+ endTie = fmap endTie+ toTied (DynamicT (ec,ed,l,a,bc,bd)) = (DynamicT (ec,ed,l,b,bc,bd),+ DynamicT (False,False,Nothing,c,False,False)) where (b,c) = toTied a+instance HasPart a => HasPart (DynamicT a) where+ type Part (DynamicT a) = Part a+ getPart (DynamicT (ec,ed,l,a,bc,bd)) = getPart a+ modifyPart f (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,modifyPart f a,bc,bd)+instance HasChord a => HasChord (DynamicT a) where+ type ChordNote (DynamicT a) = DynamicT (ChordNote a)+ getChord (DynamicT (ec,ed,l,a,bc,bd)) = fmap (\x -> DynamicT (ec,ed,l,x,bc,bd)) (getChord a)+instance HasPitch a => HasPitch (DynamicT a) where+ type Pitch (DynamicT a) = Pitch a+ getPitch (DynamicT (ec,ed,l,a,bc,bd)) = getPitch a+ modifyPitch f (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,modifyPitch f a,bc,bd)+instance HasDynamic (DynamicT a) where+ setBeginCresc bc (DynamicT (ec,ed,l,a,_ ,bd)) = DynamicT (ec,ed,l,a,bc,bd)+ setEndCresc ec (DynamicT (_ ,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,a,bc,bd)+ setBeginDim bd (DynamicT (ec,ed,l,a,bc,_ )) = DynamicT (ec,ed,l,a,bc,bd)+ setEndDim ed (DynamicT (ec,_ ,l,a,bc,bd)) = DynamicT (ec,ed,l,a,bc,bd)+ setLevel l (DynamicT (ec,ed,_,a,bc,bd)) = DynamicT (ec,ed,Just l,a,bc,bd)+instance HasArticulation a => HasArticulation (DynamicT a) where+ setEndSlur n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setEndSlur n a,bc,bd)+ setContSlur n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setContSlur n a,bc,bd)+ setBeginSlur n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setBeginSlur n a,bc,bd)+ setAccLevel n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setAccLevel n a,bc,bd)+ setStaccLevel n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setStaccLevel n a,bc,bd)+instance HasTremolo a => HasTremolo (DynamicT a) where+ setTrem n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setTrem n a,bc,bd)+instance HasHarmonic a => HasHarmonic (DynamicT a) where+ setHarmonic n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setHarmonic n a,bc,bd)+instance HasSlide a => HasSlide (DynamicT a) where+ setBeginGliss n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setBeginGliss n a,bc,bd)+ setBeginSlide n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setBeginSlide n a,bc,bd)+ setEndGliss n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setEndGliss n a,bc,bd)+ setEndSlide n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setEndSlide n a,bc,bd)+instance HasText a => HasText (DynamicT a) where+ addText s (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,addText s a,bc,bd)+++-- ArticulationT++-- end slur, cont slur, acc level, stacc level, begin slur+-- newtype ArticulationT a = ArticulationT { getArticulationT :: (Bool, Bool, Int, Int, a, Bool) }+++instance Tiable a => Tiable (ArticulationT a) where+ beginTie = fmap beginTie+ endTie = fmap endTie+ toTied (ArticulationT (es,us,al,sl,a,bs)) = (ArticulationT (False,us,al,sl,b,bs),+ ArticulationT (es, us,0,0,c,False)) where (b,c) = toTied a+instance HasPart a => HasPart (ArticulationT a) where+ type Part (ArticulationT a) = Part a+ getPart (ArticulationT (es,us,al,sl,a,bs)) = getPart a+ modifyPart f (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,modifyPart f a,bs)+instance HasChord a => HasChord (ArticulationT a) where+ type ChordNote (ArticulationT a) = ArticulationT (ChordNote a)+ getChord (ArticulationT (es,us,al,sl,a,bs)) = fmap (\x -> ArticulationT (es,us,al,sl,x,bs)) (getChord a)+instance HasPitch a => HasPitch (ArticulationT a) where+ type Pitch (ArticulationT a) = Pitch a+ getPitch (ArticulationT (es,us,al,sl,a,bs)) = getPitch a+ modifyPitch f (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,modifyPitch f a,bs)+instance HasDynamic a => HasDynamic (ArticulationT a) where+ setBeginCresc n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setBeginCresc n a,bs)+ setEndCresc n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setEndCresc n a,bs)+ setBeginDim n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setBeginDim n a,bs)+ setEndDim n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setEndDim n a,bs)+ setLevel n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setLevel n a,bs)+instance HasArticulation (ArticulationT a) where+ setEndSlur es (ArticulationT (_ ,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,a,bs)+ setContSlur us (ArticulationT (es,_ ,al,sl,a,bs)) = ArticulationT (es,us,al,sl,a,bs)+ setBeginSlur bs (ArticulationT (es,us,al,sl,a,_ )) = ArticulationT (es,us,al,sl,a,bs)+ setAccLevel al (ArticulationT (es,us,_ ,sl,a,bs)) = ArticulationT (es,us,al,sl,a,bs)+ setStaccLevel sl (ArticulationT (es,us,al,_ ,a,bs)) = ArticulationT (es,us,al,sl,a,bs)+instance HasTremolo a => HasTremolo (ArticulationT a) where+ setTrem n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setTrem n a,bs)+instance HasHarmonic a => HasHarmonic (ArticulationT a) where+ setHarmonic n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setHarmonic n a,bs)+instance HasSlide a => HasSlide (ArticulationT a) where+ setBeginGliss n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setBeginGliss n a,bs)+ setBeginSlide n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setBeginSlide n a,bs)+ setEndGliss n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setEndGliss n a,bs)+ setEndSlide n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setEndSlide n a,bs)+instance HasText a => HasText (ArticulationT a) where+ addText s (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,addText s a,bs)+++-- TremoloT++-- newtype TremoloT a = TremoloT { getTremoloT :: (Int, a) }+++instance Tiable a => Tiable (TremoloT a) where+ beginTie = fmap beginTie+ endTie = fmap endTie+ toTied (TremoloT (n,a)) = (TremoloT (n,b), TremoloT (n,c)) where (b,c) = toTied a+instance HasPart a => HasPart (TremoloT a) where+ type Part (TremoloT a) = Part a+ getPart (TremoloT (_,a)) = getPart a+ modifyPart f (TremoloT (n,x)) = TremoloT (n, modifyPart f x)+instance HasChord a => HasChord (TremoloT a) where+ type ChordNote (TremoloT a) = TremoloT (ChordNote a)+ getChord (TremoloT (n,x)) = fmap (\x -> TremoloT (n,x)) (getChord x)+instance HasPitch a => HasPitch (TremoloT a) where+ type Pitch (TremoloT a) = Pitch a+ getPitch (TremoloT (_,a)) = getPitch a+ modifyPitch f (TremoloT (n,x)) = TremoloT (n, modifyPitch f x)+instance HasDynamic a => HasDynamic (TremoloT a) where+ setBeginCresc n (TremoloT (v,x)) = TremoloT (v, setBeginCresc n x)+ setEndCresc n (TremoloT (v,x)) = TremoloT (v, setEndCresc n x)+ setBeginDim n (TremoloT (v,x)) = TremoloT (v, setBeginDim n x)+ setEndDim n (TremoloT (v,x)) = TremoloT (v, setEndDim n x)+ setLevel n (TremoloT (v,x)) = TremoloT (v, setLevel n x)+instance HasArticulation a => HasArticulation (TremoloT a) where+ setEndSlur n (TremoloT (v,x)) = TremoloT (v, setEndSlur n x)+ setContSlur n (TremoloT (v,x)) = TremoloT (v, setContSlur n x)+ setBeginSlur n (TremoloT (v,x)) = TremoloT (v, setBeginSlur n x)+ setAccLevel n (TremoloT (v,x)) = TremoloT (v, setAccLevel n x)+ setStaccLevel n (TremoloT (v,x)) = TremoloT (v, setStaccLevel n x)+instance HasTremolo (TremoloT a) where+ setTrem n (TremoloT (_,x)) = TremoloT (n,x)+instance HasHarmonic a => HasHarmonic (TremoloT a) where+ setHarmonic n (TremoloT (v,x)) = TremoloT (v, setHarmonic n x)+instance HasSlide a => HasSlide (TremoloT a) where+ setBeginGliss n (TremoloT (v,x)) = TremoloT (v, setBeginGliss n x)+ setBeginSlide n (TremoloT (v,x)) = TremoloT (v, setBeginSlide n x)+ setEndGliss n (TremoloT (v,x)) = TremoloT (v, setEndGliss n x)+ setEndSlide n (TremoloT (v,x)) = TremoloT (v, setEndSlide n x)+instance HasText a => HasText (TremoloT a) where+ addText s (TremoloT (n,x)) = TremoloT (n,addText s x)+++-- TextT++-- newtype TextT a = TextT { getTextT :: (Int, a) }++instance Tiable a => Tiable (TextT a) where+ beginTie = fmap beginTie+ endTie = fmap endTie+ toTied (TextT (n,a)) = (TextT (n,b), TextT (mempty,c)) where (b,c) = toTied a+instance HasPart a => HasPart (TextT a) where+ type Part (TextT a) = Part a+ getPart (TextT (_,a)) = getPart a+ modifyPart f (TextT (n,x)) = TextT (n, modifyPart f x)+instance HasChord a => HasChord (TextT a) where+ type ChordNote (TextT a) = TextT (ChordNote a)+ getChord (TextT (n,x)) = fmap (\x -> TextT (n,x)) (getChord x)+instance HasPitch a => HasPitch (TextT a) where+ type Pitch (TextT a) = Pitch a+ getPitch (TextT (_,a)) = getPitch a+ modifyPitch f (TextT (n,x)) = TextT (n, modifyPitch f x)+instance HasDynamic a => HasDynamic (TextT a) where+ setBeginCresc n (TextT (v,x)) = TextT (v, setBeginCresc n x)+ setEndCresc n (TextT (v,x)) = TextT (v, setEndCresc n x)+ setBeginDim n (TextT (v,x)) = TextT (v, setBeginDim n x)+ setEndDim n (TextT (v,x)) = TextT (v, setEndDim n x)+ setLevel n (TextT (v,x)) = TextT (v, setLevel n x)+instance HasArticulation a => HasArticulation (TextT a) where+ setEndSlur n (TextT (v,x)) = TextT (v, setEndSlur n x)+ setContSlur n (TextT (v,x)) = TextT (v, setContSlur n x)+ setBeginSlur n (TextT (v,x)) = TextT (v, setBeginSlur n x)+ setAccLevel n (TextT (v,x)) = TextT (v, setAccLevel n x)+ setStaccLevel n (TextT (v,x)) = TextT (v, setStaccLevel n x)+instance HasTremolo a => HasTremolo (TextT a) where+ setTrem n (TextT (s,x)) = TextT (s,setTrem n x)+instance HasHarmonic a => HasHarmonic (TextT a) where+ setHarmonic n (TextT (v,x)) = TextT (v, setHarmonic n x)+instance HasSlide a => HasSlide (TextT a) where+ setBeginGliss n (TextT (v,x)) = TextT (v, setBeginGliss n x)+ setBeginSlide n (TextT (v,x)) = TextT (v, setBeginSlide n x)+ setEndGliss n (TextT (v,x)) = TextT (v, setEndGliss n x)+ setEndSlide n (TextT (v,x)) = TextT (v, setEndSlide n x)+instance HasText (TextT a) where+ addText s (TextT (t,x)) = TextT (t ++ [s],x)+++-- HarmonicT++instance Tiable a => Tiable (HarmonicT a) where+ beginTie = fmap beginTie+ endTie = fmap endTie+ toTied (HarmonicT (n,a)) = (HarmonicT (n,b), HarmonicT (n,c)) where (b,c) = toTied a+instance HasPart a => HasPart (HarmonicT a) where+ type Part (HarmonicT a) = Part a+ getPart (HarmonicT (_,a)) = getPart a+ modifyPart f (HarmonicT (n,x)) = HarmonicT (n, modifyPart f x)+instance HasChord a => HasChord (HarmonicT a) where+ type ChordNote (HarmonicT a) = HarmonicT (ChordNote a)+ getChord (HarmonicT (n,x)) = fmap (\x -> HarmonicT (n,x)) (getChord x)+instance HasPitch a => HasPitch (HarmonicT a) where+ type Pitch (HarmonicT a) = Pitch a+ getPitch (HarmonicT (_,a)) = getPitch a+ modifyPitch f (HarmonicT (n,x)) = HarmonicT (n, modifyPitch f x)+instance HasDynamic a => HasDynamic (HarmonicT a) where+ setBeginCresc n (HarmonicT (v,x)) = HarmonicT (v, setBeginCresc n x)+ setEndCresc n (HarmonicT (v,x)) = HarmonicT (v, setEndCresc n x)+ setBeginDim n (HarmonicT (v,x)) = HarmonicT (v, setBeginDim n x)+ setEndDim n (HarmonicT (v,x)) = HarmonicT (v, setEndDim n x)+ setLevel n (HarmonicT (v,x)) = HarmonicT (v, setLevel n x)+instance HasArticulation a => HasArticulation (HarmonicT a) where+ setEndSlur n (HarmonicT (v,x)) = HarmonicT (v, setEndSlur n x)+ setContSlur n (HarmonicT (v,x)) = HarmonicT (v, setContSlur n x)+ setBeginSlur n (HarmonicT (v,x)) = HarmonicT (v, setBeginSlur n x)+ setAccLevel n (HarmonicT (v,x)) = HarmonicT (v, setAccLevel n x)+ setStaccLevel n (HarmonicT (v,x)) = HarmonicT (v, setStaccLevel n x)+instance HasTremolo a => HasTremolo (HarmonicT a) where+ setTrem n (HarmonicT (s,x)) = HarmonicT (s,setTrem n x)+instance HasHarmonic (HarmonicT a) where+ setHarmonic n (HarmonicT (_,x)) = HarmonicT (n,x)+instance HasSlide a => HasSlide (HarmonicT a) where+ setBeginGliss n (HarmonicT (s,x)) = HarmonicT (s,setBeginGliss n x)+ setBeginSlide n (HarmonicT (s,x)) = HarmonicT (s,setBeginSlide n x)+ setEndGliss n (HarmonicT (s,x)) = HarmonicT (s,setEndGliss n x)+ setEndSlide n (HarmonicT (s,x)) = HarmonicT (s,setEndSlide n x)+instance HasText a => HasText (HarmonicT a) where+ addText s (HarmonicT (n,x)) = HarmonicT (n,addText s x)+++-- SlideT+++instance Tiable a => Tiable (SlideT a) where+ beginTie = fmap beginTie+ endTie = fmap endTie+ toTied (SlideT (eg,es,a,bg,bs)) = (SlideT (eg, es, b,False,False),+ SlideT (False,False,c,bg, bs)) where (b,c) = toTied a+instance HasPart a => HasPart (SlideT a) where+ type Part (SlideT a) = Part a+ getPart (SlideT (eg,es,a,bg,bs)) = getPart a+ modifyPart f (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,modifyPart f a,bg,bs)+instance HasChord a => HasChord (SlideT a) where+ type ChordNote (SlideT a) = SlideT (ChordNote a)+ getChord (SlideT (eg,es,a,bg,bs)) = fmap (\x -> SlideT (eg,es,x,bg,bs)) (getChord a)+instance HasPitch a => HasPitch (SlideT a) where+ type Pitch (SlideT a) = Pitch a+ getPitch (SlideT (eg,es,a,bg,bs)) = getPitch a+ modifyPitch f (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,modifyPitch f a,bg,bs)+instance HasDynamic a => HasDynamic (SlideT a) where+ setBeginCresc n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setBeginCresc n a,bg,bs)+ setEndCresc n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setEndCresc n a,bg,bs)+ setBeginDim n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setBeginDim n a,bg,bs)+ setEndDim n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setEndDim n a,bg,bs)+ setLevel n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setLevel n a,bg,bs)+instance HasArticulation a => HasArticulation (SlideT a) where+ setEndSlur n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setEndSlur n a,bg,bs)+ setContSlur n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setContSlur n a,bg,bs)+ setBeginSlur n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setBeginSlur n a,bg,bs)+ setAccLevel n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setAccLevel n a,bg,bs)+ setStaccLevel n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setStaccLevel n a,bg,bs)+instance HasTremolo a => HasTremolo (SlideT a) where+ setTrem n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setTrem n a,bg,bs)+instance HasHarmonic a => HasHarmonic (SlideT a) where+ setHarmonic n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setHarmonic n a,bg,bs)+instance HasSlide (SlideT a) where+ setBeginGliss bg (SlideT (eg,es,a,_,bs)) = SlideT (eg,es,a,bg,bs)+ setBeginSlide bs (SlideT (eg,es,a,bg,_)) = SlideT (eg,es,a,bg,bs)+ setEndGliss eg (SlideT (_,es,a,bg,bs)) = SlideT (eg,es,a,bg,bs)+ setEndSlide es (SlideT (eg,_,a,bg,bs)) = SlideT (eg,es,a,bg,bs)+instance HasText a => HasText (SlideT a) where+ addText s (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,addText s a,bg,bs)+++-------------------------------------------------------------------------------------+-- Num, Integral, Enum and Bounded+-------------------------------------------------------------------------------------++-- PartT++instance (Enum v, Eq v, Num a) => Num (PartT v a) where+ PartT (v,a) + PartT (_,b) = PartT (v,a+b)+ PartT (v,a) * PartT (_,b) = PartT (v,a*b)+ PartT (v,a) - PartT (_,b) = PartT (v,a-b)+ abs (PartT (v,a)) = PartT (v,abs a)+ signum (PartT (v,a)) = PartT (v,signum a)+ fromInteger a = PartT (toEnum 0,fromInteger a)++instance (Enum v, Enum a) => Enum (PartT v a) where+ toEnum a = PartT (toEnum 0, toEnum a) -- TODO use def, mempty or minBound?+ fromEnum (PartT (v,a)) = fromEnum a++instance (Enum v, Bounded a) => Bounded (PartT v a) where+ minBound = PartT (toEnum 0, minBound)+ maxBound = PartT (toEnum 0, maxBound)++instance (Enum v, Ord v, Num a, Ord a, Real a) => Real (PartT v a) where+ toRational (PartT (v,a)) = toRational a++instance (Enum v, Ord v, Real a, Enum a, Integral a) => Integral (PartT v a) where+ PartT (v,a) `quotRem` PartT (_,b) = (PartT (v,q), PartT (v,r)) where (q,r) = a `quotRem` b+ toInteger (PartT (v,a)) = toInteger a+++-- TieT++instance Num a => Num (TieT a) where+ TieT (et,a,bt) + TieT (_,b,_) = TieT (et,a+b,bt)+ TieT (et,a,bt) * TieT (_,b,_) = TieT (et,a*b,bt)+ TieT (et,a,bt) - TieT (_,b,_) = TieT (et,a-b,bt)+ abs (TieT (et,a,bt)) = TieT (et,abs a,bt)+ signum (TieT (et,a,bt)) = TieT (et,signum a,bt)+ fromInteger a = TieT (False,fromInteger a,False)++instance Enum a => Enum (TieT a) where+ toEnum a = TieT (False,toEnum a,False)+ fromEnum (TieT (_,a,_)) = fromEnum a++instance Bounded a => Bounded (TieT a) where+ minBound = TieT (False,minBound,False)+ maxBound = TieT (False,maxBound,False)++instance (Num a, Ord a, Real a) => Real (TieT a) where+ toRational (TieT (_,a,_)) = toRational a++instance (Real a, Enum a, Integral a) => Integral (TieT a) where+ TieT (et,a,bt) `quotRem` TieT (_,b,_) = (TieT (et,q,bt), TieT (et,r,bt)) where (q,r) = a `quotRem` b+ toInteger (TieT (_,a,_)) = toInteger a+++-- DynamicT++instance Num a => Num (DynamicT a) where+ DynamicT (p,q,r,a,s,t) + DynamicT (_,_,_,b,_,_) = DynamicT (p,q,r,a+b,s,t)+ DynamicT (p,q,r,a,s,t) * DynamicT (_,_,_,b,_,_) = DynamicT (p,q,r,a*b,s,t)+ DynamicT (p,q,r,a,s,t) - DynamicT (_,_,_,b,_,_) = DynamicT (p,q,r,a-b,s,t)+ abs (DynamicT (p,q,r,a,s,t)) = DynamicT (p,q,r,abs a,s,t)+ signum (DynamicT (p,q,r,a,s,t)) = DynamicT (p,q,r,signum a,s,t)+ fromInteger a = DynamicT (False,False,Nothing,fromInteger a,False,False)++instance Enum a => Enum (DynamicT a) where+ toEnum a = DynamicT (False,False,Nothing,toEnum a,False,False)+ fromEnum (DynamicT (_,_,_,a,_,_)) = fromEnum a++instance Bounded a => Bounded (DynamicT a) where+ minBound = DynamicT (False,False,Nothing,minBound,False,False)+ maxBound = DynamicT (False,False,Nothing,maxBound,False,False)++instance (Num a, Ord a, Real a) => Real (DynamicT a) where+ toRational (DynamicT (_,_,_,a,_,_)) = toRational a++instance (Real a, Enum a, Integral a) => Integral (DynamicT a) where+ DynamicT (p,q,r,a,s,t) `quotRem` DynamicT (_,_,_,b,_,_) = (DynamicT (p,q,r,q',s,t), DynamicT (p,q,r,r',s,t)) where (q',r') = a `quotRem` b+ toInteger (DynamicT (_,_,_,a,_,_)) = toInteger a+++-- ArticulationT++instance Num a => Num (ArticulationT a) where+ ArticulationT (p,q,r,s,a,t) + ArticulationT (_,_,_,_,b,_) = ArticulationT (p,q,r,s,a+b,t)+ ArticulationT (p,q,r,s,a,t) * ArticulationT (_,_,_,_,b,_) = ArticulationT (p,q,r,s,a*b,t)+ ArticulationT (p,q,r,s,a,t) - ArticulationT (_,_,_,_,b,_) = ArticulationT (p,q,r,s,a-b,t)+ abs (ArticulationT (p,q,r,s,a,t)) = ArticulationT (p,q,r,s,abs a,t)+ signum (ArticulationT (p,q,r,s,a,t)) = ArticulationT (p,q,r,s,signum a,t)+ fromInteger a = ArticulationT (False,False,0,0,fromInteger a,False)++instance Enum a => Enum (ArticulationT a) where+ toEnum a = ArticulationT (False,False,0,0,toEnum a,False)+ fromEnum (ArticulationT (_,_,_,_,a,_)) = fromEnum a++instance Bounded a => Bounded (ArticulationT a) where+ minBound = ArticulationT (False,False,0,0,minBound,False)+ maxBound = ArticulationT (False,False,0,0,maxBound,False)++instance (Num a, Ord a, Real a) => Real (ArticulationT a) where+ toRational (ArticulationT (_,_,_,_,a,_)) = toRational a++instance (Real a, Enum a, Integral a) => Integral (ArticulationT a) where+ ArticulationT (p,q,r,s,a,t) `quotRem` ArticulationT (_,_,_,_,b,_) = (ArticulationT (p,q,r,s,q',t), ArticulationT (p,q,r,s,r',t)) where (q',r') = a `quotRem` b+ toInteger (ArticulationT (_,_,_,_,a,_)) = toInteger a+++-- TremoloT++instance Num a => Num (TremoloT a) where+ TremoloT (v,a) + TremoloT (_,b) = TremoloT (v,a+b)+ TremoloT (v,a) * TremoloT (_,b) = TremoloT (v,a*b)+ TremoloT (v,a) - TremoloT (_,b) = TremoloT (v,a-b)+ abs (TremoloT (v,a)) = TremoloT (v,abs a)+ signum (TremoloT (v,a)) = TremoloT (v,signum a)+ fromInteger a = TremoloT (toEnum 0,fromInteger a)++instance Enum a => Enum (TremoloT a) where+ toEnum a = TremoloT (0, toEnum a) -- TODO use def, mempty or minBound?+ fromEnum (TremoloT (v,a)) = fromEnum a++instance Bounded a => Bounded (TremoloT a) where+ minBound = TremoloT (0, minBound)+ maxBound = TremoloT (0, maxBound)++instance (Num a, Real a) => Real (TremoloT a) where+ toRational (TremoloT (_,a)) = toRational a++instance (Real a, Enum a, Integral a) => Integral (TremoloT a) where+ TremoloT (v,a) `quotRem` TremoloT (_,b) = (TremoloT (v,q), TremoloT (v,r)) where (q,r) = a `quotRem` b+ toInteger (TremoloT (_,a)) = toInteger a+++-- TextT++instance Num a => Num (TextT a) where+ TextT (v,a) + TextT (_,b) = TextT (v,a+b)+ TextT (v,a) * TextT (_,b) = TextT (v,a*b)+ TextT (v,a) - TextT (_,b) = TextT (v,a-b)+ abs (TextT (v,a)) = TextT (v,abs a)+ signum (TextT (v,a)) = TextT (v,signum a)+ fromInteger a = TextT (mempty,fromInteger a)++instance Enum a => Enum (TextT a) where+ toEnum a = TextT (mempty, toEnum a) -- TODO use def, mempty or minBound?+ fromEnum (TextT (v,a)) = fromEnum a++instance Bounded a => Bounded (TextT a) where+ minBound = TextT (mempty, minBound)+ maxBound = TextT (mempty, maxBound)++instance (Num a, Ord a, Real a) => Real (TextT a) where+ toRational (TextT (v,a)) = toRational a++instance (Real a, Enum a, Integral a) => Integral (TextT a) where+ TextT (v,a) `quotRem` TextT (_,b) = (TextT (v,q), TextT (v,r)) where (q,r) = a `quotRem` b+ toInteger (TextT (v,a)) = toInteger a+++-- HarmonicT++instance Num a => Num (HarmonicT a) where+ HarmonicT (v,a) + HarmonicT (_,b) = HarmonicT (v,a+b)+ HarmonicT (v,a) * HarmonicT (_,b) = HarmonicT (v,a*b)+ HarmonicT (v,a) - HarmonicT (_,b) = HarmonicT (v,a-b)+ abs (HarmonicT (v,a)) = HarmonicT (v,abs a)+ signum (HarmonicT (v,a)) = HarmonicT (v,signum a)+ fromInteger a = HarmonicT (toEnum 0,fromInteger a)++instance Enum a => Enum (HarmonicT a) where+ toEnum a = HarmonicT (0, toEnum a) -- TODO use def, mempty or minBound?+ fromEnum (HarmonicT (v,a)) = fromEnum a++instance Bounded a => Bounded (HarmonicT a) where+ minBound = HarmonicT (0, minBound)+ maxBound = HarmonicT (0, maxBound)++instance (Num a, Ord a, Real a) => Real (HarmonicT a) where+ toRational (HarmonicT (v,a)) = toRational a++instance (Real a, Enum a, Integral a) => Integral (HarmonicT a) where+ HarmonicT (v,a) `quotRem` HarmonicT (_,b) = (HarmonicT (v,q), HarmonicT (v,r)) where (q,r) = a `quotRem` b+ toInteger (HarmonicT (v,a)) = toInteger a+++-- SlideT++instance Num a => Num (SlideT a) where+ SlideT (eg,es,a,bg,bs) + SlideT (_,_,b,_,_) = SlideT (eg,es,a+b,bg,bs)+ SlideT (eg,es,a,bg,bs) * SlideT (_,_,b,_,_) = SlideT (eg,es,a*b,bg,bs)+ SlideT (eg,es,a,bg,bs) - SlideT (_,_,b,_,_) = SlideT (eg,es,a-b,bg,bs)+ abs (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,abs a,bg,bs)+ signum (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,signum a,bg,bs)+ fromInteger a = SlideT (False,False,fromInteger a,False,False)++instance Enum a => Enum (SlideT a) where+ toEnum a = SlideT (False,False,toEnum a,False,False)+ fromEnum (SlideT (_,_,a,_,_)) = fromEnum a++instance Bounded a => Bounded (SlideT a) where+ minBound = SlideT (False,False,minBound,False,False)+ maxBound = SlideT (False,False,maxBound,False,False)++instance (Num a, Ord a, Real a) => Real (SlideT a) where+ toRational (SlideT (_,_,a,_,_)) = toRational a++instance (Real a, Enum a, Integral a) => Integral (SlideT a) where+ SlideT (eg,es,a,bg,bs) `quotRem` SlideT (_,_,b,_,_) = (SlideT (eg,es,q',bg,bs), SlideT (eg,es,r',bg,bs)) where (q',r') = a `quotRem` b+ toInteger (SlideT (_,_,a,_,_)) = toInteger a++++++mapFirstL f = mapFirstMiddleLast f id id++mapFirstMiddleLast :: (a -> b) -> (a -> b) -> (a -> b) -> [a] -> [b]+mapFirstMiddleLast f g h = go+ where+ go [] = []+ go [a] = [f a]+ go [a,b] = [f a, h b]+ go xs = [f $ head xs] +++ map g (tail $ init xs) +++ [h $ last xs]
src/Music/Score/Ornaments.hs view
@@ -1,10 +1,13 @@- + {-# LANGUAGE TypeFamilies, DeriveFunctor, DeriveFoldable,+ DeriveDataTypeable, FlexibleInstances,- GeneralizedNewtypeDeriving #-} + FlexibleContexts,+ ConstraintKinds,+ GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------------- -- |@@ -16,7 +19,7 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) ----- Provides a musical score represenation.+-- Provides functions for manipulating ornaments (and some other things...). -- ------------------------------------------------------------------------------------- @@ -30,7 +33,7 @@ HarmonicT(..), HasSlide(..), SlideT(..),- + tremolo, text, harmonic,@@ -41,28 +44,28 @@ import Data.Ratio import Data.Foldable import Data.Monoid+import Data.Typeable import qualified Data.List as List import Data.VectorSpace import Data.AffineSpace -import Music.Score.Part-import Music.Score.Score-import Music.Score.Duration-import Music.Score.Time import Music.Score.Voice+import Music.Score.Score+import Music.Time+import Music.Score.Part import Music.Score.Combinators class HasTremolo a where setTrem :: Int -> a -> a newtype TremoloT a = TremoloT { getTremoloT :: (Int, a) }- deriving (Eq, Show, Ord, Functor{-, Foldable-})+ deriving (Eq, Show, Ord, Functor{-, Foldable-}, Typeable) class HasText a where addText :: String -> a -> a newtype TextT a = TextT { getTextT :: ([String], a) }- deriving (Eq, Show, Ord, Functor{-, Foldable-})+ deriving (Eq, Show, Ord, Functor{-, Foldable-}, Typeable) -- 0 for none, positive for natural, negative for artificial@@ -70,7 +73,7 @@ setHarmonic :: Int -> a -> a newtype HarmonicT a = HarmonicT { getHarmonicT :: (Int, a) }- deriving (Eq, Show, Ord, Functor{-, Foldable-})+ deriving (Eq, Show, Ord, Functor{-, Foldable-}, Typeable) -- end gliss/slide, level, begin gliss/slide class HasSlide a where@@ -80,66 +83,40 @@ setEndSlide :: Bool -> a -> a newtype SlideT a = SlideT { getSlideT :: (Bool, Bool, a, Bool, Bool) }- deriving (Eq, Show, Ord, Functor{-, Foldable-})+ deriving (Eq, Show, Ord, Functor{-, Foldable-}, Typeable) -- |--- Add tremolo cross-beams to all notes in the score.+-- Set the number of tremolo divisions for all notes in the score. ---tremolo :: (Functor f, HasTremolo b) => Int -> f b -> f b+tremolo :: (Functor s, HasTremolo b) => Int -> s b -> s b tremolo n = fmap (setTrem n) -- |--- Add text to the first note in the score.+-- Attach the given text to the first note in the score. ---text :: (Ord v, v ~ Voice b, HasVoice b, HasText b) => String -> Score b -> Score b-text s = mapSep (addText s) id id+text :: (HasEvents s, HasPart' a, HasText a) => String -> s a -> s a+text s = mapPhrase (addText s) id id -- | -- Slide between the first and the last note. ---slide :: (Ord v, v ~ Voice b, HasVoice b, HasSlide b) => Score b -> Score b-slide = mapSep (setBeginSlide True) id (setEndSlide True)+slide :: (HasEvents s, HasPart' a, HasSlide a) => s a -> s a+slide = mapPhrase (setBeginSlide True) id (setEndSlide True) +glissando :: (HasEvents s, HasPart' a, HasSlide a) => s a -> s a+glissando = mapPhrase (setBeginGliss True) id (setEndGliss True) -- | -- Make all notes natural harmonics on the given overtone (1 for octave, 2 for fifth etc). -- Sounding pitch is unaffected, but notated output is transposed automatically. ---harmonic :: (Ord v, v ~ Voice b, HasVoice b, HasHarmonic b) => Int -> Score b -> Score b-harmonic n = mapSep f f f where f = setHarmonic n+harmonic :: (Functor s, HasHarmonic a) => Int -> s a -> s a+harmonic n = fmap (setHarmonic n) -- | -- Make all notes natural harmonics on the given overtone (1 for octave, 2 for fifth etc). -- Sounding pitch is unaffected, but notated output is transposed automatically. ---artificial :: (Ord v, v ~ Voice b, HasVoice b, HasHarmonic b) => Score b -> Score b-artificial = mapSep f f f where f = setHarmonic (-4)---- FIXME consolidate---- | --- Map over first, middle and last elements of list.--- Biased on first, then on first and last for short lists.--- -mapSepL :: (a -> b) -> (a -> b) -> (a -> b) -> [a] -> [b]-mapSepL f g h [] = []-mapSepL f g h [a] = [f a]-mapSepL f g h [a,b] = [f a, h b]-mapSepL f g h xs = [f $ head xs] ++ (map g $ tail $ init xs) ++ [h $ last xs]--mapSep :: (HasVoice a, Ord v, v ~ Voice a) => (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b-mapSep f g h sc = fixDur . mapVoices (fmap $ mapSepPart f g h) $ sc- where- fixDur a = padAfter (duration sc - duration a) a--mapSepPart :: (a -> b) -> (a -> b) -> (a -> b) -> Score a -> Score b-mapSepPart f g h sc = mconcat . mapSepL (fmap f) (fmap g) (fmap h) . fmap toSc . perform $ sc- where - fixDur a = padAfter (duration sc - duration a) a- toSc (t,d,x) = delay (t .-. 0) . stretch d $ note x- third f (a,b,c) = (a,b,f c)--padAfter :: Duration -> Score a -> Score a-padAfter d a = a |> (rest^*d) +artificial :: (Functor s, HasHarmonic a) => s a -> s a+artificial = fmap f where f = setHarmonic (-4) -
src/Music/Score/Part.hs view
@@ -1,9 +1,14 @@- + {-# LANGUAGE TypeFamilies, DeriveFunctor, DeriveFoldable,- GeneralizedNewtypeDeriving #-} + DeriveDataTypeable,+ FlexibleInstances,+ FlexibleContexts,+ ConstraintKinds,+ OverloadedStrings,+ GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------------- -- |@@ -15,99 +20,203 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) ----- Provides a musical score represenation.+-- Provides partwise traversal, part composition and extraction. -- ------------------------------------------------------------------------------------- + module Music.Score.Part (- Part(..)- ) where+ HasPart(..),+ HasPart',+ -- PartName(..),+ PartT(..),+ extract,+ extractParts,+ mapPart,+ mapAllParts,+ mapParts,+ getParts,+ setParts,+ modifyParts, -import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)+ -- ** Part composition+ (</>),+ moveParts,+ moveToPart,+ ) where +import Control.Monad (ap, mfilter, join, liftM, MonadPlus(..)) import Data.Semigroup-import Control.Applicative-import Control.Monad (ap, join, MonadPlus(..))+import Data.String import Data.Foldable-import Data.Traversable-import Data.Maybe-import Data.Either-import Data.Function (on)+import Data.Typeable import Data.Ord (comparing)-import Data.Ratio+import Data.Traversable+import qualified Data.List as List import Data.VectorSpace import Data.AffineSpace+import Data.Ratio -import Music.Score.Time-import Music.Score.Duration+import Music.Time ----------------------------------------------------------------------------------------- Part type--------------------------------------------------------------------------------------+-- |+-- Class of types with an associated part.+--+-- The part type can be any type that is orddered.+--+class HasPart a where+ -- | Associated part type. Should implement 'Ord' and 'Show'.+ type Part a :: * + -- | Get the voice of the given note.+ getPart :: a -> Part a++ -- | Set the voice of the given note.+ setPart :: Part a -> a -> a++ -- | Modify the voice of the given note.+ modifyPart :: (Part a -> Part a) -> a -> a++ setPart n = modifyPart (const n)+ modifyPart f x = x++newtype PartT n a = PartT { getPartT :: (n, a) }+ deriving (Eq, Ord, Show, Functor, Typeable)++instance HasPart () where { type Part () = Integer ; getPart _ = 0 }+instance HasPart Double where { type Part Double = Integer ; getPart _ = 0 }+instance HasPart Float where { type Part Float = Integer ; getPart _ = 0 }+instance HasPart Int where { type Part Int = Integer ; getPart _ = 0 }+instance HasPart Integer where { type Part Integer = Integer ; getPart _ = 0 }+instance Integral a => HasPart (Ratio a) where { type Part (Ratio a) = Integer ; getPart _ = 0 }+ -- |--- A part is a sorted list of relative-time notes and rests.+-- Like 'HasPart', but enforces the part to be ordered.+-- This is usually required for part separation and traversal. ----- Part is a 'Monoid' under sequential composition. 'mempty' is the empty part and 'mappend'--- appends parts.+type HasPart' a = (Ord (Part a), HasPart a)++-- |+-- Extract parts from the a score. ----- Part has an 'Applicative' instance derived from the 'Monad' instance.+-- The parts are returned in the order defined the associated 'Ord' instance part type.+-- You can recompose the score with 'mconcat', i.e. ----- Part is a 'Monad'. 'return' creates a part containing a single value of duration--- one, and '>>=' transforms the values of a part, allowing the addition and--- removal of values under relative duration. Perhaps more intuitively, 'join' scales --- each inner part to the duration of the outer part, then removes the --- intermediate structure. +-- > mconcat . extract = id ----- > let p = Part [(1, Just 0), (2, Just 1)] :: Part Int--- >--- > p >>= \x -> Part [ (1, Just $ toEnum $ x+65), --- > (3, Just $ toEnum $ x+97) ] :: Part Char--- >--- > ===> Part {getPart = [ (1 % 1,Just 'A'),--- > (3 % 1,Just 'a'),--- > (2 % 1,Just 'B'),--- > (6 % 1,Just 'b') ]}+-- Simple type ----- Part is a 'VectorSpace' using sequential composition as addition, and time scaling--- as scalar multiplication.+-- > Score a -> [Score a] ---newtype Part a = Part { getPart :: [(Duration, a)] }- deriving (Eq, Ord, Show, Functor, Foldable, Monoid)+extract :: (HasPart' a, MonadPlus s, Performable s) => s a -> [s a]+extract sc = fmap (`extract'` sc) (getParts sc)+ where+ extract' v = mfilter ((== v) . getPart) -instance Semigroup (Part a) where- (<>) = mappend+-- |+-- Extract parts from the a score.+--+-- The parts are returned in the order defined the associated 'Ord' instance part type.+--+-- Simple type+--+-- > Score a -> [(Part a, Score a)]+--+extractParts :: (HasPart' a, MonadPlus s, Performable s) => s a -> [(Part a, s a)]+extractParts sc = fmap (`extractParts2` sc) (getParts sc)+ where+ extractParts2 v = (\x -> (v,x)) . mfilter ((== v) . getPart) -instance Applicative Part where- pure = return- (<*>) = ap -instance Monad Part where- return a = Part [(1, a)]- a >>= k = join' $ fmap k a- where- join' (Part ps) = foldMap (uncurry (*^)) ps+-- |+-- Map over a single voice in the given score.+--+-- > Part -> (Score a -> Score a) -> Score a -> Score a+--+mapPart :: (Ord v, v ~ Part a, HasPart a, MonadPlus s, Performable s, Enum b) => b -> (s a -> s a) -> s a -> s a+mapPart n f = mapAllParts (zipWith ($) (replicate (fromEnum n) id ++ [f] ++ repeat id)) -instance AdditiveGroup (Part a) where- zeroV = mempty- (^+^) = mappend- negateV = id+-- |+-- Map over all parts in the given score.+--+-- > ([Score a] -> [Score a]) -> Score a -> Score a+--+mapAllParts :: (HasPart' a, MonadPlus s, Performable s) => ([s a] -> [s b]) -> s a -> s b+mapAllParts f = msum . f . extract -instance VectorSpace (Part a) where- type Scalar (Part a) = Duration- n *^ Part as = Part (fmap (first (n*^)) as)+-- |+-- Map over all parts in the given score.+--+-- > ([Score a] -> [Score a]) -> Score a -> Score a+--+mapParts :: (HasPart' a, MonadPlus s, Performable s) => (s a -> s b) -> s a -> s b+mapParts f = mapAllParts (fmap f) -instance HasDuration (Part a) where- duration (Part []) = 0- duration (Part as) = sum (fmap fst as)- +-- |+-- Get all parts in the given score. Returns a list of parts.+--+-- > Score a -> [Part]+--+getParts :: (HasPart' a, Performable s) => s a -> [Part a]+getParts = List.sort . List.nub . fmap getPart . toList' +-- |+-- Set all parts in the given score.+--+-- > Part -> Score a -> Score a+--+setParts :: (HasPart a, Functor s) => Part a -> s a -> s a+setParts n = fmap (setPart n) +-- |+-- Modify all parts in the given score.+--+-- > (Part -> Part) -> Score a -> Score a+--+modifyParts :: (HasPart a, Functor s) => (Part a -> Part a) -> s a -> s a+modifyParts n = fmap (modifyPart n) -list z f [] = z-list z f xs = f xs+--------------------------------------------------------------------------------+-- Part composition+-------------------------------------------------------------------------------- -first f (x,y) = (f x, y)-second f (x,y) = (x, f y)+infixr 6 </>++-- |+-- Similar to '<>', but increases parts in the second part to prevent collision.+--+(</>) :: (HasPart' a, Enum (Part a), Functor s, MonadPlus s, Performable s) => s a -> s a -> s a+a </> b = a `mplus` moveParts offset b+ where+ -- max voice in a + 1+ offset = succ $ maximum' 0 $ fmap fromEnum $ getParts a++-- |+-- Move down one voice (all parts).+--+moveParts :: (HasPart' a, Enum (Part a), Integral b, Functor s) => b -> s a -> s a+moveParts x = modifyParts (successor x)++-- |+-- Move top-part to the specific voice (other parts follow).+--+moveToPart :: (HasPart' a, Enum (Part a), Functor s) => Part a -> s a -> s a+moveToPart v = moveParts (fromEnum v)+++++-------------------------------------------------------------------------------------++successor :: (Integral b, Enum a) => b -> a -> a+successor n | n < 0 = (!! fromIntegral (abs n)) . iterate pred+ | n >= 0 = (!! fromIntegral n) . iterate succ++maximum' :: (Ord a, Foldable t) => a -> t a -> a+maximum' z = option z getMax . foldMap (Option . Just . Max)++minimum' :: (Ord a, Foldable t) => a -> t a -> a+minimum' z = option z getMin . foldMap (Option . Just . Min)+
src/Music/Score/Pitch.hs view
@@ -1,10 +1,11 @@- + {-# LANGUAGE TypeFamilies, DeriveFunctor, DeriveFoldable,+ DeriveDataTypeable, FlexibleInstances,- GeneralizedNewtypeDeriving #-} + GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------------- -- |@@ -16,7 +17,7 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) ----- Provides a musical score represenation.+-- Provides pitch manipulation. -- ------------------------------------------------------------------------------------- @@ -32,39 +33,34 @@ import Control.Monad (ap, mfilter, join, liftM, MonadPlus(..)) import Data.String import Data.Foldable+import Data.Typeable import Data.Traversable import qualified Data.List as List import Data.VectorSpace import Data.AffineSpace import Data.Ratio -import Music.Score.Part-import Music.Score.Score-import Music.Score.Duration-import Music.Score.Time-import Music.Score.Ties- class HasPitch a where- -- | + -- | -- Associated pitch type. Should implement 'Eq' and 'Show' to be usable.- -- + -- type Pitch a :: * -- | -- Get the pitch of the given note.- -- + -- getPitch :: a -> Pitch a -- | -- Set the pitch of the given note.- -- + -- setPitch :: Pitch a -> a -> a -- | -- Modify the pitch of the given note.- -- + -- modifyPitch :: (Pitch a -> Pitch a) -> a -> a- + setPitch n = modifyPitch (const n) modifyPitch f x = x @@ -84,6 +80,12 @@ instance HasPitch Integer where { type Pitch Integer = Integer ; getPitch = id; modifyPitch = id } instance Integral a => HasPitch (Ratio a) where { type Pitch (Ratio a) = (Ratio a) ; getPitch = id; modifyPitch = id } +instance HasPitch a => HasPitch [a] where+ type Pitch [a] = Pitch a+ getPitch [] = error "getPitch: Empty list"+ getPitch as = getPitch (head as)+ modifyPitch f as = fmap (modifyPitch f) as+ -- | -- Get all pitches in the given score. Returns a list of pitches. --@@ -107,3 +109,4 @@ -- modifyPitches :: (HasPitch a, Functor s) => (Pitch a -> Pitch a) -> s a -> s a modifyPitches n = fmap (modifyPitch n)+
src/Music/Score/Rhythm.hs view
@@ -2,9 +2,9 @@ {-# LANGUAGE TypeFamilies, DeriveFunctor,- DeriveFoldable, + DeriveFoldable, GeneralizedNewtypeDeriving,- ScopedTypeVariables #-} + ScopedTypeVariables #-} ------------------------------------------------------------------------------------- -- |@@ -16,13 +16,11 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) ----- Provides a musical score represenation.--- ------------------------------------------------------------------------------------- module Music.Score.Rhythm ( -- * Rhythm type- Rhythm(..), + Rhythm(..), -- * Quantization quantize,@@ -46,29 +44,36 @@ import Text.Parsec hiding ((<|>)) import Text.Parsec.Pos -import Music.Score.Time-import Music.Score.Duration+import Music.Time import Music.Score.Ties -data Rhythm a - = Beat Duration a -- d is divisible by 2+data Rhythm a+ = Beat DurationT a -- d is divisible by 2+ | Group [Rhythm a] -- normal note sequence | Dotted Int (Rhythm a) -- n > 0.- | Tuplet Duration (Rhythm a) -- d is an emelent of 'tupletMods'.- | Bound Duration (Rhythm a) -- tied from duration- | Rhythms [Rhythm a] -- normal note sequence+ | Tuplet DurationT (Rhythm a) -- d is an emelent of 'tupletMods'. deriving (Eq, Show, Functor, Foldable) -- RInvTuplet Duration (Rhythm a) +getBeatValue :: Rhythm a -> a+getBeatValue (Beat d a) = a+getBeatValue _ = error "getBeatValue: Not a beat"++getBeatDuration :: Rhythm a -> DurationT+getBeatDuration (Beat d a) = d+getBeatDuration _ = error "getBeatValue: Not a beat"++ instance Semigroup (Rhythm a) where (<>) = mappend --- Catenates using 'Rhythms'+-- Catenates using 'Group' instance Monoid (Rhythm a) where- mempty = Rhythms []- Rhythms as `mappend` Rhythms bs = Rhythms (as <> bs)- r `mappend` Rhythms bs = Rhythms ([r] <> bs)- Rhythms as `mappend` r = Rhythms (as <> [r])+ mempty = Group []+ Group as `mappend` Group bs = Group (as <> bs)+ r `mappend` Group bs = Group ([r] <> bs)+ Group as `mappend` r = Group (as <> [r]) instance AdditiveGroup (Rhythm a) where zeroV = error "No zeroV for (Rhythm a)"@@ -76,37 +81,38 @@ negateV = error "No negateV for (Rhythm a)" instance VectorSpace (Rhythm a) where- type Scalar (Rhythm a) = Duration+ type Scalar (Rhythm a) = DurationT a *^ Beat d x = Beat (a*d) x Beat d x `subDur` d' = Beat (d-d') x +{- instance HasDuration (Rhythm a) where duration (Beat d _) = d duration (Dotted n a) = duration a * dotMod n duration (Tuplet c a) = duration a * c- duration (Bound d a) = duration a + d- duration (Rhythms as) = sum (fmap duration as) + duration (Group as) = sum (fmap duration as)+-} -quantize :: [(Duration, a)] -> Either String (Rhythm a)+quantize :: Tiable a => [(DurationT, a)] -> Either String (Rhythm a) quantize = quantize' (atEnd rhythm) -- Internal... -testQuantize :: [Duration] -> Either String (Rhythm ())+testQuantize :: [DurationT] -> Either String (Rhythm ()) testQuantize = quantize' (atEnd rhythm) . fmap (\x->(x,())) -dotMod :: Int -> Duration+dotMod :: Int -> DurationT dotMod n = dotMods !! (n-1) -- [3/2, 7/4, 15/8, 31/16 ..]-dotMods :: [Duration]+dotMods :: [DurationT] dotMods = zipWith (/) (fmap pred $ drop 2 times2) (drop 1 times2) where times2 = iterate (*2) 1 -tupletMods :: [Duration]+tupletMods :: [DurationT] tupletMods = [2/3, 4/5, {-4/6,-} 4/7, 8/9] @@ -115,8 +121,8 @@ -- 3/2, 6/4 for inverted tuplets data RState = RState {- timeMod :: Duration, -- time modification; notatedDur * timeMod = actualDur- timeSub :: Duration, -- time subtraction (in bound note)+ timeMod :: DurationT, -- time modification; notatedDur * timeMod = actualDur+ timeSub :: DurationT, -- time subtraction (in bound note) tupleDepth :: Int } @@ -124,24 +130,24 @@ mempty = RState { timeMod = 1, timeSub = 0, tupleDepth = 0 } a `mappend` _ = a -modifyTimeMod :: (Duration -> Duration) -> RState -> RState+modifyTimeMod :: (DurationT -> DurationT) -> RState -> RState modifyTimeMod f (RState tm ts td) = RState (f tm) ts td -modifyTimeSub :: (Duration -> Duration) -> RState -> RState+modifyTimeSub :: (DurationT -> DurationT) -> RState -> RState modifyTimeSub f (RState tm ts td) = RState tm (f ts) td modifyTupleDepth :: (Int -> Int) -> RState -> RState modifyTupleDepth f (RState tm ts td) = RState tm ts (f td) --- | --- A @RhytmParser a b@ converts (Part a) to b.-type RhythmParser a b = Parsec [(Duration, a)] RState b+-- |+-- A @RhytmParser a b@ converts (Voice a) to b.+type RhythmParser a b = Parsec [(DurationT, a)] RState b -quantize' :: RhythmParser a b -> [(Duration, a)] -> Either String b+quantize' :: Tiable a => RhythmParser a b -> [(DurationT, a)] -> Either String b quantize' p = left show . runParser p mempty "" -- Matches a (duration, value) pair iff the predicate matches, returns beat-match :: (Duration -> a -> Bool) -> RhythmParser a (Rhythm a)+match :: Tiable a => (DurationT -> a -> Bool) -> RhythmParser a (Rhythm a) match p = tokenPrim show next test where show x = ""@@ -149,32 +155,32 @@ test (d,x) = if p d x then Just (Beat d x) else Nothing -- Matches any rhythm-rhythm :: RhythmParser a (Rhythm a)-rhythm = Rhythms <$> Text.Parsec.many1 (rhythm' <|> bound)+rhythm :: Tiable a => RhythmParser a (Rhythm a)+rhythm = Group <$> many1 (rhythm' <|> bound) -rhythmNoBound :: RhythmParser a (Rhythm a)-rhythmNoBound = Rhythms <$> Text.Parsec.many1 rhythm'+rhythmNoBound :: Tiable a => RhythmParser a (Rhythm a)+rhythmNoBound = Group <$> many1 rhythm' -rhythm' :: RhythmParser a (Rhythm a)+rhythm' :: Tiable a => RhythmParser a (Rhythm a) rhythm' = mzero <|> beat <|> dotted <|> tuplet -- Matches a beat divisible by 2 (notated)-beat :: RhythmParser a (Rhythm a)+beat :: Tiable a => RhythmParser a (Rhythm a) beat = do RState tm ts _ <- getState- (\d -> (d^/tm) `subDur` ts) <$> match (\d _ -> - d - ts > 0 + (\d -> (d^/tm) `subDur` ts) <$> match (\d _ ->+ d - ts > 0 &&- isDivisibleBy 2 (d / tm - ts)) -- TODO or is it (d - ts) / tm+ isDivisibleBy 2 (d / tm - ts)) -- Or is it ((d - ts) / tm)? -- | Matches a dotted rhythm-dotted :: RhythmParser a (Rhythm a)+dotted :: Tiable a => RhythmParser a (Rhythm a) dotted = msum . fmap dotted' $ [1..2] -- max 2 dots -dotted' :: Int -> RhythmParser a (Rhythm a)+dotted' :: Tiable a => Int -> RhythmParser a (Rhythm a) dotted' n = do modifyState $ modifyTimeMod (* dotMod n) a <- beat@@ -183,35 +189,46 @@ -- | Matches a bound rhythm-bound :: RhythmParser a (Rhythm a)+bound :: Tiable a => RhythmParser a (Rhythm a) bound = bound' (1/2) -bound' :: Duration -> RhythmParser a (Rhythm a)+bound' :: Tiable a => DurationT -> RhythmParser a (Rhythm a) bound' d = do modifyState $ modifyTimeSub (+ d)- a <- rhythm'+ a <- beat modifyState $ modifyTimeSub (subtract d)- return $ Bound d a+ let (b,c) = toTied $ getBeatValue a+ return $ Group [Beat (getBeatDuration a) $ b, Beat (1/2) $ c]+ -- FIXME doesn't know order -- | Matches a tuplet-tuplet :: RhythmParser a (Rhythm a)+tuplet :: Tiable a => RhythmParser a (Rhythm a) tuplet = msum . fmap tuplet' $ tupletMods -- tuplet' 2/3 for triplet, 4/5 for quintuplet etc-tuplet' :: Duration -> RhythmParser a (Rhythm a)+tuplet' :: Tiable a => DurationT -> RhythmParser a (Rhythm a) tuplet' d = do RState _ _ depth <- getState onlyIf (depth < 1) $ do -- max 1 nested tuplets- modifyState $ modifyTimeMod (* d) + modifyState $ modifyTimeMod (* d) . modifyTupleDepth succ- a <- rhythmNoBound - modifyState $ modifyTimeMod (/ d) + a <- rhythmNoBound+ modifyState $ modifyTimeMod (/ d) . modifyTupleDepth pred return (Tuplet d a) +------------------------------------------------------------------------------------- +-- | Similar to 'many1', but tries longer sequences before trying one.+many1long :: Stream s m t => ParsecT s u m a -> ParsecT s u m [a]+many1long p = try (many2 p) <|> fmap return p++-- | Similar to 'many1', but applies the parser 2 or more times.+many2 :: Stream s m t => ParsecT s u m a -> ParsecT s u m [a]+many2 p = do { x <- p; xs <- many1 p; return (x : xs) }+ -- | -- Succeed only if the entire input is consumed. --@@ -223,23 +240,21 @@ where notFollowedBy' p = try $ (try p >> unexpected "") <|> return () anyToken' = tokenPrim (const "") (\pos _ _ -> pos) Just- + onlyIf :: MonadPlus m => Bool -> m b -> m b onlyIf b p = if b then p else mzero logBaseR :: forall a . (RealFloat a, Floating a) => Rational -> Rational -> a-logBaseR k n +logBaseR k n | isInfinite (fromRational n :: a) = logBaseR k (n/k) + 1-logBaseR k n +logBaseR k n | isDenormalized (fromRational n :: a) = logBaseR k (n*k) - 1 logBaseR k n = logBase (fromRational k) (fromRational n) -- As it sounds-isDivisibleBy :: Duration -> Duration -> Bool+isDivisibleBy :: DurationT -> DurationT -> Bool isDivisibleBy n = (== 0.0) . snd . properFraction . logBaseR (toRational n) . toRational --single x = [x] left f (Left x) = Left (f x) left f (Right y) = Right y
src/Music/Score/Score.hs view
@@ -1,9 +1,11 @@- + {-# LANGUAGE TypeFamilies, DeriveFunctor, DeriveFoldable,- GeneralizedNewtypeDeriving #-} + DeriveDataTypeable,+ DeriveTraversable,+ GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------------- -- |@@ -15,87 +17,67 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) ----- Provides a musical score represenation.+-- Provides the 'Score' type. -- ------------------------------------------------------------------------------------- module Music.Score.Score (- Score(..),- rest,- note, - -- filterS,- perform,- performRelative+ Score,+ -- mapTime, ) where -import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)+import Prelude hiding (null, length, repeat, foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum) import Data.Semigroup import Control.Applicative import Control.Monad (ap, join, MonadPlus(..)) import Data.Foldable import Data.Traversable+import Data.Typeable import Data.Maybe import Data.Either+import Data.Pointed import Data.Function (on) import Data.Ord (comparing) import Data.Ratio import Data.VectorSpace import Data.AffineSpace+import Test.QuickCheck (Arbitrary(..),Gen(..)) import qualified Data.Map as Map import qualified Data.List as List import Music.Pitch.Literal import Music.Dynamics.Literal -import Music.Score.Time-import Music.Score.Duration+import Music.Time+import Music.Score.Voice+import Music.Score.Track ------------------------------------------------------------------------------------- -- Score type ------------------------------------------------------------------------------------- -- |--- A score is a sorted list of absolute time notes and rests. A rest is a duration and --- a note is a value and a duration.+-- A score is a list of events, i.e. time-duration-value triplets. Semantically --+-- > type Score a = [(Time, Duration, a)]+--+-- There is no explicit representation for rests. However you can use `Score (Maybe a)` to+-- represent a score with rests. Such rests are only useful when composing scores. They+-- may be removed with 'removeRests'.+-- -- Score is a 'Monoid' under parallel composition. 'mempty' is a score of no parts. -- For sequential composition of scores, use '|>'. -- -- Score has an 'Applicative' instance derived from the 'Monad' instance. Not sure it is useful. ----- Score is a 'Monad'. 'return' creates a score containing a single note of--- duration one, and '>>=' transforms the values of a score, while allowing--- transformations of time and duration. More intuitively, 'join' scales and--- offsets each inner score to fit into an outer score, then removes the intermediate--- structure. ------ > let s = Score [(0, 1, Just 0), (1, 2, Just 1)] :: Score Int--- >--- > s >>= \x -> Score [ (0, 1, Just $ toEnum $ x+65), --- > (1, 3, Just $ toEnum $ x+97) ] :: Score Char--- >--- > ===> Score {getScore = [ (0 % 1, 1 % 1, Just 'A'),--- > (1 % 1, 3 % 1, Just 'a'),--- > (1 % 1, 2 % 1, Just 'B'),--- > (3 % 1, 6 % 1, Just 'b') ]}------ Score is an instance of 'VectorSpace' using sequential composition as addition, --- and time scaling as scalar multiplication. +-- Score is an instance of 'VectorSpace' using sequential composition as addition,+-- and time scaling as scalar multiplication. ---newtype Score a = Score { getScore :: [(Time, Duration, Maybe a)] }- deriving ({-Eq, Ord, -}Show, Functor, Foldable)---- TODO invariant that the list is sorted----- Performance equality needeed because of rests...--instance Eq a => Eq (Score a) where- a == b = perform a == perform b+newtype Score a = Score { getScore :: [(TimeT, DurationT, a)] }+ deriving (Eq, Ord, Show, Functor, Foldable, Typeable, Traversable) -instance Ord a => Ord (Score a) where- a `compare` b = perform a `compare` perform b+type instance Time Score = TimeT instance Semigroup (Score a) where (<>) = mappend@@ -106,8 +88,38 @@ Score as `mappend` Score bs = Score (as `m` bs) where m = mergeBy (comparing fst3)- fst3 (a,b,c) = a +-- |+-- This instance is somewhat similar to the list instance.+--+-- * 'return' creates a score containing a single note at /(0, 1)/.+-- +-- * @s@ '>>=' @k@ maps each note to a new score, which is then scaled and delayed by the onset and+-- duration of the original note. That is, @k@ returns a score @t@ such that /0 < onset t < offset t < 1/, +-- the resulting events will not cross the boundaries of the original note.+-- +-- * 'join' scales and offsets each inner score to fit into the note containing it, then+-- removes the intermediate structure.+--+-- > let s = compose [(0,1,0), (1,2,1)]+-- >+-- > s >>= \x -> compose [ (0,1,toEnum $ x+65),+-- > (1,3,toEnum $ x+97) ] :: Score Char+-- >+-- > ===> compose [ (1, 1, 'A'),+-- > (1, 3, 'a'),+-- > (1, 2, 'B'),+-- > (3, 6, 'b') ]}+-- +instance Monad Score where+ return x = Score [(0, 1, x)]+ a >>= k = join' $ fmap k a+ where+ join' sc = {-mconcat $ toList-}fold $ mapTime (\t d -> delay' t . stretch d) sc++instance Pointed Score where+ point = return+ instance Applicative Score where pure = return (<*>) = ap@@ -121,100 +133,88 @@ mzero = mempty mplus = mappend -instance Monad Score where- return = note- a >>= k = join' $ fmap k a- where - join' sc = mconcat $ toList $ mapWithTimeDur (\t d -> fmap (delay t . (d*^) )) $ sc--mapWithTimeDur :: (Duration -> Duration -> Maybe a -> Maybe b) -> Score a -> Score b-mapWithTimeDur f = Score . fmap (liftTimeDur f) . getScore--liftTimeDur :: (Duration -> Duration -> Maybe a -> Maybe b) -> (Time, Duration, Maybe a) -> (Time, Duration, Maybe b)-liftTimeDur f (t,d,x) = case f (t2d t) d x of- Nothing -> (t,d,Nothing)- Just y -> (t,d,Just y)- where- t2d = Duration . getTime+instance Performable Score where+ perform = getScore -instance AdditiveGroup (Score a) where- zeroV = mempty- (^+^) = mappend- negateV = id+instance Stretchable (Score) where+ d `stretch` Score sc = Score $ fmap (first3 (^* fromDurationT d) . second3 (^* d)) $ sc -instance VectorSpace (Score a) where- type Scalar (Score a) = Duration- d *^ Score sc = Score . fmap (first3 (^* d2t d) . second3 (^* d)) $ sc- where- first3 f (a,b,c) = (f a,b,c)- second3 f (a,b,c) = (a,f b,c) - d2t = Time . getDuration- -instance Delayable (Score a) where+instance Delayable (Score) where d `delay` Score sc = Score . fmap (first3 (.+^ d)) $ sc- where- first3 f (a,b,c) = (f a,b,c) -instance HasOnset (Score a) where- onset (Score []) = 0+instance HasOnset (Score) where+ -- onset (Score []) = 0 -- onset (Score xs) = minimum (fmap on xs) where on (t,d,x) = t- onset (Score xs) = on (head xs) where on (t,d,x) = t++ -- Note: this version of onset is lazier, but depends on the invariant that the list is sorted+ onset (Score []) = 0+ onset (Score xs) = on (head xs) where on (t,d,x) = t++instance HasOffset (Score) where offset (Score []) = 0- offset (Score xs) = maximum (fmap off xs) where off (t,d,x) = t + (Time . getDuration $ d)- -- Note: this version of onset is lazier, but depends on the invariant above- -instance HasDuration (Score a) where- duration x = offset x .-. onset x + offset (Score xs) = maximum (fmap off xs) where off (t,d,x) = t + (fromDurationT $ d) +instance HasDuration (Score) where+ duration x = offset x .-. onset x+ instance IsPitch a => IsPitch (Score a) where fromPitch = pure . fromPitch instance IsDynamics a => IsDynamics (Score a) where fromDynamics = pure . fromDynamics +-- Utility+instance AdditiveGroup (Score a) where+ zeroV = error "Not impl"+ (^+^) = error "Not impl"+ negateV = error "Not impl" --- |--- Create a score of duration one with no values.----rest :: Score a-rest = Score [(0,1,Nothing)]+instance VectorSpace (Score a) where+ type Scalar (Score a) = DurationT+ d *^ s = d `stretch` s +instance Arbitrary a => Arbitrary (Score a) where+ arbitrary = do+ x <- arbitrary+ t <- fmap toDurationT $ (arbitrary::Gen Double)+ d <- fmap toDurationT $ (arbitrary::Gen Double)+ return $ delay t $ stretch d $ (note x)+ -- |--- Create a score of duration one with the given value. Equivalent to 'pure' and 'return'.+-- Create a score of duration one with the given value (same as 'return'). -- note :: a -> Score a-note x = Score [(0,1,Just x)]--{---- Use mfilter instead of this--filterS :: (a -> Bool) -> Score a -> Score a-filterS f = Score . filter g . getScore- where- g (t,d,Nothing) = True- g (t,d,(Just x)) = f x--}+note = return -perform :: Score a -> [(Time, Duration, a)]-perform = removeRests . getScore- where- removeRests = catMaybes . fmap propagateRest- propagateRest (t, d, Just x) = Just (t, d, x)- propagateRest (t, d, Nothing) = Nothing+-- |+-- Create a score of duration one with no values.+--+rest :: Score (Maybe a)+rest = return Nothing -performRelative :: Score a -> [(Time, Duration, a)]-performRelative = toRel . perform+-- |+-- Repeat a score indefinately.+--+repeat :: Score a -> Score a+repeat a = a `plus` delay (duration a) (repeat a) where- toRel = snd . mapAccumL g 0- g now (t,d,x) = (t, (t-now,d,x))-+ Score as `plus` Score bs = Score (as <> bs) +-- |+-- Map over all events in a score.+--+mapTime :: (TimeT -> DurationT -> a -> b) -> Score a -> Score b+mapTime f = Score . fmap (mapEvent f) . getScore +mapEvent :: (TimeT -> DurationT -> a -> b) -> (TimeT, DurationT, a) -> (TimeT, DurationT, b)+mapEvent f (t, d, x) = (t, d, f t d x) +------------------------------------------------------------------------------------- +delay' t = delay (fromTimeT t) - +fst3 (a,b,c) = a list z f [] = z list z f xs = f xs@@ -222,7 +222,13 @@ first f (x,y) = (f x, y) second f (x,y) = (x, f y) +first3 f (a,b,c) = (f a,b,c)+second3 f (a,b,c) = (a,f b,c) mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]-mergeBy f as bs = List.sortBy f $ as <> bs+mergeBy f [] ys = ys+mergeBy f xs [] = xs+mergeBy f xs'@(x:xs) ys'@(y:ys)+ | x `f` y == LT = x : mergeBy f xs ys'+ | x `f` y /= LT = y : mergeBy f xs' ys
src/Music/Score/Ties.hs view
@@ -1,10 +1,13 @@- + {-# LANGUAGE TypeFamilies, DeriveFunctor, DeriveFoldable,+ DeriveDataTypeable, FlexibleInstances,- GeneralizedNewtypeDeriving #-} + FlexibleContexts,+ ConstraintKinds,+ GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------------- -- |@@ -16,7 +19,7 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) ----- Provides a musical score represenation.+-- Provides tie representation and splitting. -- ------------------------------------------------------------------------------------- @@ -26,114 +29,111 @@ TieT(..), splitTies, splitTiesSingle,- splitTiesPart,+ splitTiesVoice, ) where +import Control.Monad+import Control.Monad.Plus+import Data.Default+import Data.Maybe import Data.Ratio+import Data.Foldable hiding (concat)+import Data.Typeable import qualified Data.List as List import Data.VectorSpace import Data.AffineSpace --import Music.Score.Part+import Music.Score.Voice import Music.Score.Score-import Music.Score.Duration-import Music.Score.Time--+import Music.Score.Combinators+import Music.Score.Part+import Music.Time -- | -- Class of types that can be tied. -- class Tiable a where+ beginTie :: a -> a+ endTie :: a -> a+ -- | Split elements into beginning and end and add tie. -- Begin properties goes to the first tied note, and end properties to the latter. -- The first returned element will have the original onset.- -- + -- toTied :: a -> (a, a)+ toTied a = (beginTie a, endTie a) -newtype TieT a = TieT { getTieT :: (Bool, a, Bool) } - deriving (Eq, Ord, Show, Functor)+newtype TieT a = TieT { getTieT :: (Bool, a, Bool) }+ deriving (Eq, Ord, Show, Functor, Foldable, Typeable) -- These are note really tiable..., but Tiable a => (Bool,a,Bool) would be-instance Tiable Double where toTied x = (x,x)-instance Tiable Float where toTied x = (x,x)-instance Tiable Int where toTied x = (x,x)-instance Tiable Integer where toTied x = (x,x)-instance Tiable () where toTied x = (x,x)-instance Tiable (Ratio a) where toTied x = (x,x)+instance Tiable Double where { beginTie = id ; endTie = id }+instance Tiable Float where { beginTie = id ; endTie = id }+instance Tiable Int where { beginTie = id ; endTie = id }+instance Tiable Integer where { beginTie = id ; endTie = id }+instance Tiable () where { beginTie = id ; endTie = id }+instance Tiable (Ratio a) where { beginTie = id ; endTie = id } instance Tiable a => Tiable (Maybe a) where+ beginTie = fmap beginTie+ endTie = fmap endTie toTied Nothing = (Nothing, Nothing) toTied (Just a) = (Just b, Just c) where (b,c) = toTied a- + instance Tiable a => Tiable (TieT a) where- toTied (TieT (prevTie, a, _)) = (TieT (prevTie, b, True), TieT (True, c, False))+ beginTie (TieT (prevTie, a, nextTie)) = TieT (prevTie, a, True)+ endTie (TieT (prevTie, a, nextTie)) = TieT (True, a, nextTie)+ toTied (TieT (prevTie, a, nextTie)) = (TieT (prevTie, b, True), TieT (True, c, nextTie)) where (b,c) = toTied a --- | --- /Not implemented/+-- | -- Split all notes that cross a barlines into a pair of tied notes.--- -splitTies :: Tiable a => Score a -> Score a-splitTies = error "splitTies: Not implemented"+--+splitTies :: (HasPart' a, Tiable a) => Score a -> Score a+splitTies = mapParts splitTiesSingle --- | --- Split all notes that cross a barlines into a pair of tied notes.--- Note: only works for single-part scores (with no overlapping events).--- +-- |+-- Equivalent to `splitTies` for single-voice scores.+-- Fails if the score contains overlapping events.+-- splitTiesSingle :: Tiable a => Score a -> Score a-splitTiesSingle = partToSingleScore . splitTiesPart . singleScoreToPart--partToSingleScore :: Part (Maybe a) -> Score a-partToSingleScore = Score . accumTime . getPart- where- accumTime = snd . List.mapAccumL g 0- where- g t (d, x) = (t .+^ d, (t, d, x))--singleScoreToPart :: Score a -> Part (Maybe a)-singleScoreToPart sc = Part . movePart . throwTime . getScore $ sc- where- throwTime = fmap g where g (t,d,x) = (d,x)- d = onset sc .-. 0- movePart = if (d == 0) then id else ([(d, Nothing)] ++)+splitTiesSingle = voiceToScore' . splitTiesVoice . scoreToVoice --- | +-- | -- Split all notes that cross a barlines into a pair of tied notes.--- -splitTiesPart :: Tiable a => Part a -> Part a-splitTiesPart = Part . concat . snd . List.mapAccumL g 0 . getPart+--+splitTiesVoice :: Tiable a => Voice a -> Voice a+splitTiesVoice = Voice . concat . snd . List.mapAccumL g 0 . getVoice where- g t (d, x) = (t + d, occs) + g t (d, x) = (t + d, occs) where (_, barTime) = properFraction t remBarTime = 1 - barTime- occs = splitDur remBarTime (d,x)+ occs = splitDur remBarTime 1 (d,x) -- |--- Split an event into a part the given duration, and parts shorter than or equal to one.--- The returned list is always non-empty.+-- Split an event into one chunk of the duration @s@, followed parts shorter than duration @t@. --+-- The returned list is always non-empty. All elements but the first and the last must have duration @t@.+-- -- > sum $ fmap fst $ splitDur s (x,a) = x--- -splitDur :: Tiable a => Duration -> (Duration, a) -> [(Duration, a)]-splitDur s x = case splitDur' s x of- (a, Nothing) -> a : []- (a, Just b) -> a : splitDur 1 b---- FIXME completely assumes bar dur 1, see #36+--+splitDur :: Tiable a => DurationT -> DurationT -> (DurationT, a) -> [(DurationT, a)]+splitDur s t x = case splitDur' s x of+ (a, Nothing) -> [a]+ (a, Just b) -> a : splitDur t t b -- | -- Extract the the first part of a given duration. If the note is shorter than the given duration, -- return it and @Nothing@. Otherwise return the extracted part, and the rest. -- -- > splitDur s (d,a)--- -splitDur' :: Tiable a => Duration -> (Duration, a) -> ((Duration, a), Maybe (Duration, a))+--+splitDur' :: Tiable a => DurationT -> (DurationT, a) -> ((DurationT, a), Maybe (DurationT, a)) splitDur' s (d,a) | d <= s = ((d,a), Nothing) | otherwise = ((s,b), Just (d-s, c)) where (b,c) = toTied a- ++
− src/Music/Score/Time.hs
@@ -1,120 +0,0 @@--{-# LANGUAGE- TypeFamilies,- DeriveFunctor,- DeriveFoldable,- GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------------------ |--- Copyright : (c) Hans Hoglund 2012------ License : BSD-style------ Maintainer : hans@hanshoglund.se--- Stability : experimental--- Portability : non-portable (TF,GNTD)------ Provides a musical score represenation.-------------------------------------------------------------------------------------------module Music.Score.Time where--import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)--import Data.Semigroup-import Control.Applicative-import Data.Traversable-import Data.Maybe-import Data.Either-import Data.Function (on)-import Data.Ord (comparing)-import Data.Ratio-import Data.VectorSpace-import Data.AffineSpace--import Music.Score.Duration------------------------------------------------------------------------------------------ Time type------------------------------------------------------------------------------------------ |--- This type represents absolute time in seconds a known reference time.--- The reference time can be any time, but is usually the the beginning of the --- musical performance.------ Times forms an affine space with durations as the underlying vector space,--- that is, we can add a time to a duration to get a new time using '.+^', --- take the difference of two times to get a duration using '.-.'.----newtype Time = Time { getTime::Rational }- deriving (Eq, Ord, Num, Enum, Real, Fractional, RealFrac)- -- Note: no Floating as we want to be able to switch to rational--instance Show Time where - show = show . getTime--instance AdditiveGroup Time where- zeroV = 0- (^+^) = (+)- negateV = negate--instance VectorSpace Time where- type Scalar Time = Time- (*^) = (*)--instance InnerSpace Time where (<.>) = (*)--instance AffineSpace Time where- type Diff Time = Duration- a .-. b = t2d $ a - b where t2d = Duration . getTime- a .+^ b = a + d2t b where d2t = Time . getDuration---- |--- Class of types with a position in time.------ Onset and offset are logical start and stop time, rather than actual sounding time,--- or to put it differently, the time of the attack and damp actions on an instrument,--- rather than the actual beginning or end of the sound. ------ If a type has an instance for both 'HasOnset' and 'HasDuration', the following laws--- should hold:--- --- > duration a = offset a - onset a--- > offset a >= onset a------ implying------ > duration a >= 0-------class HasOnset a where- -- | - -- Get the onset of the given value.- --- onset :: a -> Time-- -- | - -- Get the offset of the given value.- --- offset :: a -> Time- -instance HasOnset a => HasOnset (WrappedMonoid a) where - onset = onset . unwrapMonoid- offset = offset . unwrapMonoid---class HasPreOnset a where- preOnset :: a -> Time--class HasPostOnset a where- postOnset :: a -> Time--class HasPostOffset a where- postOffset :: a -> Time-- --
src/Music/Score/Track.hs view
@@ -1,9 +1,10 @@- + {-# LANGUAGE TypeFamilies, DeriveFunctor, DeriveFoldable,- GeneralizedNewtypeDeriving #-} + FlexibleInstances,+ GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------------- -- |@@ -15,12 +16,12 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) ----- Provides a musical score represenation.+-- Provides the 'Track' type. -- ------------------------------------------------------------------------------------- module Music.Score.Track (- Track(..)+ Track(..), ) where import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)@@ -37,18 +38,18 @@ import Data.Ratio import Data.VectorSpace import Data.AffineSpace+import Test.QuickCheck (Arbitrary(..),Gen(..)) import qualified Data.Map as Map import qualified Data.List as List -import Music.Score.Time-import Music.Score.Duration+import Music.Time ------------------------------------------------------------------------------------- -- Track type ------------------------------------------------------------------------------------- -- |--- A track is a sorted list of absolute-time occurences.+-- A track is a list of events with explicit onset. Events can not overlap. -- -- Track is a 'Monoid' under parallel composition. 'mempty' is the empty track and 'mappend' -- interleaves values.@@ -59,9 +60,9 @@ -- zero, and '>>=' transforms the values of a track, allowing the addition and -- removal of values relative to the time of the value. Perhaps more intuitively, -- 'join' delays each inner track to start at the offset of an outer track, then--- removes the intermediate structure. +-- removes the intermediate structure. ----- > let t = Track [(0, 65),(1, 66)] +-- > let t = Track [(0, 65),(1, 66)] -- > -- > t >>= \x -> Track [(0, 'a'), (10, toEnum x)] -- >@@ -70,12 +71,14 @@ -- > (10.0, 'A'), -- > (11.0, 'B') ]} ----- Track is an instance of 'VectorSpace' using parallel composition as addition, --- and time scaling as scalar multiplication. +-- Track is an instance of 'VectorSpace' using parallel composition as addition,+-- and time scaling as scalar multiplication. ---newtype Track a = Track { getTrack :: [(Time, a)] }+newtype Track a = Track { getTrack :: [(TimeT, a)] } deriving (Eq, Ord, Show, Functor, Foldable) +type instance Time Track = TimeT+ instance Semigroup (Track a) where (<>) = mappend @@ -86,17 +89,16 @@ where m = mergeBy (comparing fst) -instance Applicative Track where- pure = return- (<*>) = ap- instance Monad Track where return a = Track [(0, a)] a >>= k = join' . fmap k $ a where- join' (Track ts) = foldMap (uncurry delay') $ ts- delay' t = delay (Duration . getTime $ t)+ join' (Track ts) = foldMap (uncurry delay') ts +instance Applicative Track where+ pure = return+ (<*>) = ap+ instance Alternative Track where empty = mempty (<|>) = mappend@@ -106,30 +108,41 @@ mzero = mempty mplus = mappend -instance AdditiveGroup (Track a) where- zeroV = mempty- (^+^) = mappend- negateV = id--instance VectorSpace (Track a) where- type Scalar (Track a) = Time- n *^ Track tr = Track . (fmap (first (n*^))) $ tr+instance Stretchable (Track) where+ n `stretch` Track tr = Track $ fmap (first (^* fromDurationT n)) tr -instance Delayable (Track a) where- d `delay` Track tr = Track . fmap (first (.+^ d)) $ tr+instance Delayable (Track) where+ d `delay` Track tr = Track $ fmap (first (.+^ d)) tr -instance HasOnset (Track a) where+instance HasOnset (Track) where onset (Track []) = 0 onset (Track xs) = minimum (fmap on xs) where on (t,x) = t++{-+instance HasOffset (Track) where offset (Track []) = 0 offset (Track xs) = maximum (fmap off xs) where off (t,x) = t+-} -instance HasDuration (Track a) where+-- offset x = maximum (fmap off x) where off (t,x) = t++{-+instance HasDuration (Track) where duration x = offset x .-. onset x+-} --- offset x = maximum (fmap off x) where off (t,x) = t- +instance Arbitrary a => Arbitrary (Track a) where+ arbitrary = do+ x <- arbitrary+ t <- fmap toDurationT $ (arbitrary::Gen Double)+ d <- fmap toDurationT $ (arbitrary::Gen Double)+ return $ delay t $ stretch d $ (return x) +++-------------------------------------------------------------------------------------++delay' t = delay (fromTimeT t) list z f [] = z list z f xs = f xs
src/Music/Score/Voice.hs view
@@ -1,11 +1,9 @@- + {-# LANGUAGE TypeFamilies, DeriveFunctor, DeriveFoldable,- FlexibleInstances,- OverloadedStrings,- GeneralizedNewtypeDeriving #-} + GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------------- -- |@@ -17,183 +15,105 @@ -- Stability : experimental -- Portability : non-portable (TF,GNTD) ----- Provides a musical score represenation.+-- Provides the 'Voice' type. -- ------------------------------------------------------------------------------------- - module Music.Score.Voice (- HasVoice(..),- -- VoiceName(..),- VoiceT(..),- voices,- mapVoice,- mapVoices,- getVoices,- setVoices,- modifyVoices,- - -- ** Voice composition- (</>),- moveParts,- moveToPart,+ Voice(..), ) where -import Control.Monad (ap, mfilter, join, liftM, MonadPlus(..))+import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)+ import Data.Semigroup-import Data.String+import Control.Applicative+import Control.Monad (ap, join, MonadPlus(..)) import Data.Foldable-import Data.Ord (comparing) import Data.Traversable-import qualified Data.List as List+import Data.Maybe+import Data.Pointed+import Data.Either+import Data.Function (on)+import Data.Ord (comparing)+import Data.Ratio import Data.VectorSpace import Data.AffineSpace-import Data.Ratio -import Music.Score.Part-import Music.Score.Score-import Music.Score.Duration-import Music.Score.Time-import Music.Score.Ties---class HasVoice a where- -- | - -- Associated voice type. Should implement 'Ord' and 'Show' to be usable.- -- - type Voice a :: *-- -- |- -- Get the voice of the given note.- -- - getVoice :: a -> Voice a-- -- |- -- Set the voice of the given note.- -- - setVoice :: Voice a -> a -> a-- -- |- -- Modify the voice of the given note.- -- - modifyVoice :: (Voice a -> Voice a) -> a -> a- - setVoice n = modifyVoice (const n)- modifyVoice f x = x---- newtype VoiceName = VoiceName { getVoiceName :: String }- -- deriving (Eq, Ord, IsString)--- instance Show VoiceName where show = getVoiceName--newtype VoiceT n a = VoiceT { getVoiceT :: (n, a) }- deriving (Eq, Ord, Show, Functor)--instance HasVoice () where { type Voice () = Integer ; getVoice _ = 0 }-instance HasVoice Double where { type Voice Double = Integer ; getVoice _ = 0 }-instance HasVoice Float where { type Voice Float = Integer ; getVoice _ = 0 }-instance HasVoice Int where { type Voice Int = Integer ; getVoice _ = 0 }-instance HasVoice Integer where { type Voice Integer = Integer ; getVoice _ = 0 }-instance Integral a => HasVoice (Ratio a) where { type Voice (Ratio a) = Integer ; getVoice _ = 0 }------ | --- Extract parts from the given score. Returns a list of single-part score. A dual of @pcat@.------ > Score a -> [Score a]----voices :: (HasVoice a, Ord v, v ~ Voice a, MonadPlus s, Foldable s) => s a -> [s a]-voices sc = fmap (flip extract $ sc) (getVoices sc) - where - extract v = mfilter ((== v) . getVoice)+import Music.Time --- |--- Map over a single voice in the given score.------ > Voice -> (Score a -> Score a) -> Score a -> Score a----mapVoice :: (Ord v, v ~ Voice a, HasVoice a, MonadPlus s, Foldable s, Enum b) => b -> (s a -> s a) -> s a -> s a-mapVoice n f = mapVoices (zipWith ($) (replicate (fromEnum n) id ++ [f] ++ repeat id))+import Music.Pitch.Literal+import Music.Dynamics.Literal --- |--- Map over all voices in the given score.------ > ([Score a] -> [Score a]) -> Score a -> Score a----mapVoices :: (HasVoice a, Ord v, v ~ Voice a, MonadPlus s, Foldable s) => ([s a] -> [s b]) -> s a -> s b-mapVoices f = msum . f . voices+-------------------------------------------------------------------------------------+-- Voice type+------------------------------------------------------------------------------------- -- |--- Get all voices in the given score. Returns a list of voices.------ > Score a -> [Voice]+-- A voice is a list of events with explicit duration. Events can not overlap. ---getVoices :: (HasVoice a, Ord v, v ~ Voice a, Foldable s) => s a -> [Voice a]-getVoices = List.sort . List.nub . fmap getVoice . toList---- |--- Set all voices in the given score.+-- Voice is a 'Monoid' under sequential composition. 'mempty' is the empty part and 'mappend'+-- appends parts. ----- > Voice -> Score a -> Score a+-- Voice has an 'Applicative' instance derived from the 'Monad' instance. ---setVoices :: (HasVoice a, Functor s) => Voice a -> s a -> s a-setVoices n = fmap (setVoice n)---- |--- Modify all voices in the given score.+-- Voice is a 'Monad'. 'return' creates a part containing a single value of duration+-- one, and '>>=' transforms the values of a part, allowing the addition and+-- removal of values under relative duration. Perhaps more intuitively, 'join' scales+-- each inner part to the duration of the outer part, then removes the+-- intermediate structure. ----- > (Voice -> Voice) -> Score a -> Score a+-- > let p = Voice [(1, Just 0), (2, Just 1)] :: Voice Int+-- >+-- > p >>= \x -> Voice [ (1, Just $ toEnum $ x+65),+-- > (3, Just $ toEnum $ x+97) ] :: Voice Char+-- >+-- > ===> Voice {getVoice = [ (1 % 1,Just 'A'),+-- > (3 % 1,Just 'a'),+-- > (2 % 1,Just 'B'),+-- > (6 % 1,Just 'b') ]} ---modifyVoices :: (HasVoice a, Functor s) => (Voice a -> Voice a) -> s a -> s a-modifyVoices n = fmap (modifyVoice n)--------------------------------------------------------------------------------------- Voice composition-----------------------------------------------------------------------------------infixr 6 </>---- TODO use Alternative instead of (Functor + MonadPlus) ?---- |--- Similar to '<>', but increases voices in the second part to prevent voice collision.+-- Voice is a 'VectorSpace' using sequential composition as addition, and time scaling+-- as scalar multiplication. ---(</>) :: (Enum v, Ord v, v ~ Voice a, Functor s, MonadPlus s, Foldable s, HasVoice a) => s a -> s a -> s a-a </> b = a `mplus` moveParts offset b- where - -- max voice in a + 1- offset = succ $ maximum' 0 $ fmap fromEnum $ getVoices a-+newtype Voice a = Voice { getVoice :: [(DurationT, a)] }+ deriving (Eq, Ord, Show, Functor, Foldable, Monoid) --- |--- Move down one voice (all parts).----moveParts :: (Enum v, v ~ Voice a, Integral b, Functor s, HasVoice a) => b -> s a -> s a-moveParts x = modifyVoices (successor x)+type instance Time Voice = TimeT --- |--- Move top-part to the specific voice (other parts follow).----moveToPart :: (Enum v, v ~ Voice a, Functor s, HasVoice a) => v -> s a -> s a-moveToPart v = moveParts (fromEnum v)+instance Semigroup (Voice a) where+ (<>) = mappend +instance Monad Voice where+ return a = Voice [(1, a)]+ a >>= k = join' $ fmap k a+ where+ join' (Voice ps) = foldMap (uncurry stretch) ps +instance Pointed Voice where+ point = return +instance Applicative Voice where+ pure = return+ (<*>) = ap +instance Stretchable (Voice) where+ n `stretch` Voice as = Voice (fmap (first (n*^)) as) +instance HasDuration (Voice) where+ duration (Voice as) = sum (fmap fst as) +instance IsPitch a => IsPitch (Voice a) where+ fromPitch = pure . fromPitch +instance IsDynamics a => IsDynamics (Voice a) where+ fromDynamics = pure . fromDynamics -successor :: (Integral b, Enum a) => b -> a -> a-successor n | n < 0 = (!! fromIntegral (abs n)) . iterate pred- | n >= 0 = (!! fromIntegral n) . iterate succ+------------------------------------------------------------------------------------- +list z f [] = z+list z f xs = f xs -maximum' :: (Ord a, Foldable t) => a -> t a -> a-maximum' z = option z getMax . foldMap (Option . Just . Max)+first f (x,y) = (f x, y)+second f (x,y) = (x, f y) -minimum' :: (Ord a, Foldable t) => a -> t a -> a-minimum' z = option z getMin . foldMap (Option . Just . Min)
+ src/Music/Score/Zip.hs view
@@ -0,0 +1,119 @@++{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ FlexibleInstances,+ FlexibleContexts,+ ConstraintKinds,+ OverloadedStrings,+ GeneralizedNewtypeDeriving #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Provides zippers over scores.+--+-------------------------------------------------------------------------------------+++module Music.Score.Zip (+ -- ** Zipper+ apply,+ snapshot,+ -- trig,+ applySingle,+ snapshotSingle,+ -- before,+ -- first,+ ) where++import Control.Monad (ap, mfilter, join, liftM, MonadPlus(..))+import Data.Semigroup+import Data.String+import Data.Foldable+import Data.Traversable+import qualified Data.List as List+import Data.VectorSpace+import Data.AffineSpace+import Data.Ratio+import Data.Ord++import Music.Score.Track+import Music.Score.Voice+import Music.Score.Score+import Music.Time+import Music.Score.Part+import Music.Score.Combinators++-------------------------------------------------------------------------------------+-- Analysis++-- |+-- Apply a time-varying function to all events in score.+--+apply :: HasPart' a => Voice (Score a -> Score b) -> Score a -> Score b+apply x = mapAllParts (fmap $ applySingle x)++-- |+-- Get all notes that start during a given note.+--+snapshot :: HasPart' a => Score b -> Score a -> Score (b, Score a)+snapshot x = mapAllParts (fmap $ snapshotSingle x)++trig :: Score a -> Score b -> Score b+trig p as = mconcat $ toList $ fmap snd $ snapshotSingle p as++-- |+-- Apply a time-varying function to all events in score.+--+applySingle :: Voice (Score a -> Score b) -> Score a -> Score b+applySingle fs as = notJoin $ fmap (\(f,s) -> f s) sampled+ where+ -- This is not join; we simply concatenate all inner scores in parallel+ notJoin = mconcat . toList+ sampled = snapshotSingle (voiceToScore fs) as++-- |+-- Get all notes that start during a given note.+--+snapshotSingle :: Score a -> Score b -> Score (a, Score b)+snapshotSingle as bs = mapEventsSingle ( \t d a -> g a (onsetIn t d bs) ) as+ where+ -- g Nothing z = Nothing+ g = (,)+++-- |+-- Filter out events that has its onset in the given time interval (inclusive start).+-- For example, onset in 1 2 filters events such that (1 <= onset x < 3)+onsetIn :: TimeT -> DurationT -> Score a -> Score a+onsetIn a b = compose . filter' (\(t,d,x) -> a <= t && t < a .+^ b) . perform+ where+ filter' = filterOnce+ -- more lazy than mfilter++-- |+-- Extract the first consecutive sublist for which the predicate returns true, or+-- the empty list if no such sublist exists.+filterOnce :: (a -> Bool) -> [a] -> [a]+filterOnce p = List.takeWhile p . List.dropWhile (not . p)+++before :: DurationT -> Score a -> Score a+before d = trig (return () `stretchedBy` d)++first :: Score a -> a+first = value . head . perform+ where + value (a,b,c) = c+++stretchedBy = flip stretch
+ src/Music/Time.hs view
@@ -0,0 +1,47 @@++{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable, + DeriveDataTypeable,+ GeneralizedNewtypeDeriving,+ FlexibleInstances,+ FlexibleContexts,+ ConstraintKinds,+ TypeOperators, + OverloadedStrings,+ NoMonomorphismRestriction #-}++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : non-portable (TF,GNTD)+--+-- Provides time representations for use with scores, events etc.+--+-------------------------------------------------------------------------------------++module Music.Time (+ module Music.Time.Pos,+ module Music.Time.Time,+ module Music.Time.Duration,+ -- module Music.Time.Era,+ module Music.Time.Delayable,+ module Music.Time.Stretchable,+ module Music.Time.Performable,+ module Music.Time.Onset,+ ) where++import Music.Time.Time+import Music.Time.Duration+import Music.Time.Delayable+import Music.Time.Stretchable+-- import Music.Time.Era+import Music.Time.Performable+import Music.Time.Pos+import Music.Time.Onset
+ src/Music/Time/Delayable.hs view
@@ -0,0 +1,44 @@++{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ FlexibleContexts,+ ConstraintKinds,+ GeneralizedNewtypeDeriving #-} ++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Delayable (+ Delayable(..),+ ) where++import Data.Semigroup+import Data.VectorSpace+import Data.AffineSpace++import Music.Time.Time+import Music.Time.Duration+import Music.Time.Pos+++-- |+-- Delayable values. +-- +class Delayable s where++ -- |+ -- Delay a value.+ -- > Duration -> Score a -> Score a+ -- + delay :: Duration s -> s a -> s a
+ src/Music/Time/Duration.hs view
@@ -0,0 +1,62 @@+ +{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ FlexibleContexts,+ ConstraintKinds,+ GeneralizedNewtypeDeriving #-} ++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Duration (+ DurationT,+ fromDurationT,+ toDurationT,+ ) where++import Data.Semigroup+import Data.VectorSpace+import Data.AffineSpace+++-------------------------------------------------------------------------------------+-- Duration type+-------------------------------------------------------------------------------------++-- |+-- This type represents relative time in seconds.+--+newtype DurationT = DurationT { getDurationT::Rational } + deriving (Eq, Ord, Num, Enum, Real, Fractional, RealFrac)++instance Show DurationT where + show = show . getDurationT++instance AdditiveGroup DurationT where+ zeroV = 0+ (^+^) = (+)+ negateV = negate++instance VectorSpace DurationT where+ type Scalar DurationT = DurationT+ (*^) = (*)++instance InnerSpace DurationT where (<.>) = (*)++fromDurationT :: Fractional a => DurationT -> a+fromDurationT = fromRational . getDurationT++toDurationT :: Real a => a -> DurationT+toDurationT = DurationT . toRational+
+ src/Music/Time/Onset.hs view
@@ -0,0 +1,113 @@++{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ FlexibleContexts,+ GeneralizedNewtypeDeriving #-} ++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Onset (+ HasDuration(..),+ HasOnset(..),+ HasOffset(..),+ HasPreOnset(..),+ HasPostOnset(..),+ HasPostOffset(..),+ -- ** Defaults+ durationDefault,+ onsetDefault,+ offsetDefault,+ -- ** Wrappers+ AddOffset(..),+ ) where++import Data.Semigroup+import Data.VectorSpace+import Data.AffineSpace++import Music.Time.Pos+import Music.Time.Time+import Music.Time.Duration+import Music.Time.Delayable+import Music.Time.Stretchable++class HasDuration s where+ duration :: s a -> Duration s++-- |+-- Class of types with a position in time.+--+-- Onset and offset are logical start and stop time, i.e. the preferred beginning and end+-- of the sound, not o the the time of the attack and damp actions on an instrument,+--+-- If a type has an instance for both 'HasOnset' and 'HasDuration', the following laws+-- should hold:+-- +-- > duration a = offset a - onset a+-- > offset a >= onset a+--+-- implying+--+-- > duration a >= 0+--+class HasOnset s where+ -- | + -- Get the onset of the given value.+ --+ onset :: s a -> Time s++class HasOffset s where+ -- | + -- Get the offset of the given value.+ --+ offset :: s a -> Time s+ +class HasPreOnset s where+ preOnset :: s a -> Time s++class HasPostOnset s where+ postOnset :: s a -> Time s++class HasPostOffset s where+ postOffset :: s a -> Time s++-- | Given 'HasOnset' and 'HasOffset' instances, this function implements 'duration'.+durationDefault :: (AffineSpace (Time s), HasOffset s, HasOnset s) => s a -> Duration s+durationDefault x = offset x .-. onset x++-- | Given 'HasDuration' and 'HasOffset' instances, this function implements 'onset'.+onsetDefault :: (AffineSpace (Time s), HasOffset s, HasDuration s) => s a -> Time s+onsetDefault x = offset x .-^ duration x++-- | Given 'HasOnset' and 'HasOnset' instances, this function implements 'offset'.+offsetDefault :: (AffineSpace (Time s), HasOnset s, HasDuration s) => s a -> Time s+offsetDefault x = onset x .+^ duration x+ +newtype AddOffset t s a = AddOffset (t, s a)++type instance Time (AddOffset t s) = t++instance (Delayable a, t ~ Time a) => Delayable (AddOffset t a) where+ delay d (AddOffset (t,a)) = AddOffset (t, delay d a)++instance (Stretchable a, t ~ Time a) => Stretchable (AddOffset t a) where+ stretch d (AddOffset (t,a)) = AddOffset (t, stretch d a)++instance (HasOnset a, t ~ Time a) => HasOnset (AddOffset t a) where+ onset (AddOffset (t,a)) = onset a++instance HasOffset (AddOffset t s) where+ offset (AddOffset (t,_)) = t+
+ src/Music/Time/Performable.hs view
@@ -0,0 +1,59 @@++{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ RankNTypes,+ GeneralizedNewtypeDeriving #-} ++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Performable (+ Performable(..),+ foldMapDefault,+ ) where++import Data.Foldable (Foldable(..))++import Data.Semigroup+import Music.Time.Pos+import Music.Time.Time+import Music.Time.Duration+import Music.Time.Delayable+import Music.Time.Stretchable++-- |+-- Performable values.+--+-- Minimal complete definition: 'perform'.+-- +class Foldable s => Performable s where++ -- | Perform a score.+ --+ -- This is the inverse of 'compose'+ --+ perform :: (t ~ Time s, d ~ Duration s) => s a -> [(t, d, a)]++ -- | Perform a score, yielding an ordered list of values.+ --+ -- Equivalent to 'Foldable.toList', but may be more efficient.+ --+ toList' :: s a -> [a]+ toList' = map trd3 . perform+ where+ trd3 (a,b,c) = c+ +-- | This function may be used as a value for 'foldMap' in a 'Foldable' instance. +foldMapDefault :: (Performable s, Monoid m) => (a -> m) -> s a -> m+foldMapDefault f = foldMap f . toList'
+ src/Music/Time/Pos.hs view
@@ -0,0 +1,70 @@++{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ GeneralizedNewtypeDeriving #-} ++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Pos (+ Time(..),+ Duration(..),+ ) where++import Data.AffineSpace+import Music.Time.Time+import Music.Time.Duration++-- |+-- This type function returns the time type for a given type.+--+-- It has kind+--+-- > (* -> *) -> *+--+-- meaning that an instance should be written on the form:+--+-- > type instance Time a = b+--+-- where /a/ and /b/ are type-level expression of kind @* -> *@ and @*@ respectively.+--+type family Time (s :: * -> *) :: *++-- |+-- This type function returns the duration type for a given type.+--+type Duration a = Diff (Time a)++{-++type instance Time Double = Double+type instance Time Rational = Rational+type instance Time (a -> b) = Time b+type instance Time [a] = Time a+type instance Time (Maybe a) = Time a++-- TODO move+type instance Time TimeT = TimeT+type instance Time DurationT = DurationT+-}+++-- type instance Pos (Option a) = Pos a+-- type instance Pos (Set a) = Pos a+-- type instance Pos (Map k a) = Pos a+++++
+ src/Music/Time/Stretchable.hs view
@@ -0,0 +1,50 @@++{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ FlexibleContexts,+ ConstraintKinds,+ GeneralizedNewtypeDeriving #-} ++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Stretchable (+ Stretchable(..),+ ) where++import Data.Semigroup+import Data.VectorSpace+import Data.AffineSpace++import Music.Time.Time+import Music.Time.Duration+import Music.Time.Pos++-- -- |+-- -- Stretchable values.+-- -- +-- type Stretchable a = (VectorSpace a, Scalar a ~ Duration)+++-- |+-- Stretchable values. +-- +class Stretchable s where++ -- |+ -- Stretch (augment) a value by the given factor.+ -- + -- > Duration -> Score a -> Score a+ -- + stretch :: Duration s -> s a -> s a
+ src/Music/Time/Time.hs view
@@ -0,0 +1,73 @@++{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ GeneralizedNewtypeDeriving #-} ++-------------------------------------------------------------------------------------+-- |+-- Copyright : (c) Hans Hoglund 2012+--+-- License : BSD-style+--+-- Maintainer : hans@hanshoglund.se+-- Stability : experimental+-- Portability : non-portable (TF,GNTD)+--+-------------------------------------------------------------------------------------++module Music.Time.Time (+ TimeT,+ fromTimeT,+ toTimeT+ ) where++import Data.Semigroup+import Data.VectorSpace+import Data.AffineSpace++import Music.Time.Duration++-------------------------------------------------------------------------------------+-- Time type+-------------------------------------------------------------------------------------++-- |+-- This type represents absolute time in seconds since the start time. Note+-- that time can be negative, representing events occuring before the start time.+-- The start time is usually the the beginning of the musical performance. +--+-- Time forms an affine space with durations as the underlying vector space,+-- that is, we can add a time to a duration to get a new time using '.+^', +-- take the difference of two times to get a duration using '.-.'.+--+newtype TimeT = TimeT { getTimeT :: Rational }+ deriving (Eq, Ord, Num, Enum, Real, Fractional, RealFrac)++instance Show TimeT where + show = show . getTimeT++instance AdditiveGroup TimeT where+ zeroV = 0+ (^+^) = (+)+ negateV = negate++instance VectorSpace TimeT where+ type Scalar TimeT = TimeT+ (*^) = (*)++instance InnerSpace TimeT where + (<.>) = (*)++instance AffineSpace TimeT where+ type Diff TimeT = DurationT+ a .-. b = fromTimeT $ a - b+ a .+^ b = a + fromDurationT b++fromTimeT :: Fractional a => TimeT -> a+fromTimeT = fromRational . getTimeT++toTimeT :: Real a => a -> TimeT+toTimeT = TimeT . toRational+
− test/Main.hs
@@ -1,67 +0,0 @@--module Main where--import Music.Score--{--fj1 = sc $ melody [c,d] |> melody [eb,d]^/2 |> c-fj2 = sc $ melody [eb,f] |> g^*2-fj3 = sc $ g^*(3/4) |> ab^*(1/4) |> melody [g,f,eb,d] ^/2 |> c-fj4 = c |> g_ |> c^*2--fj = rep 2 fj1 |> rep 2 fj2 |> rep 2 fj3 |> rep 2 fj4--fj' = mempty- <> setVoices "Violin I" (rep 10 fj) - <> setVoices "Violin II" (delay 8 $ (rep 10 fj)^*(2/3)) - <> setVoices "Viola" (delay 16 $ (rep 10 fj)^*(4/5)) - <> setVoices "Violoncello" (delay 24 $ (rep 10 fj)^*(4/7))---- classic version...-fj'' = mempty- <> setVoices "Violin I" (rep 10 fj) - <> setVoices "Violin II" (delay 8 $ (rep 10 fj)) - <> setVoices "Viola" (delay 16 $ (rep 10 fj)) - <> setVoices "Violoncello" (delay 24 $ (rep 10 fj))---- rep 0 x = mempty--- rep n x = x |> rep (n-1) x-grp n p = rep n p^/n---- open$ (rep 3 $ grp 2 c |> grp 4 db |> grp 4 c |> (rest^*3))--testArtDyn = mempty- <> v (0+1) (rep 80 t^*(3*1))- <> v (0+2) (rep 80 t^*(4*1)) - <> v (0+3) (rep 80 t^*(5*1))- <> v (0+4) (rep 80 t^*(7*1))- <> v (4+1) (rep 20 s^*(3*2))- <> v (4+2) (rep 20 s^*(4*2)) - <> v (4+3) (rep 20 s^*(5*2))- <> v (4+4) (rep 20 s^*(7*2))- where- v x = setVoices (VoiceName $ "Violin I." ++ show x)- s, t :: Sc Double- s = mempty- |> (fmap (setLevel (-2.5) . setBeginSlur True . setBeginCresc True) c) - |> d - |> f - |> (fmap (setEndSlur True . setLevel (0.5) . setEndCresc True ) e)- t = mempty- |> (fmap (setLevel (-2.5) . setBeginSlur True . setBeginCresc True) g) - |> a - |> bb - |> (fmap (setEndSlur True . setLevel (0.5) . setEndCresc True ) a)--showScore :: Score Double -> String-showScore = show--play = playMidiIO . (^* (60/100)) . sc-open = openXml . (^* (1/4)) . sc--rep 0 x = mempty-rep n x = x |> rep (n-1) x- -}- -main = do- putStrLn "Testing Music.Score"