music-score (empty) → 1.2
raw patch · 18 files changed
+3759/−0 lines, 18 filesdep +HCodecsdep +basedep +containerssetup-changed
Dependencies added: HCodecs, base, containers, music-dynamics-literal, music-pitch-literal, musicxml2, parsec, random, reenact, semigroupoids, semigroups, time, transformers, unix, vector-space
Files
- COPYING +26/−0
- Setup.lhs +4/−0
- music-score.cabal +56/−0
- src/Music/Score.hs +1204/−0
- src/Music/Score/Articulation.hs +149/−0
- src/Music/Score/Combinators.hs +523/−0
- src/Music/Score/Duration.hs +85/−0
- src/Music/Score/Dynamics.hs +204/−0
- src/Music/Score/Ornaments.hs +145/−0
- src/Music/Score/Part.hs +113/−0
- src/Music/Score/Pitch.hs +109/−0
- src/Music/Score/Rhythm.hs +245/−0
- src/Music/Score/Score.hs +228/−0
- src/Music/Score/Ties.hs +139/−0
- src/Music/Score/Time.hs +120/−0
- src/Music/Score/Track.hs +143/−0
- src/Music/Score/Voice.hs +199/−0
- test/Main.hs +67/−0
+ COPYING view
@@ -0,0 +1,26 @@++Copyright (c) 2013, Hans Höglund+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of the <organization> nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL <COPYRIGHT HOLDER> BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ music-score.cabal view
@@ -0,0 +1,56 @@++name: music-score+version: 1.2+cabal-version: >= 1.2+author: Hans Hoglund+maintainer: Hans Hoglund+license: BSD3+license-file: COPYING+synopsis: Musical score and part representation.+category: Music+tested-with: GHC+build-type: Simple++description: + Musical score and part representation.+ + This library is part of the Haskell Music Suite, see <http://musicsuite.github.com>.++library + build-depends: + base >= 4 && < 5,+ unix,+ time,+ random, + containers, + parsec,+ transformers,+ HCodecs,+ musicxml2,+ semigroups,+ semigroupoids,+ vector-space,+ music-pitch-literal,+ music-dynamics-literal,+ reenact++ hs-source-dirs: src+ exposed-modules:+ Music.Score+ Music.Score.Time+ Music.Score.Duration+ Music.Score.Track+ Music.Score.Part+ Music.Score.Score+ Music.Score.Rhythm+ Music.Score.Combinators+ Music.Score.Pitch+ Music.Score.Voice+ Music.Score.Ties+ Music.Score.Articulation+ Music.Score.Dynamics+ Music.Score.Ornaments+ +executable "music-score-tests"+ hs-source-dirs: src test+ main-is: Main.hs
+ src/Music/Score.hs view
@@ -0,0 +1,1204 @@++{-# 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 => Score a -> Event MidiMessage+playMidi 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 "Graphic MIDI")+ -- FIXME hardcoded output...++-- |+-- Convert a score to a MIDI event and run it.+-- +playMidiIO :: HasMidi a => Score a -> IO ()+playMidiIO = runLoop . playMidi++ +++-------------------------------------------------------------------------------------++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+
+ src/Music/Score/Articulation.hs view
@@ -0,0 +1,149 @@+ +{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ FlexibleInstances,+ 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.Articulation (+ HasArticulation(..),+ ArticulationT(..),+ + -- ** Accents+ accent,+ marcato, + accentLast,+ marcatoLast,+ accentAll,+ marcatoAll,++ -- ** Phrasing+ tenuto,+ separated,+ staccato,+ portato,+ legato,+ spiccato,+ + -- ** Miscellaneous+ resetArticulation,+ + ) where++import Data.Ratio+import Data.Foldable+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.Combinators++class HasArticulation a where+ setBeginSlur :: Bool -> a -> a+ setContSlur :: Bool -> a -> a+ 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)++--------------------------------------------------------------------------------+-- Articulation+--------------------------------------------------------------------------------++-- 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)++-- 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) ++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/Combinators.hs view
@@ -0,0 +1,523 @@+ +{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ FlexibleInstances,+ OverloadedStrings,+ 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.Combinators (+ -- ** Constructing scores+ rest,+ note,+ chord,+ melody,++ -- ** Composing scores+ (|>),+ (<|),+ scat,+ pcat,+ + -- *** Special composition+ sustain,+ overlap,+ anticipate,+ + -- ** Transforming scores+ -- *** Moving in time+ move,+ moveBack,+ startAt,+ stopAt,++ -- *** Stretching in time+ stretch,+ compress,+ stretchTo,+ + -- ** Zipper+ apply,+ sample,+ trig,+ applySingle,+ sampleSingle, + + -- *** Structure+ + repTimes,+ repWith,+ repWithIndex,+ repWithTime,+ group,+ groupWith,+ scatMap,+ rev, + before,+ first,+ butFirst,++ + -- ** Conversion+ scoreToTrack,+ scoreToPart,+ scoreToParts,+ partToScore,+ trackToScore,+ ) where++import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)++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.Part+import Music.Score.Score+import Music.Score.Duration+import Music.Score.Time+import Music.Score.Ties+import Music.Score.Voice+++-------------------------------------------------------------------------------------+-- Constructors+-------------------------------------------------------------------------------------++-- | Creates a score containing the given elements, composed in sequence.+melody :: [a] -> Score a+melody = scat . map note++-- | Creates a score containing the given elements, composed in parallel.+chord :: [a] -> Score a+chord = pcat . map note++-- | Creates a score from a the given melodies, composed in parallel.+melodies :: [[a]] -> Score a+melodies = pcat . map melody++-- | Creates a score from a the given chords, composed in sequence.+chords :: [[a]] -> Score a+chords = scat . map chord++-- | Like 'melody', but stretching each note by the given factors.+melodyStretch :: [(Duration, a)] -> Score 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 )++-- | 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)+++-------------------------------------------------------------------------------------+-- Transformations+-------------------------------------------------------------------------------------++-- |+-- Move a score move in time. Equivalent to 'delay'.+-- +-- > Duration -> Score a -> Score a+-- +move :: Delayable a => Duration -> a -> a+move = delay++-- |+-- Move a score moveBack in time. Negated verison of 'delay'+-- +-- > Duration -> Score a -> Score a+-- +moveBack :: Delayable a => Duration -> a -> a+moveBack t = delay (negate t)++-- |+-- Stretch a score. Equivalent to '*^'.+-- +-- > Duration -> Score a -> Score a+-- +stretch :: VectorSpace v => Scalar v -> v -> v+stretch = (*^)++-- |+-- Move a score to start at a 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++-- |+-- Move a score to stop at a specific time.+-- +-- > 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 a score. Flipped version of '^/'.+-- +-- > Duration -> Score a -> Score a+-- +compress :: (VectorSpace v, s ~ Scalar v, Fractional s) => s -> v -> v+compress = flip (^/)++-- | +-- 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+-------------------------------------------------------------------------------------++infixr 6 |>+infixr 6 <|++-- |+-- Compose in sequence.+--+-- To compose in parallel, use '<>'.+--+-- > Score a -> Score a -> Score a+(|>) :: (Semigroup a, Delayable a, HasOnset a) => a -> a -> a+a |> b = a <> startAt (offset a) b+-- a |< b = a <> stopAt (onset a) b+++-- |+-- Compose in reverse sequence. +--+-- To compose in parallel, use '<>'.+--+-- > Score a -> Score a -> Score a+(<|) :: (Semigroup a, Delayable a, HasOnset a) => a -> a -> 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++-- |+-- Parallel concatentation. A synonym for 'mconcat'.+--+-- > [Score t] -> Score t+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++-- 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.+--+-- > 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 ++-- |+-- 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++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++-- |+-- Get all notes that start during a given note.+--+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)+++-- | 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)+++-------------------------------------------------------------------------------------+-- Conversion++-- |+-- Convert a score to a track by throwing away durations.+--+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.+--+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.+--+scoreToParts :: (HasVoice a, Voice a ~ v, Ord v) => Score a -> [Part (Maybe a)]+scoreToParts = fmap scoreToPart . voices++-- |+-- Convert a part to a score.+--+partToScore :: Part a -> Score a+partToScore = scat . fmap g . getPart+ where+ g (d,x) = stretch d (note x)++-- |+-- Convert a track to a score. Each note gets an arbitrary duration of one.+--+trackToScore :: Track a -> Score a+trackToScore = pcat . fmap g . getTrack+ where+ g (t,x) = delay (t .-. 0) (note x)+++--------------------------------------------------------------------------------+-- Structure+--------------------------------------------------------------------------------++-- |+-- Repeat exact amount of times.+--+-- > Duration -> Score Note -> Score Note+--+repTimes :: (Enum a, Monoid c, HasOnset c, Delayable c) => a -> c -> c+repTimes n a = replicate (0 `max` fromEnum n) () `repWith` (const a)++-- |+-- Repeat once for each element in the list.+--+-- > [a] -> (a -> Score Note) -> Score Note+--+-- Example:+--+-- > repWith [1,2,1] (c^*)+--+repWith :: (Monoid c, HasOnset c, Delayable c) => [a] -> (a -> c) -> c+repWith = flip (\f -> scat . fmap f)++-- |+-- Combination of 'scat' and 'fmap'. Note that+--+-- > scatMap = flip repWith+--+scatMap f = scat . fmap f++-- |+-- Repeat exact amount of times with an index.+--+-- > Duration -> (Duration -> Score Note) -> Score Note+--+repWithIndex :: (Enum a, Num a, Monoid c, HasOnset c, Delayable c) => a -> (a -> c) -> c+repWithIndex n = repWith [0..n-1]++-- |+-- Repeat exact amount of times with relative time.+--+-- > Duration -> (Time -> Score Note) -> Score Note+--+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++-- |+-- Repeat a number of times and scale down by the same amount.+--+-- > Duration -> Score a -> Score a+--+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)++-- |+-- Repeat a number of times and scale down by the same amount.+--+-- > [Duration] -> Score a -> Score a+--+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)++-- |+-- Reverse a score around its middle point.+--+-- > onset a = onset (rev a)+-- > duration a = duration (rev a)+-- > offset a = offset (rev a)+--+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++-- |+-- Repeat indefinately, like repeat for lists.+--+-- > Score Note -> Score Note+--+rep :: Score a -> Score a+rep a = a `plus` delay (duration a) (rep a)+ where+ Score as `plus` Score bs = Score (as <> bs)+++infixl 6 ||>+a ||> b = padToBar a |> b+bar = rest^*4++padToBar a = a |> (rest ^* (d' * 4))+ where+ d = snd $ properFraction $ duration a / 4+ d' = if (d == 0) then 0 else (1-d)+++rotl [] = []+rotl (x:xs) = xs ++ [x]++rotr [] = []+rotr xs = (last xs:init xs)++rotated n as | n >= 0 = iterate rotr as !! n+ | n < 0 = iterate rotl as !! (abs n)++++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+++tau = pi*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 ++++++++++-- FIXME consolidate+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"
+ src/Music/Score/Duration.hs view
@@ -0,0 +1,85 @@+ +{-# 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
@@ -0,0 +1,204 @@+ +{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ FlexibleInstances,+ 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.Dynamics (+ HasDynamic(..),+ DynamicT(..),++ -- ** Dynamics over time+ Levels(..),+ cresc,+ dim,++ -- ** Application+ dynamicSingle,+ dynamics,++ -- ** Miscellaneous+ resetDynamics,+ ) where++import Control.Monad+import Data.Semigroup+import Data.Ratio+import Data.Foldable+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.Combinators++import Music.Dynamics.Literal++class HasDynamic a where+ setBeginCresc :: Bool -> a -> a+ setEndCresc :: Bool -> a -> a+ setBeginDim :: Bool -> a -> a+ setEndDim :: Bool -> a -> a+ setLevel :: Double -> a -> a++-- 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)++++--------------------------------------------------------------------------------+-- Dynamics+--------------------------------------------------------------------------------++-- 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 +++-- | 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 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.+--+dynamicSingle :: HasDynamic a => Score (Levels Double) -> Score a -> Score a+dynamicSingle d a = (duration a `stretchTo` d) `dyn` a++++-- | 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))++-- | 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)++resetDynamics :: HasDynamic c => c -> c+resetDynamics = setBeginCresc False . setEndCresc False . setBeginDim False . setEndDim False+++-- |+-- Represents dynamics over a duration.+--+data Levels a+ = Level a+ | Change a a+ deriving (Eq, Show)++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-}++cresc :: IsDynamics a => Double -> Double -> a+cresc a b = fromDynamics $ DynamicsL ((Just a), (Just b))++dim :: IsDynamics a => Double -> Double -> a+dim a b = fromDynamics $ DynamicsL ((Just a), (Just b))+++-- end cresc, end dim, level, begin cresc, begin dim+type Levels2 a = (Bool, Bool, Maybe a, Bool, Bool)++dyn2 :: Ord a => [Levels a] -> [Levels2 a]+dyn2 = snd . List.mapAccumL g (Nothing, False, False) -- level, cresc, dim+ where+ 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) + | 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) + | 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++applyDynSingle :: HasDynamic a => Part (Levels Double) -> Score a -> Score a+applyDynSingle ds as = applySingle ds3 as+ where+ -- ds2 :: Part (Dyn2 Double)+ ds2 = transf dyn2 ds+ -- ds3 :: Part (Score a -> Score a)+ ds3 = (flip fmap) ds2 g+ + 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) +++++second :: (a -> b) -> (c,a) -> (c,b)+second f (a,b) = (a,f b)++toFrac :: (Real a, Fractional b) => a -> b+toFrac = fromRational . toRational++fromJust (Just x) = x
+ src/Music/Score/Ornaments.hs view
@@ -0,0 +1,145 @@+ +{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ FlexibleInstances,+ 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.Ornaments (+ HasTremolo(..),+ TremoloT(..),+ HasText(..),+ TextT(..),+ HasHarmonic(..),+ HarmonicT(..),+ HasSlide(..),+ SlideT(..),+ + tremolo,+ text,+ harmonic,+ artificial,+ slide,+ ) where++import Data.Ratio+import Data.Foldable+import Data.Monoid+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.Combinators++class HasTremolo a where+ setTrem :: Int -> a -> a++newtype TremoloT a = TremoloT { getTremoloT :: (Int, a) }+ deriving (Eq, Show, Ord, Functor{-, Foldable-})++class HasText a where+ addText :: String -> a -> a++newtype TextT a = TextT { getTextT :: ([String], a) }+ deriving (Eq, Show, Ord, Functor{-, Foldable-})+++-- 0 for none, positive for natural, negative for artificial+class HasHarmonic a where+ setHarmonic :: Int -> a -> a++newtype HarmonicT a = HarmonicT { getHarmonicT :: (Int, a) }+ deriving (Eq, Show, Ord, Functor{-, Foldable-})++-- end gliss/slide, level, begin gliss/slide+class HasSlide a where+ setBeginGliss :: Bool -> a -> a+ setBeginSlide :: Bool -> a -> a+ setEndGliss :: Bool -> a -> a+ setEndSlide :: Bool -> a -> a++newtype SlideT a = SlideT { getSlideT :: (Bool, Bool, a, Bool, Bool) }+ deriving (Eq, Show, Ord, Functor{-, Foldable-})+++-- |+-- Add tremolo cross-beams to all notes in the score.+--+tremolo :: (Functor f, HasTremolo b) => Int -> f b -> f b+tremolo n = fmap (setTrem n)++-- |+-- Add 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++-- |+-- 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)++-- |+-- 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++-- |+-- 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) ++
+ src/Music/Score/Part.hs view
@@ -0,0 +1,113 @@+ +{-# 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.Part (+ Part(..)+ ) where++import Prelude hiding (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.Maybe+import Data.Either+import Data.Function (on)+import Data.Ord (comparing)+import Data.Ratio+import Data.VectorSpace+import Data.AffineSpace++import Music.Score.Time+import Music.Score.Duration++-------------------------------------------------------------------------------------+-- Part type+-------------------------------------------------------------------------------------++-- |+-- A part is a sorted list of relative-time notes and rests.+--+-- Part is a 'Monoid' under sequential composition. 'mempty' is the empty part and 'mappend'+-- appends parts.+--+-- Part has an 'Applicative' instance derived from the 'Monad' instance.+--+-- 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. +--+-- > 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') ]}+--+-- Part is a 'VectorSpace' using sequential composition as addition, and time scaling+-- as scalar multiplication.+--+newtype Part a = Part { getPart :: [(Duration, a)] }+ deriving (Eq, Ord, Show, Functor, Foldable, Monoid)++instance Semigroup (Part a) where+ (<>) = mappend++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++instance AdditiveGroup (Part a) where+ zeroV = mempty+ (^+^) = mappend+ negateV = id++instance VectorSpace (Part a) where+ type Scalar (Part a) = Duration+ n *^ Part as = Part (fmap (first (n*^)) as)++instance HasDuration (Part a) where+ duration (Part []) = 0+ duration (Part as) = sum (fmap fst as)+ ++++++list z f [] = z+list z f xs = f xs++first f (x,y) = (f x, y)+second f (x,y) = (x, f y)
+ src/Music/Score/Pitch.hs view
@@ -0,0 +1,109 @@+ +{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ FlexibleInstances,+ 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.Pitch (+ HasPitch(..),+ PitchT(..),+ getPitches,+ setPitches,+ modifyPitches,+ ) where++import Control.Monad (ap, mfilter, join, liftM, MonadPlus(..))+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 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+++newtype PitchT p a = PitchT { getPitchT :: (p, a) }+ deriving (Eq, Ord, Show, Functor)++instance HasPitch (PitchT p a) where+ type Pitch (PitchT p a) = p+ getPitch (PitchT (v,_)) = v+ modifyPitch f (PitchT (v,x)) = PitchT (f v, x)++instance HasPitch () where { type Pitch () = () ; getPitch = id; modifyPitch = id }+instance HasPitch Double where { type Pitch Double = Double ; getPitch = id; modifyPitch = id }+instance HasPitch Float where { type Pitch Float = Float ; getPitch = id; modifyPitch = id }+instance HasPitch Int where { type Pitch Int = Int ; getPitch = id; modifyPitch = id }+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 }++-- |+-- Get all pitches in the given score. Returns a list of pitches.+--+-- > Score a -> [Pitch]+--+getPitches :: (HasPitch a, Eq v, v ~ Pitch a, Foldable s) => s a -> [Pitch a]+getPitches = List.nub . fmap getPitch . toList++-- |+-- Set all pitches in the given score.+--+-- > Pitch -> Score a -> Score a+--+setPitches :: (HasPitch a, Functor s) => Pitch a -> s a -> s a+setPitches n = fmap (setPitch n)++-- |+-- Modify all pitches in the given score.+--+-- > (Pitch -> Pitch) -> Score a -> Score a+--+modifyPitches :: (HasPitch a, Functor s) => (Pitch a -> Pitch a) -> s a -> s a+modifyPitches n = fmap (modifyPitch n)
+ src/Music/Score/Rhythm.hs view
@@ -0,0 +1,245 @@++{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable, + GeneralizedNewtypeDeriving,+ ScopedTypeVariables #-} ++-------------------------------------------------------------------------------------+-- |+-- 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.Rhythm (+ -- * Rhythm type+ Rhythm(..), ++ -- * Quantization+ quantize,+ dotMod,+ ) where++import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)++import Data.Semigroup+import Control.Applicative+import Control.Monad (ap, join, MonadPlus(..))+import Data.Maybe+import Data.Either+import Data.Foldable+import Data.Traversable+import Data.Function (on)+import Data.Ord (comparing)+import Data.Ratio+import Data.VectorSpace++import Text.Parsec hiding ((<|>))+import Text.Parsec.Pos++import Music.Score.Time+import Music.Score.Duration+import Music.Score.Ties+++data Rhythm a + = Beat Duration a -- d is divisible by 2+ | 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+ deriving (Eq, Show, Functor, Foldable)+ -- RInvTuplet Duration (Rhythm a)++instance Semigroup (Rhythm a) where+ (<>) = mappend++-- Catenates using 'Rhythms'+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])++instance AdditiveGroup (Rhythm a) where+ zeroV = error "No zeroV for (Rhythm a)"+ (^+^) = error "No ^+^ for (Rhythm a)"+ negateV = error "No negateV for (Rhythm a)"++instance VectorSpace (Rhythm a) where+ type Scalar (Rhythm a) = Duration+ 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) ++quantize :: [(Duration, a)] -> Either String (Rhythm a)+quantize = quantize' (atEnd rhythm)+++-- Internal...++testQuantize :: [Duration] -> Either String (Rhythm ())+testQuantize = quantize' (atEnd rhythm) . fmap (\x->(x,()))++dotMod :: Int -> Duration+dotMod n = dotMods !! (n-1)++-- [3/2, 7/4, 15/8, 31/16 ..]+dotMods :: [Duration]+dotMods = zipWith (/) (fmap pred $ drop 2 times2) (drop 1 times2)+ where+ times2 = iterate (*2) 1++tupletMods :: [Duration]+tupletMods = [2/3, 4/5, {-4/6,-} 4/7, 8/9]+++-- 3/2 for dots+-- 2/3, 4/5, 4/6, 4/7, 8/9, 8/10, 8/11 for ordinary tuplets+-- 3/2, 6/4 for inverted tuplets++data RState = RState {+ timeMod :: Duration, -- time modification; notatedDur * timeMod = actualDur+ timeSub :: Duration, -- time subtraction (in bound note)+ tupleDepth :: Int+ }++instance Monoid RState where+ mempty = RState { timeMod = 1, timeSub = 0, tupleDepth = 0 }+ a `mappend` _ = a++modifyTimeMod :: (Duration -> Duration) -> RState -> RState+modifyTimeMod f (RState tm ts td) = RState (f tm) ts td++modifyTimeSub :: (Duration -> Duration) -> 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++quantize' :: RhythmParser a b -> [(Duration, 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 p = tokenPrim show next test+ where+ show x = ""+ next pos _ _ = updatePosChar pos 'x'+ 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)++rhythmNoBound :: RhythmParser a (Rhythm a)+rhythmNoBound = Rhythms <$> Text.Parsec.many1 rhythm'++rhythm' :: RhythmParser a (Rhythm a)+rhythm' = mzero+ <|> beat+ <|> dotted+ <|> tuplet++-- Matches a beat divisible by 2 (notated)+beat :: RhythmParser a (Rhythm a)+beat = do+ RState tm ts _ <- getState+ (\d -> (d^/tm) `subDur` ts) <$> match (\d _ -> + d - ts > 0 + &&+ isDivisibleBy 2 (d / tm - ts)) -- TODO or is it (d - ts) / tm++-- | Matches a dotted rhythm+dotted :: RhythmParser a (Rhythm a)+dotted = msum . fmap dotted' $ [1..2] -- max 2 dots++dotted' :: Int -> RhythmParser a (Rhythm a)+dotted' n = do+ modifyState $ modifyTimeMod (* dotMod n)+ a <- beat+ modifyState $ modifyTimeMod (/ dotMod n)+ return (Dotted n a)+++-- | Matches a bound rhythm+bound :: RhythmParser a (Rhythm a)+bound = bound' (1/2)+++bound' :: Duration -> RhythmParser a (Rhythm a)+bound' d = do+ modifyState $ modifyTimeSub (+ d)+ a <- rhythm'+ modifyState $ modifyTimeSub (subtract d)+ return $ Bound d a++-- | Matches a tuplet+tuplet :: 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' d = do+ RState _ _ depth <- getState+ onlyIf (depth < 1) $ do -- max 1 nested tuplets+ modifyState $ modifyTimeMod (* d) + . modifyTupleDepth succ+ a <- rhythmNoBound + modifyState $ modifyTimeMod (/ d) + . modifyTupleDepth pred+ return (Tuplet d a)++++-- |+-- Succeed only if the entire input is consumed.+--+atEnd :: RhythmParser a b -> RhythmParser a b+atEnd p = do+ x <- p+ notFollowedBy' anyToken' <?> "end of input"+ return x+ 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 + | isInfinite (fromRational n :: a) = logBaseR k (n/k) + 1+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 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
@@ -0,0 +1,228 @@+ +{-# 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.Score (+ Score(..),+ rest,+ note, + -- filterS,+ perform,+ performRelative+ ) where++import Prelude hiding (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.Maybe+import Data.Either+import Data.Function (on)+import Data.Ord (comparing)+import Data.Ratio+import Data.VectorSpace+import Data.AffineSpace+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++-------------------------------------------------------------------------------------+-- 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.+--+-- 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. +--+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++instance Ord a => Ord (Score a) where+ a `compare` b = perform a `compare` perform b++instance Semigroup (Score a) where+ (<>) = mappend++-- Equivalent to the derived Monoid, except for the sorted invariant.+instance Monoid (Score a) where+ mempty = Score []+ Score as `mappend` Score bs = Score (as `m` bs)+ where+ m = mergeBy (comparing fst3)+ fst3 (a,b,c) = a++instance Applicative Score where+ pure = return+ (<*>) = ap++instance Alternative Score where+ empty = mempty+ (<|>) = mappend++-- Satisfies left distribution+instance MonadPlus Score where+ 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 AdditiveGroup (Score a) where+ zeroV = mempty+ (^+^) = mappend+ negateV = id++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+ 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+ -- 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+ 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 ++instance IsPitch a => IsPitch (Score a) where+ fromPitch = pure . fromPitch++instance IsDynamics a => IsDynamics (Score a) where+ fromDynamics = pure . fromDynamics+++-- |+-- Create a score of duration one with no values.+--+rest :: Score a+rest = Score [(0,1,Nothing)]++-- |+-- Create a score of duration one with the given value. Equivalent to 'pure' and '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+-}++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++performRelative :: Score a -> [(Time, Duration, a)]+performRelative = toRel . perform+ where+ toRel = snd . mapAccumL g 0+ g now (t,d,x) = (t, (t-now,d,x))++++++++ ++list z f [] = z+list z f xs = f xs++first f (x,y) = (f x, y)+second f (x,y) = (x, f y)+++mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+mergeBy f as bs = List.sortBy f $ as <> bs+
+ src/Music/Score/Ties.hs view
@@ -0,0 +1,139 @@+ +{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ FlexibleInstances,+ 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.Ties (+ Tiable(..),+ TieT(..),+ splitTies,+ splitTiesSingle,+ splitTiesPart,+ ) where++import Data.Ratio+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++++-- |+-- Class of types that can be tied.+--+class Tiable a where+ -- | 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)++newtype TieT a = TieT { getTieT :: (Bool, a, Bool) } + deriving (Eq, Ord, Show, Functor)++-- 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 a => Tiable (Maybe a) where+ 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))+ 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"++-- | +-- Split all notes that cross a barlines into a pair of tied notes.+-- Note: only works for single-part scores (with no 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)] ++)++-- | +-- 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+ where+ g t (d, x) = (t + d, occs) + where+ (_, barTime) = properFraction t+ remBarTime = 1 - barTime+ occs = splitDur remBarTime (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.+--+-- > 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++-- |+-- 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' 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 view
@@ -0,0 +1,120 @@++{-# 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
@@ -0,0 +1,143 @@+ +{-# 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.Track (+ Track(..)+ ) where++import Prelude hiding (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.Maybe+import Data.Either+import Data.Function (on)+import Data.Ord (comparing)+import Data.Ratio+import Data.VectorSpace+import Data.AffineSpace+import qualified Data.Map as Map+import qualified Data.List as List++import Music.Score.Time+import Music.Score.Duration++-------------------------------------------------------------------------------------+-- Track type+-------------------------------------------------------------------------------------++-- |+-- A track is a sorted list of absolute-time occurences.+--+-- Track is a 'Monoid' under parallel composition. 'mempty' is the empty track and 'mappend'+-- interleaves values.+--+-- Track has an 'Applicative' instance derived from the 'Monad' instance.+--+-- Track is a 'Monad'. 'return' creates a track containing a single value at time+-- 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. +--+-- > let t = Track [(0, 65),(1, 66)] +-- >+-- > t >>= \x -> Track [(0, 'a'), (10, toEnum x)]+-- >+-- > ==> Track {getTrack = [ (0.0, 'a'),+-- > (1.0, 'a'),+-- > (10.0, 'A'),+-- > (11.0, 'B') ]}+--+-- Track is an instance of 'VectorSpace' using parallel composition as addition, +-- and time scaling as scalar multiplication. +--+newtype Track a = Track { getTrack :: [(Time, a)] }+ deriving (Eq, Ord, Show, Functor, Foldable)++instance Semigroup (Track a) where+ (<>) = mappend++-- Equivalent to the derived Monoid, except for the sorted invariant.+instance Monoid (Track a) where+ mempty = Track []+ Track as `mappend` Track bs = Track (as `m` bs)+ 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)++instance Alternative Track where+ empty = mempty+ (<|>) = mappend++-- Satisfies left distribution+instance MonadPlus Track where+ 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 Delayable (Track a) where+ d `delay` Track tr = Track . fmap (first (.+^ d)) $ tr++instance HasOnset (Track a) where+ onset (Track []) = 0+ onset (Track xs) = minimum (fmap on xs) where on (t,x) = t+ offset (Track []) = 0+ offset (Track xs) = maximum (fmap off xs) where off (t,x) = t++instance HasDuration (Track a) where+ duration x = offset x .-. onset x++-- offset x = maximum (fmap off x) where off (t,x) = t+ +++list z f [] = z+list z f xs = f xs++first f (x,y) = (f x, y)+second f (x,y) = (x, f y)+++mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]+mergeBy f as bs = List.sortBy f $ as <> bs+
+ src/Music/Score/Voice.hs view
@@ -0,0 +1,199 @@+ +{-# LANGUAGE+ TypeFamilies,+ DeriveFunctor,+ DeriveFoldable,+ FlexibleInstances,+ OverloadedStrings,+ 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.Voice (+ HasVoice(..),+ -- VoiceName(..),+ VoiceT(..),+ voices,+ mapVoice,+ mapVoices,+ getVoices,+ setVoices,+ modifyVoices,+ + -- ** Voice composition+ (</>),+ moveParts,+ moveToPart,+ ) where++import Control.Monad (ap, mfilter, join, liftM, MonadPlus(..))+import Data.Semigroup+import Data.String+import Data.Foldable+import Data.Ord (comparing)+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 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)++-- |+-- 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))++-- |+-- 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++-- |+-- Get all voices in the given score. Returns a list of voices.+--+-- > Score a -> [Voice]+--+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 -> Score a -> Score a+--+setVoices :: (HasVoice a, Functor s) => Voice a -> s a -> s a+setVoices n = fmap (setVoice n)++-- |+-- Modify all voices in the given score.+--+-- > (Voice -> Voice) -> Score a -> Score a+--+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.+--+(</>) :: (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+++-- |+-- 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)++-- |+-- 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)++++++++++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)
+ test/Main.hs view
@@ -0,0 +1,67 @@++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"