music-score-1.2: src/Music/Score.hs
{-# LANGUAGE
CPP,
TypeFamilies,
DeriveFunctor,
DeriveFoldable,
GeneralizedNewtypeDeriving,
FlexibleInstances,
TypeOperators,
OverloadedStrings,
FlexibleContexts, -- for IsPitch stuff
NoMonomorphismRestriction #-}
-------------------------------------------------------------------------------------
-- |
-- Copyright : (c) Hans Hoglund 2012
--
-- License : BSD-style
--
-- Maintainer : hans@hanshoglund.se
-- Stability : experimental
-- Portability : non-portable (TF,GNTD)
--
-- Provides a musical score represenation.
--
-------------------------------------------------------------------------------------
module Music.Score (
module Music.Score.Time,
module Music.Score.Duration,
module Music.Score.Track,
module Music.Score.Part,
module Music.Score.Score,
module Music.Score.Pitch,
module Music.Score.Voice,
module Music.Score.Ties,
module Music.Score.Articulation,
module Music.Score.Dynamics,
module Music.Score.Ornaments,
-- ** Constructors
#ifdef __HADDOCK__
rest,
note,
chord,
melody,
#endif
-- ** Composing
(|>),
(<|),
scat,
-- pcat,
-- sustain,
-- overlap,
-- anticipate,
-- ** Transforming
move,
moveBack,
startAt,
stopAt,
stretch,
compress,
stretchTo,
-- ** Conversions
scoreToTrack,
scoreToPart,
scoreToParts,
partToScore,
trackToScore,
-- * Export
-- ** MIDI
HasMidi(..),
toMidi,
writeMidi,
playMidi,
playMidiIO,
-- ** MusicXML
XmlScore,
XmlMusic,
HasMusicXml(..),
toXml,
writeXml,
openXml,
toXmlPart,
writeXmlPart,
openXmlPart,
)
where
{-
TODO
Split and reverse
Zipper applicative (for appying dynamic and articulation transformations etc)
-}
import Prelude hiding (foldr, concat, foldl, mapM, concatMap, maximum, sum, minimum)
import Data.Semigroup
import Data.Ratio
import Data.String
import Control.Applicative
import Control.Monad (ap, mfilter, join, liftM, MonadPlus(..))
import Data.Maybe
import Data.Either
import Data.Foldable
import Data.Traversable
import Data.Function (on)
import Data.Ord (comparing)
import Data.VectorSpace
import Data.AffineSpace
import Data.Basis
import Control.Reactive
import Control.Reactive.Midi
import Music.Score.Time
import Music.Score.Duration
import Music.Score.Rhythm
import Music.Score.Track
import Music.Score.Part
import Music.Score.Score
import Music.Score.Combinators
import Music.Score.Pitch
import Music.Score.Ties
import Music.Score.Voice
import Music.Score.Articulation
import Music.Score.Dynamics
import Music.Score.Ornaments
import qualified Codec.Midi as Midi
import qualified Music.MusicXml.Simple as Xml
import qualified Data.Map as Map
import qualified Data.List as List
import System.Posix
import System.IO.Unsafe
import Music.Pitch.Literal
import Music.Dynamics.Literal
-------------------------------------------------------------------------------------
-- |
-- Class of types that can be converted to MIDI.
--
-- Numeric types are interpreted as notes with a default velocity, pairs are
-- interpreted as @(pitch, velocity)@ pairs.
--
-- Minimal definition: 'getMidi'. Given 'getMidiScore', 'getMidi' can be implemented
-- as @getMidiScore . return@.
--
class HasMidi a where
-- | Convert a value to a MIDI score.
-- Typically, generates an /on/ event using 'note' followed by an optional /off/ event.
getMidi :: a -> Score Midi.Message
-- | Convert a score to a MIDI score.
-- The default definition can be overriden for efficiency.
getMidiScore :: Score a -> Score Midi.Message
getMidiScore = (>>= getMidi)
instance HasMidi Double where getMidi = getMidi . toInteger . round
instance HasMidi Float where getMidi = getMidi . toInteger . round
instance HasMidi Int where getMidi = getMidi . toInteger
instance Integral a => HasMidi (Ratio a) where getMidi = getMidi . toInteger . round
instance HasMidi Midi.Message where getMidi = return
instance HasMidi Integer where getMidi = \x -> getMidi (x,100::Integer)
instance HasMidi (Integer, Integer) where
getMidi (p,v) = mempty
|> note (Midi.NoteOn 0 (fromIntegral p) (fromIntegral v))
|> note (Midi.NoteOff 0 (fromIntegral p) (fromIntegral v))
-- |
-- Convert a score to a MIDI file representaiton.
--
toMidi :: HasMidi a => Score a -> Midi.Midi
toMidi score = Midi.Midi fileType divisions' [controlTrack, eventTrack]
where
endPos = 10000
fileType = Midi.MultiTrack
divisions = 1024
divisions' = Midi.TicksPerBeat divisions
controlTrack = [(0, Midi.TempoChange 1000000), (endPos, Midi.TrackEnd)]
eventTrack = events <> [(endPos, Midi.TrackEnd)]
events :: [(Midi.Ticks, Midi.Message)]
events = (\(t,_,x) -> (round (t * divisions), x)) <$> performance
performance :: [(Time, Duration, Midi.Message)]
performance = performRelative (getMidiScore score)
-- FIXME arbitrary endTime (files won't work without this...)
-- TODO handle voice
-- |
-- Convert a score MIDI and write to a file.
--
writeMidi :: HasMidi a => FilePath -> Score a -> IO ()
writeMidi path sc = Midi.exportFile path (toMidi sc)
-- |
-- Convert a score to a MIDI event.
--
playMidi :: HasMidi a => Score a -> Event MidiMessage
playMidi x = midiOut midiDest $ playback trig (pure $ toTrack $ rest^*0.2 |> x)
where
trig = accumR 0 ((+ 0.005) <$ pulse 0.005)
toTrack = fmap (\(t,_,m) -> (t,m)) . perform . getMidiScore
midiDest = fromJust $ unsafeGetReactive (findDestination $ pure "Graphic MIDI")
-- FIXME hardcoded output...
-- |
-- Convert a score to a MIDI event and run it.
--
playMidiIO :: HasMidi a => Score a -> IO ()
playMidiIO = runLoop . playMidi
-------------------------------------------------------------------------------------
type XmlScore = Xml.Score
type XmlMusic = Xml.Music
-- |
-- Class of types that can be converted to MusicXML.
--
class Tiable a => HasMusicXml a where
-- |
-- Convert a value to MusicXML.
--
-- Typically, generates a 'XmlMusic' value using 'Xml.note' or 'Xml.chord', and transforms it
-- to add beams, slurs, dynamics, articulation etc.
--
getMusicXml :: Duration -> a -> XmlMusic
instance HasMusicXml Double where getMusicXml d = getMusicXml d . (toInteger . round)
instance HasMusicXml Float where getMusicXml d = getMusicXml d . (toInteger . round)
instance HasMusicXml Int where getMusicXml d = getMusicXml d . toInteger
instance Integral a => HasMusicXml (Ratio a) where getMusicXml d = getMusicXml d . (toInteger . round)
-- FIXME arbitrary spelling, please modularize...
instance HasMusicXml Integer where
getMusicXml d p = Xml.note (spell (fromIntegral p)) d'
where
d' = (fromRational . toRational $ d)
step xs p = xs !! (p `mod` length xs)
fromStep xs p = fromMaybe (length xs - 1) $ List.findIndex (>= p) xs
scaleFromSteps = snd . List.mapAccumL add 0
where
add a x = (a + x, a + x)
major = scaleFromSteps [0,2,2,1,2,2,2,1]
spell :: Int -> Xml.Pitch
spell p = (toEnum pitchClass, if (alteration == 0) then Nothing else Just (fromIntegral alteration), fromIntegral octave)
where
octave = (p `div` 12) - 1
semitone = p `mod` 12
pitchClass = fromStep major semitone
alteration = semitone - step major pitchClass
-- |
-- Convert a score to MusicXML and write to a file.
--
writeXml :: (HasMusicXml a, HasVoice a, v ~ Voice a, Ord v, Show v) => FilePath -> Score a -> IO ()
writeXml path sc = writeFile path (Xml.showXml $ toXml sc)
-- |
-- Convert a score to MusicXML and open it.
--
openXml :: (HasMusicXml a, HasVoice a, v ~ Voice a, Ord v, Show v) => Score a -> IO ()
openXml sc = do
writeXml "test.xml" sc
execute "open" ["-a", "/Applications/Sibelius 6.app/Contents/MacOS/Sibelius 6", "test.xml"]
-- FIXME hardcode
-- |
-- Convert a score to MusicXML and write to a file.
--
writeXmlPart :: HasMusicXml a => FilePath -> Score a -> IO ()
writeXmlPart path sc = writeFile path (Xml.showXml $ toXmlPart sc)
-- |
-- Convert a score to MusicXML and open it.
--
openXmlPart :: HasMusicXml a => Score a -> IO ()
openXmlPart sc = do
writeXmlPart "test.xml" sc
execute "open" ["-a", "/Applications/Sibelius 6.app/Contents/MacOS/Sibelius 6", "test.xml"]
-- FIXME hardcode
-- |
-- Convert a score to a MusicXML representaiton.
--
toXml :: (HasMusicXml a, HasVoice a, v ~ Voice a, Ord v, Show v) => Score a -> XmlScore
toXml sc = Xml.fromParts "Title" "Composer" pl . fmap toXmlPart' . voices $ sc
where
pl = Xml.partList (fmap show $ getVoices sc)
-- |
-- Convert a single-part score to a MusicXML representaiton.
--
toXmlPart :: HasMusicXml a => Score a -> XmlScore
toXmlPart = Xml.fromPart "Title" "Composer" "Part" . toXmlPart'
toXmlPart' :: HasMusicXml a => Score a -> [XmlMusic]
toXmlPart' = id
. prelims
. fmap barToXml
. separateBars
. splitTiesSingle
. addRests
. perform
where
prelims [] = []
prelims (bar1 : rest) = (pre <> bar1) : rest
pre = mempty
<> Xml.defaultKey
<> Xml.defaultDivisions
<> Xml.metronome (1/4) 60
<> Xml.commonTime
-- |
-- Given a rest-free single-part score (such as those produced by perform), add explicit rests.
-- The result will have no empty space.
--
addRests :: [(Time, Duration, a)] -> Score a
addRests = Score . concat . snd . mapAccumL g 0
where
g prevTime (t, d, x)
| prevTime == t = (t .+^ d, [(t, d, Just x)])
| prevTime < t = (t .+^ d, [(prevTime, t .-. prevTime, Nothing), (t, d, Just x)])
| otherwise = error "addRests: Strange prevTime"
addRests' :: [(Time, Duration, a)] -> [(Time, Duration, Maybe a)]
addRests' = concat . snd . mapAccumL g 0
where
g prevTime (t, d, x)
| prevTime == t = (t .+^ d, [(t, d, Just x)])
| prevTime < t = (t .+^ d, [(prevTime, t .-. prevTime, Nothing), (t, d, Just x)])
| otherwise = error "addRests: Strange prevTime"
-- |
-- Given a set of absolute-time occurences, separate at each zero-time occurence.
-- Note that this require every bar to start with a zero-time occurence.
--
separateBars :: HasMusicXml a => Score a -> [[(Duration, Maybe a)]]
separateBars = fmap removeTime . fmap (fmap discardBarNumber) . splitAtTimeZero . fmap separateTime . getScore
where
separateTime (t,d,x) = ((bn,bt),d,x) where (bn,bt) = properFraction (toRational t)
splitAtTimeZero = splitWhile ((== 0) . getBarTime) where getBarTime ((bn,bt),_,_) = bt
discardBarNumber ((bn,bt),d,x) = (fromRational bt, d, x)
removeTime = fmap g where g (t,d,x) = (d,x)
barToXml :: HasMusicXml a => [(Duration, Maybe a)] -> Xml.Music
barToXml bar = case quantize bar of
Left e -> error $ "barToXml: Could not quantize this bar: " ++ show e
Right rh -> rhythmToXml rh
-- FIXME dotted rests does not work...
rhythmToXml :: HasMusicXml a => Rhythm (Maybe a) -> Xml.Music
rhythmToXml (Beat d x) = noteRestToXml (d, x)
rhythmToXml (Dotted n (Beat d x)) = noteRestToXml (dotMod n * d, x)
rhythmToXml (Tuplet m r) = Xml.tuplet (fromIntegral $ denominator $ getDuration $ m) (fromIntegral $ numerator $ getDuration m) (rhythmToXml r)
rhythmToXml (Bound d r) = noteRestToXml (fromRational $ getDuration d, x) <> rhythmToXml r2
where
(x,r2) = toTiedRhythm r
rhythmToXml (Rhythms rs) = mconcat $ map rhythmToXml rs
toTiedRhythm :: HasMusicXml a => Rhythm (Maybe a) -> (Maybe a, Rhythm (Maybe a))
toTiedRhythm (Beat d a) = (b, Beat d c) where (b,c) = toTied a
toTiedRhythm (Dotted n a) = (b, Dotted n c) where (b,c) = toTiedRhythm a
toTiedRhythm (Tuplet m a) = (b, Tuplet m c) where (b,c) = toTiedRhythm a
toTiedRhythm (Bound d r) = error "toXml: Nested bounded rhytms"
toTiedRhythm (Rhythms []) = error "toXml: Bound empty rhythm"
toTiedRhythm (Rhythms (a:as)) = (b, Rhythms (c:as)) where (b,c) = toTiedRhythm a
noteRestToXml :: HasMusicXml a => (Duration, Maybe a) -> Xml.Music
noteRestToXml (d, Nothing) = Xml.rest d' where d' = (fromRational . toRational $ d)
noteRestToXml (d, Just p) = getMusicXml d p
-------------------------------------------------------------------------------------
-- Transformer instances (TODO move)
-------------------------------------------------------------------------------------
-- PitchT
-- instance HasMidi a => HasMidi (PitchT p a) where
-- getMidi (PitchT (_,x)) = getMidi x
-- instance HasMusicXml a => HasMusicXml (PitchT p a) where
-- getMusicXml d (PitchT (_,x)) = getMusicXml d x
-- instance (IsPitch a, IsString n) => IsPitch (PitchT p a) where
-- fromPitch l = PitchT ("", fromPitch l)
-- instance (IsDynamics a, IsString n) => IsDynamics (PitchT p a) where
-- fromDynamics l = PitchT ("", fromDynamics l)
-- instance HasDynamic a => HasDynamic (PitchT p a) where
-- setBeginCresc n (PitchT (v,x)) = PitchT (v, setBeginCresc n x)
-- setEndCresc n (PitchT (v,x)) = PitchT (v, setEndCresc n x)
-- setBeginDim n (PitchT (v,x)) = PitchT (v, setBeginDim n x)
-- setEndDim n (PitchT (v,x)) = PitchT (v, setEndDim n x)
-- setLevel n (PitchT (v,x)) = PitchT (v, setLevel n x)
-- instance HasArticulation a => HasArticulation (PitchT p a) where
-- setEndSlur n (PitchT (v,x)) = PitchT (v, setEndSlur n x)
-- setContSlur n (PitchT (v,x)) = PitchT (v, setContSlur n x)
-- setBeginSlur n (PitchT (v,x)) = PitchT (v, setBeginSlur n x)
-- setAccLevel n (PitchT (v,x)) = PitchT (v, setAccLevel n x)
-- setStaccLevel n (PitchT (v,x)) = PitchT (v, setStaccLevel n x)
-- instance HasTremolo a => HasTremolo (PitchT p a) where
-- setTrem n (PitchT (v,x)) = PitchT (v, setTrem n x)
--
-- VoiceT
instance HasMidi a => HasMidi (VoiceT n a) where
getMidi (VoiceT (_,x)) = getMidi x
instance HasMusicXml a => HasMusicXml (VoiceT n a) where
getMusicXml d (VoiceT (_,x)) = getMusicXml d x
instance HasVoice (VoiceT n a) where
type Voice (VoiceT n a) = n
getVoice (VoiceT (v,_)) = v
modifyVoice f (VoiceT (v,x)) = VoiceT (f v, x)
instance HasPitch a => HasPitch (VoiceT n a) where
type Pitch (VoiceT n a) = Pitch a
getPitch (VoiceT (v,a)) = getPitch a
modifyPitch f (VoiceT (v,x)) = VoiceT (v, modifyPitch f x)
-- TODO IsPitch/IsDynamic with mempty/def as default as well?
instance (IsPitch a, Enum n) => IsPitch (VoiceT n a) where
fromPitch l = VoiceT (toEnum 0, fromPitch l)
instance (IsDynamics a, Enum n) => IsDynamics (VoiceT n a) where
fromDynamics l = VoiceT (toEnum 0, fromDynamics l)
instance Tiable a => Tiable (VoiceT n a) where
toTied (VoiceT (v,a)) = (VoiceT (v,b), VoiceT (v,c)) where (b,c) = toTied a
instance HasDynamic a => HasDynamic (VoiceT n a) where
setBeginCresc n (VoiceT (v,x)) = VoiceT (v, setBeginCresc n x)
setEndCresc n (VoiceT (v,x)) = VoiceT (v, setEndCresc n x)
setBeginDim n (VoiceT (v,x)) = VoiceT (v, setBeginDim n x)
setEndDim n (VoiceT (v,x)) = VoiceT (v, setEndDim n x)
setLevel n (VoiceT (v,x)) = VoiceT (v, setLevel n x)
instance HasArticulation a => HasArticulation (VoiceT n a) where
setEndSlur n (VoiceT (v,x)) = VoiceT (v, setEndSlur n x)
setContSlur n (VoiceT (v,x)) = VoiceT (v, setContSlur n x)
setBeginSlur n (VoiceT (v,x)) = VoiceT (v, setBeginSlur n x)
setAccLevel n (VoiceT (v,x)) = VoiceT (v, setAccLevel n x)
setStaccLevel n (VoiceT (v,x)) = VoiceT (v, setStaccLevel n x)
instance HasTremolo a => HasTremolo (VoiceT n a) where
setTrem n (VoiceT (v,x)) = VoiceT (v, setTrem n x)
instance HasHarmonic a => HasHarmonic (VoiceT n a) where
setHarmonic n (VoiceT (v,x)) = VoiceT (v, setHarmonic n x)
instance HasSlide a => HasSlide (VoiceT n a) where
setBeginGliss n (VoiceT (v,x)) = VoiceT (v, setBeginGliss n x)
setBeginSlide n (VoiceT (v,x)) = VoiceT (v, setBeginSlide n x)
setEndGliss n (VoiceT (v,x)) = VoiceT (v, setEndGliss n x)
setEndSlide n (VoiceT (v,x)) = VoiceT (v, setEndSlide n x)
instance HasText a => HasText (VoiceT n a) where
addText s (VoiceT (v,x)) = VoiceT (v, addText s x)
-- TieT
instance HasMidi a => HasMidi (TieT a) where
getMidi (TieT (_,x,_)) = getMidi x
instance HasMusicXml a => HasMusicXml (TieT a) where
getMusicXml d (TieT (ta,x,tb)) = addTies $ getMusicXml d x
where
addTies | ta && tb = Xml.endTie . Xml.beginTie
| tb = Xml.beginTie
| ta = Xml.endTie
| otherwise = id
instance HasVoice a => HasVoice (TieT a) where
type Voice (TieT a) = Voice a
getVoice (TieT (_,x,_)) = getVoice x
modifyVoice f (TieT (b,x,e)) = TieT (b,modifyVoice f x,e)
instance HasPitch a => HasPitch (TieT a) where
type Pitch (TieT a) = Pitch a
getPitch (TieT (_,x,_)) = getPitch x
modifyPitch f (TieT (b,x,e)) = TieT (b,modifyPitch f x,e)
instance IsPitch a => IsPitch (TieT a) where
fromPitch l = TieT (False, fromPitch l, False)
instance IsDynamics a => IsDynamics (TieT a) where
fromDynamics l = TieT (False, fromDynamics l, False)
instance HasDynamic a => HasDynamic (TieT a) where
setBeginCresc n (TieT (b,x,e)) = TieT (b,setBeginCresc n x,e)
setEndCresc n (TieT (b,x,e)) = TieT (b,setEndCresc n x,e)
setBeginDim n (TieT (b,x,e)) = TieT (b,setBeginDim n x,e)
setEndDim n (TieT (b,x,e)) = TieT (b,setEndDim n x,e)
setLevel n (TieT (b,x,e)) = TieT (b,setLevel n x,e)
instance HasArticulation a => HasArticulation (TieT a) where
setEndSlur n (TieT (b,x,e)) = TieT (b,setEndSlur n x,e)
setContSlur n (TieT (b,x,e)) = TieT (b,setContSlur n x,e)
setBeginSlur n (TieT (b,x,e)) = TieT (b,setBeginSlur n x,e)
setAccLevel n (TieT (b,x,e)) = TieT (b,setAccLevel n x,e)
setStaccLevel n (TieT (b,x,e)) = TieT (b,setStaccLevel n x,e)
instance HasTremolo a => HasTremolo (TieT a) where
setTrem n (TieT (b,x,e)) = TieT (b,setTrem n x,e)
instance HasHarmonic a => HasHarmonic (TieT a) where
setHarmonic n (TieT (b,x,e)) = TieT (b,setHarmonic n x,e)
instance HasSlide a => HasSlide (TieT a) where
setBeginGliss n (TieT (b,x,e)) = TieT (b,setBeginGliss n x,e)
setBeginSlide n (TieT (b,x,e)) = TieT (b,setBeginSlide n x,e)
setEndGliss n (TieT (b,x,e)) = TieT (b,setEndGliss n x,e)
setEndSlide n (TieT (b,x,e)) = TieT (b,setEndSlide n x,e)
instance HasText a => HasText (TieT a) where
addText s (TieT (b,x,e)) = TieT (b, addText s x, e)
-- DynamicT
-- end cresc/dim, level, begin cresc/dim
-- newtype DynamicT a = DynamicT { getDynamicT :: (Bool, Bool, Maybe Double, a, Bool, Bool) }
instance HasMidi a => HasMidi (DynamicT a) where
getMidi (DynamicT (ec,ed,l,a,bc,bd)) = getMidi a
instance HasMusicXml a => HasMusicXml (DynamicT a) where
getMusicXml d (DynamicT (ec,ed,l,a,bc,bd)) = notate $ getMusicXml d a
where
notate x = nec <> ned <> nl <> nbc <> nbd <> x
nec = if ec then Xml.endCresc else mempty
ned = if ed then Xml.endDim else mempty
nbc = if bc then Xml.beginCresc else mempty
nbd = if bd then Xml.beginDim else mempty
nl = case l of
Nothing -> mempty
Just lvl -> Xml.dynamic (fromDynamics (DynamicsL (Just lvl, Nothing)))
instance Tiable a => Tiable (DynamicT a) where
toTied (DynamicT (ec,ed,l,a,bc,bd)) = (DynamicT (ec,ed,l,b,bc,bd),
DynamicT (False,False,Nothing,c,False,False)) where (b,c) = toTied a
instance HasVoice a => HasVoice (DynamicT a) where
type Voice (DynamicT a) = Voice a
getVoice (DynamicT (ec,ed,l,a,bc,bd)) = getVoice a
modifyVoice f (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,modifyVoice f a,bc,bd)
instance HasPitch a => HasPitch (DynamicT a) where
type Pitch (DynamicT a) = Pitch a
getPitch (DynamicT (ec,ed,l,a,bc,bd)) = getPitch a
modifyPitch f (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,modifyPitch f a,bc,bd)
instance IsPitch a => IsPitch (DynamicT a) where
fromPitch l = DynamicT (False,False,Nothing,fromPitch l,False,False)
instance IsDynamics a => IsDynamics (DynamicT a) where
fromDynamics l = DynamicT (False,False,Nothing,fromDynamics l,False,False)
instance HasDynamic (DynamicT a) where
setBeginCresc bc (DynamicT (ec,ed,l,a,_ ,bd)) = DynamicT (ec,ed,l,a,bc,bd)
setEndCresc ec (DynamicT (_ ,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,a,bc,bd)
setBeginDim bd (DynamicT (ec,ed,l,a,bc,_ )) = DynamicT (ec,ed,l,a,bc,bd)
setEndDim ed (DynamicT (ec,_ ,l,a,bc,bd)) = DynamicT (ec,ed,l,a,bc,bd)
setLevel l (DynamicT (ec,ed,_,a,bc,bd)) = DynamicT (ec,ed,Just l,a,bc,bd)
instance HasArticulation a => HasArticulation (DynamicT a) where
setEndSlur n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setEndSlur n a,bc,bd)
setContSlur n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setContSlur n a,bc,bd)
setBeginSlur n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setBeginSlur n a,bc,bd)
setAccLevel n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setAccLevel n a,bc,bd)
setStaccLevel n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setStaccLevel n a,bc,bd)
instance HasTremolo a => HasTremolo (DynamicT a) where
setTrem n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setTrem n a,bc,bd)
instance HasHarmonic a => HasHarmonic (DynamicT a) where
setHarmonic n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setHarmonic n a,bc,bd)
instance HasSlide a => HasSlide (DynamicT a) where
setBeginGliss n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setBeginGliss n a,bc,bd)
setBeginSlide n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setBeginSlide n a,bc,bd)
setEndGliss n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setEndGliss n a,bc,bd)
setEndSlide n (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,setEndSlide n a,bc,bd)
instance HasText a => HasText (DynamicT a) where
addText s (DynamicT (ec,ed,l,a,bc,bd)) = DynamicT (ec,ed,l,addText s a,bc,bd)
-- ArticulationT
-- end slur, cont slur, acc level, stacc level, begin slur
-- newtype ArticulationT a = ArticulationT { getArticulationT :: (Bool, Bool, Int, Int, a, Bool) }
instance HasMidi a => HasMidi (ArticulationT a) where
getMidi (ArticulationT (es,us,al,sl,a,bs)) = getMidi a
instance HasMusicXml a => HasMusicXml (ArticulationT a) where
getMusicXml d (ArticulationT (es,us,al,sl,a,bs)) = notate $ getMusicXml d a
where
notate = nes . nal . nsl . nbs
nes = if es then Xml.endSlur else id
nal = case al of
0 -> id
1 -> Xml.accent
2 -> Xml.strongAccent
nsl = case sl of
(-2) -> Xml.tenuto
(-1) -> Xml.tenuto . Xml.staccato
0 -> id
1 -> Xml.staccato
2 -> Xml.staccatissimo
nbs = if bs then Xml.beginSlur else id
instance Tiable a => Tiable (ArticulationT a) where
toTied (ArticulationT (es,us,al,sl,a,bs)) = (ArticulationT (False,us,al,sl,b,bs),
ArticulationT (es, us,0,0,c,False)) where (b,c) = toTied a
instance HasVoice a => HasVoice (ArticulationT a) where
type Voice (ArticulationT a) = Voice a
getVoice (ArticulationT (es,us,al,sl,a,bs)) = getVoice a
modifyVoice f (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,modifyVoice f a,bs)
instance HasPitch a => HasPitch (ArticulationT a) where
type Pitch (ArticulationT a) = Pitch a
getPitch (ArticulationT (es,us,al,sl,a,bs)) = getPitch a
modifyPitch f (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,modifyPitch f a,bs)
instance IsPitch a => IsPitch (ArticulationT a) where
fromPitch l = ArticulationT (False,False,0,0,fromPitch l,False)
instance IsDynamics a => IsDynamics (ArticulationT a) where
fromDynamics l = ArticulationT (False,False,0,0,fromDynamics l,False)
instance HasDynamic a => HasDynamic (ArticulationT a) where
setBeginCresc n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setBeginCresc n a,bs)
setEndCresc n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setEndCresc n a,bs)
setBeginDim n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setBeginDim n a,bs)
setEndDim n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setEndDim n a,bs)
setLevel n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setLevel n a,bs)
instance HasArticulation (ArticulationT a) where
setEndSlur es (ArticulationT (_ ,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,a,bs)
setContSlur us (ArticulationT (es,_ ,al,sl,a,bs)) = ArticulationT (es,us,al,sl,a,bs)
setBeginSlur bs (ArticulationT (es,us,al,sl,a,_ )) = ArticulationT (es,us,al,sl,a,bs)
setAccLevel al (ArticulationT (es,us,_ ,sl,a,bs)) = ArticulationT (es,us,al,sl,a,bs)
setStaccLevel sl (ArticulationT (es,us,al,_ ,a,bs)) = ArticulationT (es,us,al,sl,a,bs)
instance HasTremolo a => HasTremolo (ArticulationT a) where
setTrem n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setTrem n a,bs)
instance HasHarmonic a => HasHarmonic (ArticulationT a) where
setHarmonic n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setHarmonic n a,bs)
instance HasSlide a => HasSlide (ArticulationT a) where
setBeginGliss n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setBeginGliss n a,bs)
setBeginSlide n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setBeginSlide n a,bs)
setEndGliss n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setEndGliss n a,bs)
setEndSlide n (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,setEndSlide n a,bs)
instance HasText a => HasText (ArticulationT a) where
addText s (ArticulationT (es,us,al,sl,a,bs)) = ArticulationT (es,us,al,sl,addText s a,bs)
-- TremoloT
-- newtype TremoloT a = TremoloT { getTremoloT :: (Int, a) }
instance HasMidi a => HasMidi (TremoloT a) where
getMidi (TremoloT (_,x)) = getMidi x
instance HasMusicXml a => HasMusicXml (TremoloT a) where
getMusicXml d (TremoloT (n,x)) = notate $ getMusicXml d x
where
notate = Xml.tremolo n
instance Tiable a => Tiable (TremoloT a) where
toTied (TremoloT (n,a)) = (TremoloT (n,b), TremoloT (n,c)) where (b,c) = toTied a
instance HasVoice a => HasVoice (TremoloT a) where
type Voice (TremoloT a) = Voice a
getVoice (TremoloT (_,a)) = getVoice a
modifyVoice f (TremoloT (n,x)) = TremoloT (n, modifyVoice f x)
instance HasPitch a => HasPitch (TremoloT a) where
type Pitch (TremoloT a) = Pitch a
getPitch (TremoloT (_,a)) = getPitch a
modifyPitch f (TremoloT (n,x)) = TremoloT (n, modifyPitch f x)
instance IsPitch a => IsPitch (TremoloT a) where
fromPitch l = TremoloT (0, fromPitch l)
instance IsDynamics a => IsDynamics (TremoloT a) where
fromDynamics l = TremoloT (0, fromDynamics l)
instance HasDynamic a => HasDynamic (TremoloT a) where
setBeginCresc n (TremoloT (v,x)) = TremoloT (v, setBeginCresc n x)
setEndCresc n (TremoloT (v,x)) = TremoloT (v, setEndCresc n x)
setBeginDim n (TremoloT (v,x)) = TremoloT (v, setBeginDim n x)
setEndDim n (TremoloT (v,x)) = TremoloT (v, setEndDim n x)
setLevel n (TremoloT (v,x)) = TremoloT (v, setLevel n x)
instance HasArticulation a => HasArticulation (TremoloT a) where
setEndSlur n (TremoloT (v,x)) = TremoloT (v, setEndSlur n x)
setContSlur n (TremoloT (v,x)) = TremoloT (v, setContSlur n x)
setBeginSlur n (TremoloT (v,x)) = TremoloT (v, setBeginSlur n x)
setAccLevel n (TremoloT (v,x)) = TremoloT (v, setAccLevel n x)
setStaccLevel n (TremoloT (v,x)) = TremoloT (v, setStaccLevel n x)
instance HasTremolo (TremoloT a) where
setTrem n (TremoloT (_,x)) = TremoloT (n,x)
instance HasHarmonic a => HasHarmonic (TremoloT a) where
setHarmonic n (TremoloT (v,x)) = TremoloT (v, setHarmonic n x)
instance HasSlide a => HasSlide (TremoloT a) where
setBeginGliss n (TremoloT (v,x)) = TremoloT (v, setBeginGliss n x)
setBeginSlide n (TremoloT (v,x)) = TremoloT (v, setBeginSlide n x)
setEndGliss n (TremoloT (v,x)) = TremoloT (v, setEndGliss n x)
setEndSlide n (TremoloT (v,x)) = TremoloT (v, setEndSlide n x)
instance HasText a => HasText (TremoloT a) where
addText s (TremoloT (n,x)) = TremoloT (n,addText s x)
-- TextT
-- newtype TextT a = TextT { getTextT :: (Int, a) }
instance HasMidi a => HasMidi (TextT a) where
getMidi (TextT (_,x)) = getMidi x
instance HasMusicXml a => HasMusicXml (TextT a) where
getMusicXml d (TextT (s,x)) = notate s $ getMusicXml d x
where
notate ts a = (mconcat $ fmap Xml.text ts) <> a
instance Tiable a => Tiable (TextT a) where
toTied (TextT (n,a)) = (TextT (n,b), TextT (mempty,c)) where (b,c) = toTied a
instance HasVoice a => HasVoice (TextT a) where
type Voice (TextT a) = Voice a
getVoice (TextT (_,a)) = getVoice a
modifyVoice f (TextT (n,x)) = TextT (n, modifyVoice f x)
instance HasPitch a => HasPitch (TextT a) where
type Pitch (TextT a) = Pitch a
getPitch (TextT (_,a)) = getPitch a
modifyPitch f (TextT (n,x)) = TextT (n, modifyPitch f x)
instance IsPitch a => IsPitch (TextT a) where
fromPitch l = TextT (mempty, fromPitch l)
instance IsDynamics a => IsDynamics (TextT a) where
fromDynamics l = TextT (mempty, fromDynamics l)
instance HasDynamic a => HasDynamic (TextT a) where
setBeginCresc n (TextT (v,x)) = TextT (v, setBeginCresc n x)
setEndCresc n (TextT (v,x)) = TextT (v, setEndCresc n x)
setBeginDim n (TextT (v,x)) = TextT (v, setBeginDim n x)
setEndDim n (TextT (v,x)) = TextT (v, setEndDim n x)
setLevel n (TextT (v,x)) = TextT (v, setLevel n x)
instance HasArticulation a => HasArticulation (TextT a) where
setEndSlur n (TextT (v,x)) = TextT (v, setEndSlur n x)
setContSlur n (TextT (v,x)) = TextT (v, setContSlur n x)
setBeginSlur n (TextT (v,x)) = TextT (v, setBeginSlur n x)
setAccLevel n (TextT (v,x)) = TextT (v, setAccLevel n x)
setStaccLevel n (TextT (v,x)) = TextT (v, setStaccLevel n x)
instance HasTremolo a => HasTremolo (TextT a) where
setTrem n (TextT (s,x)) = TextT (s,setTrem n x)
instance HasHarmonic a => HasHarmonic (TextT a) where
setHarmonic n (TextT (v,x)) = TextT (v, setHarmonic n x)
instance HasSlide a => HasSlide (TextT a) where
setBeginGliss n (TextT (v,x)) = TextT (v, setBeginGliss n x)
setBeginSlide n (TextT (v,x)) = TextT (v, setBeginSlide n x)
setEndGliss n (TextT (v,x)) = TextT (v, setEndGliss n x)
setEndSlide n (TextT (v,x)) = TextT (v, setEndSlide n x)
instance HasText (TextT a) where
addText s (TextT (t,x)) = TextT (t ++ [s],x)
-- HarmonicT
instance HasMidi a => HasMidi (HarmonicT a) where
getMidi (HarmonicT (_,x)) = getMidi x
instance HasMusicXml a => HasMusicXml (HarmonicT a) where
getMusicXml d (HarmonicT (n,x)) = notate $ getMusicXml d x
where
notate | n /= 0 = Xml.setNoteHead Xml.DiamondNoteHead
| otherwise = id
-- TODO adjust pitch etc
instance Tiable a => Tiable (HarmonicT a) where
toTied (HarmonicT (n,a)) = (HarmonicT (n,b), HarmonicT (n,c)) where (b,c) = toTied a
instance HasVoice a => HasVoice (HarmonicT a) where
type Voice (HarmonicT a) = Voice a
getVoice (HarmonicT (_,a)) = getVoice a
modifyVoice f (HarmonicT (n,x)) = HarmonicT (n, modifyVoice f x)
instance HasPitch a => HasPitch (HarmonicT a) where
type Pitch (HarmonicT a) = Pitch a
getPitch (HarmonicT (_,a)) = getPitch a
modifyPitch f (HarmonicT (n,x)) = HarmonicT (n, modifyPitch f x)
instance IsPitch a => IsPitch (HarmonicT a) where
fromPitch l = HarmonicT (0, fromPitch l)
instance IsDynamics a => IsDynamics (HarmonicT a) where
fromDynamics l = HarmonicT (0, fromDynamics l)
instance HasDynamic a => HasDynamic (HarmonicT a) where
setBeginCresc n (HarmonicT (v,x)) = HarmonicT (v, setBeginCresc n x)
setEndCresc n (HarmonicT (v,x)) = HarmonicT (v, setEndCresc n x)
setBeginDim n (HarmonicT (v,x)) = HarmonicT (v, setBeginDim n x)
setEndDim n (HarmonicT (v,x)) = HarmonicT (v, setEndDim n x)
setLevel n (HarmonicT (v,x)) = HarmonicT (v, setLevel n x)
instance HasArticulation a => HasArticulation (HarmonicT a) where
setEndSlur n (HarmonicT (v,x)) = HarmonicT (v, setEndSlur n x)
setContSlur n (HarmonicT (v,x)) = HarmonicT (v, setContSlur n x)
setBeginSlur n (HarmonicT (v,x)) = HarmonicT (v, setBeginSlur n x)
setAccLevel n (HarmonicT (v,x)) = HarmonicT (v, setAccLevel n x)
setStaccLevel n (HarmonicT (v,x)) = HarmonicT (v, setStaccLevel n x)
instance HasTremolo a => HasTremolo (HarmonicT a) where
setTrem n (HarmonicT (s,x)) = HarmonicT (s,setTrem n x)
instance HasHarmonic (HarmonicT a) where
setHarmonic n (HarmonicT (_,x)) = HarmonicT (n,x)
instance HasSlide a => HasSlide (HarmonicT a) where
setBeginGliss n (HarmonicT (s,x)) = HarmonicT (s,setBeginGliss n x)
setBeginSlide n (HarmonicT (s,x)) = HarmonicT (s,setBeginSlide n x)
setEndGliss n (HarmonicT (s,x)) = HarmonicT (s,setEndGliss n x)
setEndSlide n (HarmonicT (s,x)) = HarmonicT (s,setEndSlide n x)
instance HasText a => HasText (HarmonicT a) where
addText s (HarmonicT (n,x)) = HarmonicT (n,addText s x)
-- SlideT
instance HasMidi a => HasMidi (SlideT a) where
getMidi (SlideT (_,_,a,_,_)) = getMidi a
instance HasMusicXml a => HasMusicXml (SlideT a) where
getMusicXml d (SlideT (eg,es,a,bg,bs)) = notate $ getMusicXml d a
where
notate = neg . nes . nbg . nbs
neg = if es then Xml.endGliss else id
nes = if es then Xml.endSlide else id
nbg = if es then Xml.beginGliss else id
nbs = if es then Xml.beginSlide else id
instance Tiable a => Tiable (SlideT a) where
toTied (SlideT (eg,es,a,bg,bs)) = (SlideT (eg, es, b,False,False),
SlideT (False,False,c,bg, bs)) where (b,c) = toTied a
instance HasVoice a => HasVoice (SlideT a) where
type Voice (SlideT a) = Voice a
getVoice (SlideT (eg,es,a,bg,bs)) = getVoice a
modifyVoice f (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,modifyVoice f a,bg,bs)
instance HasPitch a => HasPitch (SlideT a) where
type Pitch (SlideT a) = Pitch a
getPitch (SlideT (eg,es,a,bg,bs)) = getPitch a
modifyPitch f (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,modifyPitch f a,bg,bs)
instance IsPitch a => IsPitch (SlideT a) where
fromPitch l = SlideT (False,False,fromPitch l,False,False)
instance IsDynamics a => IsDynamics (SlideT a) where
fromDynamics l = SlideT (False,False,fromDynamics l,False,False)
instance HasDynamic a => HasDynamic (SlideT a) where
setBeginCresc n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setBeginCresc n a,bg,bs)
setEndCresc n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setEndCresc n a,bg,bs)
setBeginDim n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setBeginDim n a,bg,bs)
setEndDim n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setEndDim n a,bg,bs)
setLevel n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setLevel n a,bg,bs)
instance HasArticulation a => HasArticulation (SlideT a) where
setEndSlur n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setEndSlur n a,bg,bs)
setContSlur n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setContSlur n a,bg,bs)
setBeginSlur n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setBeginSlur n a,bg,bs)
setAccLevel n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setAccLevel n a,bg,bs)
setStaccLevel n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setStaccLevel n a,bg,bs)
instance HasTremolo a => HasTremolo (SlideT a) where
setTrem n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setTrem n a,bg,bs)
instance HasHarmonic a => HasHarmonic (SlideT a) where
setHarmonic n (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,setHarmonic n a,bg,bs)
instance HasSlide (SlideT a) where
setBeginGliss bg (SlideT (eg,es,a,_,bs)) = SlideT (eg,es,a,bg,bs)
setBeginSlide bs (SlideT (eg,es,a,bg,_)) = SlideT (eg,es,a,bg,bs)
setEndGliss eg (SlideT (_,es,a,bg,bs)) = SlideT (eg,es,a,bg,bs)
setEndSlide es (SlideT (eg,_,a,bg,bs)) = SlideT (eg,es,a,bg,bs)
instance HasText a => HasText (SlideT a) where
addText s (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,addText s a,bg,bs)
-------------------------------------------------------------------------------------
-- Num, Integral, Enum and Bounded
-------------------------------------------------------------------------------------
-- VoiceT
instance (Enum v, Eq v, Num a) => Num (VoiceT v a) where
VoiceT (v,a) + VoiceT (_,b) = VoiceT (v,a+b)
VoiceT (v,a) * VoiceT (_,b) = VoiceT (v,a*b)
VoiceT (v,a) - VoiceT (_,b) = VoiceT (v,a-b)
abs (VoiceT (v,a)) = VoiceT (v,abs a)
signum (VoiceT (v,a)) = VoiceT (v,signum a)
fromInteger a = VoiceT (toEnum 0,fromInteger a)
instance (Enum v, Enum a) => Enum (VoiceT v a) where
toEnum a = VoiceT (toEnum 0, toEnum a) -- TODO use def, mempty or minBound?
fromEnum (VoiceT (v,a)) = fromEnum a
instance (Enum v, Bounded a) => Bounded (VoiceT v a) where
minBound = VoiceT (toEnum 0, minBound)
maxBound = VoiceT (toEnum 0, maxBound)
instance (Enum v, Ord v, Num a, Ord a, Real a) => Real (VoiceT v a) where
toRational (VoiceT (v,a)) = toRational a
instance (Enum v, Ord v, Real a, Enum a, Integral a) => Integral (VoiceT v a) where
VoiceT (v,a) `quotRem` VoiceT (_,b) = (VoiceT (v,q), VoiceT (v,r)) where (q,r) = a `quotRem` b
toInteger (VoiceT (v,a)) = toInteger a
-- TieT
instance Num a => Num (TieT a) where
TieT (et,a,bt) + TieT (_,b,_) = TieT (et,a+b,bt)
TieT (et,a,bt) * TieT (_,b,_) = TieT (et,a*b,bt)
TieT (et,a,bt) - TieT (_,b,_) = TieT (et,a-b,bt)
abs (TieT (et,a,bt)) = TieT (et,abs a,bt)
signum (TieT (et,a,bt)) = TieT (et,signum a,bt)
fromInteger a = TieT (False,fromInteger a,False)
instance Enum a => Enum (TieT a) where
toEnum a = TieT (False,toEnum a,False)
fromEnum (TieT (_,a,_)) = fromEnum a
instance Bounded a => Bounded (TieT a) where
minBound = TieT (False,minBound,False)
maxBound = TieT (False,maxBound,False)
instance (Num a, Ord a, Real a) => Real (TieT a) where
toRational (TieT (_,a,_)) = toRational a
instance (Real a, Enum a, Integral a) => Integral (TieT a) where
TieT (et,a,bt) `quotRem` TieT (_,b,_) = (TieT (et,q,bt), TieT (et,r,bt)) where (q,r) = a `quotRem` b
toInteger (TieT (_,a,_)) = toInteger a
-- DynamicT
instance Num a => Num (DynamicT a) where
DynamicT (p,q,r,a,s,t) + DynamicT (_,_,_,b,_,_) = DynamicT (p,q,r,a+b,s,t)
DynamicT (p,q,r,a,s,t) * DynamicT (_,_,_,b,_,_) = DynamicT (p,q,r,a*b,s,t)
DynamicT (p,q,r,a,s,t) - DynamicT (_,_,_,b,_,_) = DynamicT (p,q,r,a-b,s,t)
abs (DynamicT (p,q,r,a,s,t)) = DynamicT (p,q,r,abs a,s,t)
signum (DynamicT (p,q,r,a,s,t)) = DynamicT (p,q,r,signum a,s,t)
fromInteger a = DynamicT (False,False,Nothing,fromInteger a,False,False)
instance Enum a => Enum (DynamicT a) where
toEnum a = DynamicT (False,False,Nothing,toEnum a,False,False)
fromEnum (DynamicT (_,_,_,a,_,_)) = fromEnum a
instance Bounded a => Bounded (DynamicT a) where
minBound = DynamicT (False,False,Nothing,minBound,False,False)
maxBound = DynamicT (False,False,Nothing,maxBound,False,False)
instance (Num a, Ord a, Real a) => Real (DynamicT a) where
toRational (DynamicT (_,_,_,a,_,_)) = toRational a
instance (Real a, Enum a, Integral a) => Integral (DynamicT a) where
DynamicT (p,q,r,a,s,t) `quotRem` DynamicT (_,_,_,b,_,_) = (DynamicT (p,q,r,q',s,t), DynamicT (p,q,r,r',s,t)) where (q',r') = a `quotRem` b
toInteger (DynamicT (_,_,_,a,_,_)) = toInteger a
-- ArticulationT
instance Num a => Num (ArticulationT a) where
ArticulationT (p,q,r,s,a,t) + ArticulationT (_,_,_,_,b,_) = ArticulationT (p,q,r,s,a+b,t)
ArticulationT (p,q,r,s,a,t) * ArticulationT (_,_,_,_,b,_) = ArticulationT (p,q,r,s,a*b,t)
ArticulationT (p,q,r,s,a,t) - ArticulationT (_,_,_,_,b,_) = ArticulationT (p,q,r,s,a-b,t)
abs (ArticulationT (p,q,r,s,a,t)) = ArticulationT (p,q,r,s,abs a,t)
signum (ArticulationT (p,q,r,s,a,t)) = ArticulationT (p,q,r,s,signum a,t)
fromInteger a = ArticulationT (False,False,0,0,fromInteger a,False)
instance Enum a => Enum (ArticulationT a) where
toEnum a = ArticulationT (False,False,0,0,toEnum a,False)
fromEnum (ArticulationT (_,_,_,_,a,_)) = fromEnum a
instance Bounded a => Bounded (ArticulationT a) where
minBound = ArticulationT (False,False,0,0,minBound,False)
maxBound = ArticulationT (False,False,0,0,maxBound,False)
instance (Num a, Ord a, Real a) => Real (ArticulationT a) where
toRational (ArticulationT (_,_,_,_,a,_)) = toRational a
instance (Real a, Enum a, Integral a) => Integral (ArticulationT a) where
ArticulationT (p,q,r,s,a,t) `quotRem` ArticulationT (_,_,_,_,b,_) = (ArticulationT (p,q,r,s,q',t), ArticulationT (p,q,r,s,r',t)) where (q',r') = a `quotRem` b
toInteger (ArticulationT (_,_,_,_,a,_)) = toInteger a
-- TremoloT
instance Num a => Num (TremoloT a) where
TremoloT (v,a) + TremoloT (_,b) = TremoloT (v,a+b)
TremoloT (v,a) * TremoloT (_,b) = TremoloT (v,a*b)
TremoloT (v,a) - TremoloT (_,b) = TremoloT (v,a-b)
abs (TremoloT (v,a)) = TremoloT (v,abs a)
signum (TremoloT (v,a)) = TremoloT (v,signum a)
fromInteger a = TremoloT (toEnum 0,fromInteger a)
instance Enum a => Enum (TremoloT a) where
toEnum a = TremoloT (0, toEnum a) -- TODO use def, mempty or minBound?
fromEnum (TremoloT (v,a)) = fromEnum a
instance Bounded a => Bounded (TremoloT a) where
minBound = TremoloT (0, minBound)
maxBound = TremoloT (0, maxBound)
instance (Num a, Real a) => Real (TremoloT a) where
toRational (TremoloT (_,a)) = toRational a
instance (Real a, Enum a, Integral a) => Integral (TremoloT a) where
TremoloT (v,a) `quotRem` TremoloT (_,b) = (TremoloT (v,q), TremoloT (v,r)) where (q,r) = a `quotRem` b
toInteger (TremoloT (_,a)) = toInteger a
-- TextT
instance Num a => Num (TextT a) where
TextT (v,a) + TextT (_,b) = TextT (v,a+b)
TextT (v,a) * TextT (_,b) = TextT (v,a*b)
TextT (v,a) - TextT (_,b) = TextT (v,a-b)
abs (TextT (v,a)) = TextT (v,abs a)
signum (TextT (v,a)) = TextT (v,signum a)
fromInteger a = TextT (mempty,fromInteger a)
instance Enum a => Enum (TextT a) where
toEnum a = TextT (mempty, toEnum a) -- TODO use def, mempty or minBound?
fromEnum (TextT (v,a)) = fromEnum a
instance Bounded a => Bounded (TextT a) where
minBound = TextT (mempty, minBound)
maxBound = TextT (mempty, maxBound)
instance (Num a, Ord a, Real a) => Real (TextT a) where
toRational (TextT (v,a)) = toRational a
instance (Real a, Enum a, Integral a) => Integral (TextT a) where
TextT (v,a) `quotRem` TextT (_,b) = (TextT (v,q), TextT (v,r)) where (q,r) = a `quotRem` b
toInteger (TextT (v,a)) = toInteger a
-- HarmonicT
instance Num a => Num (HarmonicT a) where
HarmonicT (v,a) + HarmonicT (_,b) = HarmonicT (v,a+b)
HarmonicT (v,a) * HarmonicT (_,b) = HarmonicT (v,a*b)
HarmonicT (v,a) - HarmonicT (_,b) = HarmonicT (v,a-b)
abs (HarmonicT (v,a)) = HarmonicT (v,abs a)
signum (HarmonicT (v,a)) = HarmonicT (v,signum a)
fromInteger a = HarmonicT (toEnum 0,fromInteger a)
instance Enum a => Enum (HarmonicT a) where
toEnum a = HarmonicT (0, toEnum a) -- TODO use def, mempty or minBound?
fromEnum (HarmonicT (v,a)) = fromEnum a
instance Bounded a => Bounded (HarmonicT a) where
minBound = HarmonicT (0, minBound)
maxBound = HarmonicT (0, maxBound)
instance (Num a, Ord a, Real a) => Real (HarmonicT a) where
toRational (HarmonicT (v,a)) = toRational a
instance (Real a, Enum a, Integral a) => Integral (HarmonicT a) where
HarmonicT (v,a) `quotRem` HarmonicT (_,b) = (HarmonicT (v,q), HarmonicT (v,r)) where (q,r) = a `quotRem` b
toInteger (HarmonicT (v,a)) = toInteger a
-- SlideT
instance Num a => Num (SlideT a) where
SlideT (eg,es,a,bg,bs) + SlideT (_,_,b,_,_) = SlideT (eg,es,a+b,bg,bs)
SlideT (eg,es,a,bg,bs) * SlideT (_,_,b,_,_) = SlideT (eg,es,a*b,bg,bs)
SlideT (eg,es,a,bg,bs) - SlideT (_,_,b,_,_) = SlideT (eg,es,a-b,bg,bs)
abs (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,abs a,bg,bs)
signum (SlideT (eg,es,a,bg,bs)) = SlideT (eg,es,signum a,bg,bs)
fromInteger a = SlideT (False,False,fromInteger a,False,False)
instance Enum a => Enum (SlideT a) where
toEnum a = SlideT (False,False,toEnum a,False,False)
fromEnum (SlideT (_,_,a,_,_)) = fromEnum a
instance Bounded a => Bounded (SlideT a) where
minBound = SlideT (False,False,minBound,False,False)
maxBound = SlideT (False,False,maxBound,False,False)
instance (Num a, Ord a, Real a) => Real (SlideT a) where
toRational (SlideT (_,_,a,_,_)) = toRational a
instance (Real a, Enum a, Integral a) => Integral (SlideT a) where
SlideT (eg,es,a,bg,bs) `quotRem` SlideT (_,_,b,_,_) = (SlideT (eg,es,q',bg,bs), SlideT (eg,es,r',bg,bs)) where (q',r') = a `quotRem` b
toInteger (SlideT (_,_,a,_,_)) = toInteger a
-------------------------------------------------------------------------------------
-- Literals
-------------------------------------------------------------------------------------
instance IsPitch Double where
fromPitch (PitchL (pc, sem, oct)) = fromIntegral $ semitones sem + diatonic pc + (oct+1) * 12
where
semitones = maybe 0 round
diatonic pc = case pc of
0 -> 0
1 -> 2
2 -> 4
3 -> 5
4 -> 7
5 -> 9
6 -> 11
instance IsPitch Integer where
fromPitch (PitchL (pc, sem, oct)) = fromIntegral $ semitones sem + diatonic pc + (oct+1) * 12
where
semitones = maybe 0 round
diatonic pc = case pc of
0 -> 0
1 -> 2
2 -> 4
3 -> 5
4 -> 7
5 -> 9
6 -> 11
instance IsDynamics Double where
fromDynamics (DynamicsL (Just x, _)) = x
fromDynamics (DynamicsL (Nothing, _)) = error "IsDynamics Double: No dynamics"
data Alteration = Sh | Fl
sharp = Sh
flat = Fl
instance IsPitch (Alteration -> Double) where
fromPitch l Sh = fromPitch l + 1
fromPitch l Fl = fromPitch l - 1
instance IsPitch (Alteration -> Integer) where
fromPitch l Sh = fromPitch l + 1
fromPitch l Fl = fromPitch l - 1
instance IsPitch (Alteration -> a) => IsPitch (Alteration -> Score a) where
fromPitch l a = (pure . fromPitch l) a
-------------------------------------------------------------------------------------
-- Test stuff
-------------------------------------------------------------------------------------
type Fun a = a -> a
type Sc a = Score (VoiceT Int (TieT (TremoloT (DynamicT (ArticulationT a)))))
score :: Fun (Sc Double)
score = id
open = openXml . score
-------------------------------------------------------------------------------------
list z f [] = z
list z f xs = f xs
first f (x,y) = (f x, y)
second f (x,y) = (x, f y)
sep :: a -> [a] -> [a]
sep = List.intersperse
concatSep :: [a] -> [[a]] -> [a]
concatSep x = List.concat . sep x
-- Score filtering generalized to MonadPlus (TODO move!)
-- |
-- Generalizes the 'remove' function.
--
mremove :: MonadPlus m => (a -> Bool) -> m a -> m a
mremove p = mfilter (not . p)
-- |
-- Generalizes the 'partition' function.
--
mpartition :: MonadPlus m => (a -> Bool) -> m a -> (m a, m a)
mpartition p a = (mfilter p a, mremove p a)
-- |
-- Pass through @Just@ occurrences.
-- Generalizes the 'catMaybes' function.
--
mcatMaybes :: MonadPlus m => m (Maybe a) -> m a
mcatMaybes = (>>= maybe mzero return)
-- |
-- Modify or discard a value.
-- Generalizes the 'mapMaybe' function.
--
mmapMaybe :: MonadPlus m => (a -> Maybe b) -> m a -> m b
mmapMaybe f = mcatMaybes . liftM f
-- |
-- Group a list into sublists whereever a predicate holds. The matched element
-- is the first in the sublist.
--
-- > splitWhile isSpace "foo bar baz"
-- > ===> ["foo"," bar"," baz"]
-- >
-- > splitWhile (> 3) [1,5,4,7,0,1,2]
-- > ===> [[1],[5],[4],[7,0,1,2]]
--
splitWhile :: (a -> Bool) -> [a] -> [[a]]
splitWhile p xs = case splitWhile' p xs of
[]:xss -> xss
xss -> xss
where
splitWhile' p [] = [[]]
splitWhile' p (x:xs) = case splitWhile' p xs of
(xs:xss) -> if p x then []:(x:xs):xss else (x:xs):xss
execute :: FilePath -> [String] -> IO ()
execute program args = do
forkProcess $ executeFile program True args Nothing
return ()
single x = [x]
fmap2 = fmap . fmap
fmap3 = fmap . fmap . fmap
dump = mapM putStrLn . fmap show
left f (Left x) = Left (f x)
left f (Right y) = Right y
mergeBy :: (a -> a -> Ordering) -> [a] -> [a] -> [a]
mergeBy f as bs = List.sortBy f $ as <> bs