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