> {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-}
> module Euterpea.Music where
> infixr 5 :+:, :=:
> type AbsPitch = Int
> type Octave = Int
> type Pitch = (PitchClass, Octave)
> type Dur = Rational
> data PitchClass = Cff | Cf | C | Dff | Cs | Df | Css | D | Eff | Ds
> | Ef | Fff | Dss | E | Ff | Es | F | Gff | Ess | Fs
> | Gf | Fss | G | Aff | Gs | Af | Gss | A | Bff | As
> | Bf | Ass | B | Bs | Bss
> deriving (Show, Eq, Ord, Read, Enum, Bounded)
> data Primitive a = Note Dur a
> | Rest Dur
> deriving (Show, Eq, Ord)
> data Music a =
> Prim (Primitive a)
> | Music a :+: Music a
> | Music a :=: Music a
> | Modify Control (Music a)
> deriving (Show, Eq, Ord)
> data Control =
> Tempo Rational
> | Transpose AbsPitch
> | Instrument InstrumentName
> | Phrase [PhraseAttribute]
> | KeySig PitchClass Mode
> | Custom String
> deriving (Show, Eq, Ord)
> data Mode = Major | Minor
> deriving (Show, Eq, Ord)
> data InstrumentName =
> AcousticGrandPiano | BrightAcousticPiano | ElectricGrandPiano
> | HonkyTonkPiano | RhodesPiano | ChorusedPiano
> | Harpsichord | Clavinet | Celesta
> | Glockenspiel | MusicBox | Vibraphone
> | Marimba | Xylophone | TubularBells
> | Dulcimer | HammondOrgan | PercussiveOrgan
> | RockOrgan | ChurchOrgan | ReedOrgan
> | Accordion | Harmonica | TangoAccordion
> | AcousticGuitarNylon | AcousticGuitarSteel | ElectricGuitarJazz
> | ElectricGuitarClean | ElectricGuitarMuted | OverdrivenGuitar
> | DistortionGuitar | GuitarHarmonics | AcousticBass
> | ElectricBassFingered | ElectricBassPicked | FretlessBass
> | SlapBass1 | SlapBass2 | SynthBass1
> | SynthBass2 | Violin | Viola
> | Cello | Contrabass | TremoloStrings
> | PizzicatoStrings | OrchestralHarp | Timpani
> | StringEnsemble1 | StringEnsemble2 | SynthStrings1
> | SynthStrings2 | ChoirAahs | VoiceOohs
> | SynthVoice | OrchestraHit | Trumpet
> | Trombone | Tuba | MutedTrumpet
> | FrenchHorn | BrassSection | SynthBrass1
> | SynthBrass2 | SopranoSax | AltoSax
> | TenorSax | BaritoneSax | Oboe
> | Bassoon | EnglishHorn | Clarinet
> | Piccolo | Flute | Recorder
> | PanFlute | BlownBottle | Shakuhachi
> | Whistle | Ocarina | Lead1Square
> | Lead2Sawtooth | Lead3Calliope | Lead4Chiff
> | Lead5Charang | Lead6Voice | Lead7Fifths
> | Lead8BassLead | Pad1NewAge | Pad2Warm
> | Pad3Polysynth | Pad4Choir | Pad5Bowed
> | Pad6Metallic | Pad7Halo | Pad8Sweep
> | FX1Train | FX2Soundtrack | FX3Crystal
> | FX4Atmosphere | FX5Brightness | FX6Goblins
> | FX7Echoes | FX8SciFi | Sitar
> | Banjo | Shamisen | Koto
> | Kalimba | Bagpipe | Fiddle
> | Shanai | TinkleBell | Agogo
> | SteelDrums | Woodblock | TaikoDrum
> | MelodicDrum | SynthDrum | ReverseCymbal
> | GuitarFretNoise | BreathNoise | Seashore
> | BirdTweet | TelephoneRing | Helicopter
> | Applause | Gunshot | Percussion
> | CustomInstrument String
> deriving (Show, Eq, Ord)
> data PhraseAttribute = Dyn Dynamic
> | Tmp Tempo
> | Art Articulation
> | Orn Ornament
> deriving (Show, Eq, Ord)
> data Dynamic = Accent Rational | Crescendo Rational | Diminuendo Rational
> | StdLoudness StdLoudness | Loudness Rational
> deriving (Show, Eq, Ord)
> data StdLoudness = PPP | PP | P | MP | SF | MF | NF | FF | FFF
> deriving (Show, Eq, Ord, Enum)
> data Tempo = Ritardando Rational | Accelerando Rational
> deriving (Show, Eq, Ord)
> data Articulation = Staccato Rational | Legato Rational | Slurred Rational
> | Tenuto | Marcato | Pedal | Fermata | FermataDown | Breath
> | DownBow | UpBow | Harmonic | Pizzicato | LeftPizz
> | BartokPizz | Swell | Wedge | Thumb | Stopped
> deriving (Show, Eq, Ord)
> data Ornament = Trill | Mordent | InvMordent | DoubleMordent
> | Turn | TrilledTurn | ShortTrill
> | Arpeggio | ArpeggioUp | ArpeggioDown
> | Instruction String | Head NoteHead
> | DiatonicTrans Int
> deriving (Show, Eq, Ord)
> data NoteHead = DiamondHead | SquareHead | XHead | TriangleHead
> | TremoloHead | SlashHead | ArtHarmonic | NoHead
> deriving (Show, Eq, Ord)
> type Volume = Int
> addVolume :: Volume -> Music Pitch -> Music (Pitch,Volume)
> addVolume v = mMap (\p -> (p,v))
> data NoteAttribute =
> Volume Int
> | Fingering Integer
> | Dynamics String
> | Params [Double]
> deriving (Eq, Show)
> type Note1 = (Pitch, [NoteAttribute])
> type Music1 = Music Note1
A new type class to allow for musical polymorphism that ultimately
must be converted to Music1 to be converted to MIDI format through
the MEvent framework.
> class ToMusic1 a where
> toMusic1 :: Music a -> Music1
> instance ToMusic1 Pitch where
> toMusic1 = mMap (\p -> (p, []))
> instance ToMusic1 (Pitch, Volume) where
> toMusic1 = mMap (\(p, v) -> (p, [Volume v]))
> instance ToMusic1 (Note1) where
> toMusic1 = id
> instance ToMusic1 (AbsPitch) where
> toMusic1 = mMap (\a -> (pitch a, []))
> note :: Dur -> a -> Music a
> note d p = Prim (Note d p)
> rest :: Dur -> Music a
> rest d = Prim (Rest d)
> tempo :: Dur -> Music a -> Music a
> tempo r m = Modify (Tempo r) m
> transpose :: AbsPitch -> Music a -> Music a
> transpose i m = Modify (Transpose i) m
> instrument :: InstrumentName -> Music a -> Music a
> instrument i m = Modify (Instrument i) m
> phrase :: [PhraseAttribute] -> Music a -> Music a
> phrase pa m = Modify (Phrase pa) m
> keysig :: PitchClass -> Mode -> Music a -> Music a
> keysig pc mo m = Modify (KeySig pc mo) m
> cff,cf,c,cs,css,dff,df,d,ds,dss,eff,ef,e,es,ess,fff,ff,f,
> fs,fss,gff,gf,g,gs,gss,aff,af,a,as,ass,bff,bf,b,bs,bss ::
> Octave -> Dur -> Music Pitch
> cff o d = note d (Cff, o); cf o d = note d (Cf, o)
> c o d = note d (C, o); cs o d = note d (Cs, o)
> css o d = note d (Css, o); dff o d = note d (Dff, o)
> df o d = note d (Df, o); d o d = note d (D, o)
> ds o d = note d (Ds, o); dss o d = note d (Dss, o)
> eff o d = note d (Eff, o); ef o d = note d (Ef, o)
> e o d = note d (E, o); es o d = note d (Es, o)
> ess o d = note d (Ess, o); fff o d = note d (Fff, o)
> ff o d = note d (Ff, o); f o d = note d (F, o)
> fs o d = note d (Fs, o); fss o d = note d (Fss, o)
> gff o d = note d (Gff, o); gf o d = note d (Gf, o)
> g o d = note d (G, o); gs o d = note d (Gs, o)
> gss o d = note d (Gss, o); aff o d = note d (Aff, o)
> af o d = note d (Af, o); a o d = note d (A, o)
> as o d = note d (As, o); ass o d = note d (Ass, o)
> bff o d = note d (Bff, o); bf o d = note d (Bf, o)
> b o d = note d (B, o); bs o d = note d (Bs, o)
> bss o d = note d (Bss, o)
> bn, wn, hn, qn, en, sn, tn, sfn, dwn, dhn,
> dqn, den, dsn, dtn, ddhn, ddqn, dden :: Dur
> bnr, wnr, hnr, qnr, enr, snr, tnr, sfnr, dwnr, dhnr,
> dqnr, denr, dsnr, dtnr, ddhnr, ddqnr, ddenr :: Music Pitch
> bn = 2; bnr = rest bn
> wn = 1; wnr = rest wn
> hn = 1/2; hnr = rest hn
> qn = 1/4; qnr = rest qn
> en = 1/8; enr = rest en
> sn = 1/16; snr = rest sn
> tn = 1/32; tnr = rest tn
> sfn = 1/64; sfnr = rest sfn
> dwn = 3/2; dwnr = rest dwn
> dhn = 3/4; dhnr = rest dhn
> dqn = 3/8; dqnr = rest dqn
> den = 3/16; denr = rest den
> dsn = 3/32; dsnr = rest dsn
> dtn = 3/64; dtnr = rest dtn
> ddhn = 7/8; ddhnr = rest ddhn
> ddqn = 7/16; ddqnr = rest ddqn
> dden = 7/32; ddenr = rest dden
The conversion for Pitch and AbsPitch differs from previous versions
of Euterpea. In Euterpea 1.x, (C,5) was pitch number 60, which is not
the most common interpretation. While there is no universal standard
for which octave should be octave 0, it is far more common to have the
pitch number relationship that (C,4) = 60. Since this change has been
requested many times in previous versions of Euterpea, the following
standard is now in place as of version 2.0.0:
pitch 0 = (C,-1)
pitch 60 = (C,4)
pitch 127 = (G,9)
> absPitch :: Pitch -> AbsPitch
> absPitch (pc,oct) = 12*(oct+1) + pcToInt pc
> pcToInt :: PitchClass -> Int
> pcToInt pc = case pc of
> Cff -> -2; Cf -> -1; C -> 0; Cs -> 1; Css -> 2;
> Dff -> 0; Df -> 1; D -> 2; Ds -> 3; Dss -> 4;
> Eff -> 2; Ef -> 3; E -> 4; Es -> 5; Ess -> 6;
> Fff -> 3; Ff -> 4; F -> 5; Fs -> 6; Fss -> 7;
> Gff -> 5; Gf -> 6; G -> 7; Gs -> 8; Gss -> 9;
> Aff -> 7; Af -> 8; A -> 9; As -> 10; Ass -> 11;
> Bff -> 9; Bf -> 10; B -> 11; Bs -> 12; Bss -> 13
> pitch :: AbsPitch -> Pitch
> pitch ap =
> let (oct, n) = divMod ap 12
> in ([C,Cs,D,Ds,E,F,Fs,G,Gs,A,As,B] !! n, oct-1)
> trans :: Int -> Pitch -> Pitch
> trans i p = pitch (absPitch p + i)
> line, chord :: [Music a] -> Music a
> line = foldr (:+:) (rest 0)
> chord = foldr (:=:) (rest 0)
> line1, chord1 :: [Music a] -> Music a
> line1 = foldr1 (:+:)
> chord1 = foldr1 (:=:)
> offset :: Dur -> Music a -> Music a
> offset d m = rest d :+: m
> times :: Int -> Music a -> Music a
> times 0 m = rest 0
> times n m = m :+: times (n-1) m
> forever :: Music a -> Music a
> forever m = m :+: forever m
> lineToList :: Music a -> [Music a]
> lineToList (Prim (Rest 0)) = []
> lineToList (n :+: ns) = n : lineToList ns
> lineToList _ =
> error "lineToList: argument not created by function line"
> invertAt :: Pitch -> Music Pitch -> Music Pitch
> invertAt pRef = mMap (\p -> pitch (2 * absPitch pRef - absPitch p))
> invertAt1 :: Pitch -> Music (Pitch, a) -> Music (Pitch, a)
> invertAt1 pRef = mMap (\(p,x) -> (pitch (2 * absPitch pRef - absPitch p),x))
> invert :: Music Pitch -> Music Pitch
> invert m =
> let pRef = mFold pFun (++) (++) (flip const) m
> in if null pRef then m
> else invertAt (head pRef) m
> where pFun (Note d p) = [p]
> pFun _ = []
> invert1 :: Music (Pitch,a) -> Music (Pitch,a)
> invert1 m =
> let pRef = mFold pFun (++) (++) (flip const) m
> in if null pRef then m
> else invertAt1 (head pRef) m
> where pFun (Note d (p,x)) = [p]
> pFun _ = []
> retro :: Music a -> Music a
> retro n@(Prim _) = n
> retro (Modify c m) = Modify c (retro m)
> retro (m1 :+: m2) = retro m2 :+: retro m1
> retro (m1 :=: m2) =
> let d1 = dur m1
> d2 = dur m2
> in if d1>d2 then retro m1 :=: (rest (d1-d2) :+: retro m2)
> else (rest (d2-d1) :+: retro m1) :=: retro m2
> retroInvert, invertRetro :: Music Pitch -> Music Pitch
> retroInvert = retro . invert
> invertRetro = invert . retro
> dur :: Music a -> Dur
> dur (Prim (Note d _)) = d
> dur (Prim (Rest d)) = d
> dur (m1 :+: m2) = dur m1 + dur m2
> dur (m1 :=: m2) = dur m1 `max` dur m2
> dur (Modify (Tempo r) m) = dur m / r
> dur (Modify _ m) = dur m
> cut :: Dur -> Music a -> Music a
> cut d m | d <= 0 = rest 0
> cut d (Prim (Note oldD p)) = note (min oldD d) p
> cut d (Prim (Rest oldD)) = rest (min oldD d)
> cut d (m1 :=: m2) = cut d m1 :=: cut d m2
> cut d (m1 :+: m2) = let m'1 = cut d m1
> m'2 = cut (d - dur m'1) m2
> in m'1 :+: m'2
> cut d (Modify (Tempo r) m) = tempo r (cut (d*r) m)
> cut d (Modify c m) = Modify c (cut d m)
> remove :: Dur -> Music a -> Music a
> remove d m | d <= 0 = m
> remove d (Prim (Note oldD p)) = note (max (oldD-d) 0) p
> remove d (Prim (Rest oldD)) = rest (max (oldD-d) 0)
> remove d (m1 :=: m2) = remove d m1 :=: remove d m2
> remove d (m1 :+: m2) = let m'1 = remove d m1
> m'2 = remove (d - dur m1) m2
> in m'1 :+: m'2
> remove d (Modify (Tempo r) m) = tempo r (remove (d*r) m)
> remove d (Modify c m) = Modify c (remove d m)
> removeZeros :: Music a -> Music a
> removeZeros (Prim p) = Prim p
> removeZeros (m1 :+: m2) =
> let m'1 = removeZeros m1
> m'2 = removeZeros m2
> in case (m'1,m'2) of
> (Prim (Note 0 p), m) -> m
> (Prim (Rest 0 ), m) -> m
> (m, Prim (Note 0 p)) -> m
> (m, Prim (Rest 0 )) -> m
> (m1, m2) -> m1 :+: m2
> removeZeros (m1 :=: m2) =
> let m'1 = removeZeros m1
> m'2 = removeZeros m2
> in case (m'1,m'2) of
> (Prim (Note 0 p), m) -> m
> (Prim (Rest 0 ), m) -> m
> (m, Prim (Note 0 p)) -> m
> (m, Prim (Rest 0 )) -> m
> (m1, m2) -> m1 :=: m2
> removeZeros (Modify c m) = Modify c (removeZeros m)
> type LazyDur = [Dur]
> durL :: Music a -> LazyDur
> durL m@(Prim _) = [dur m]
> durL (m1 :+: m2) = let d1 = durL m1
> in d1 ++ map (+(last d1)) (durL m2)
> durL (m1 :=: m2) = mergeLD (durL m1) (durL m2)
> durL (Modify (Tempo r) m) = map (/r) (durL m)
> durL (Modify _ m) = durL m
> mergeLD :: LazyDur -> LazyDur -> LazyDur
> mergeLD [] ld = ld
> mergeLD ld [] = ld
> mergeLD ld1@(d1:ds1) ld2@(d2:ds2) =
> if d1<d2 then d1 : mergeLD ds1 ld2
> else d2 : mergeLD ld1 ds2
> minL :: LazyDur -> Dur -> Dur
> minL [] d' = d'
> minL [d] d' = min d d'
> minL (d:ds) d' = if d < d' then minL ds d' else d'
> cutL :: LazyDur -> Music a -> Music a
> cutL [] m = rest 0
> cutL (d:ds) m | d <= 0 = cutL ds m
> cutL ld (Prim (Note oldD p)) = note (minL ld oldD) p
> cutL ld (Prim (Rest oldD)) = rest (minL ld oldD)
> cutL ld (m1 :=: m2) = cutL ld m1 :=: cutL ld m2
> cutL ld (m1 :+: m2) =
> let m'1 = cutL ld m1
> m'2 = cutL (map (\d -> d - dur m'1) ld) m2
> in m'1 :+: m'2
> cutL ld (Modify (Tempo r) m) = tempo r (cutL (map (*r) ld) m)
> cutL ld (Modify c m) = Modify c (cutL ld m)
> (/=:) :: Music a -> Music a -> Music a
> m1 /=: m2 = cutL (durL m2) m1 :=: cutL (durL m1) m2
> data PercussionSound =
> AcousticBassDrum
> | BassDrum1
> | SideStick
> | AcousticSnare | HandClap | ElectricSnare | LowFloorTom
> | ClosedHiHat | HighFloorTom | PedalHiHat | LowTom
> | OpenHiHat | LowMidTom | HiMidTom | CrashCymbal1
> | HighTom | RideCymbal1 | ChineseCymbal | RideBell
> | Tambourine | SplashCymbal | Cowbell | CrashCymbal2
> | Vibraslap | RideCymbal2 | HiBongo | LowBongo
> | MuteHiConga | OpenHiConga | LowConga | HighTimbale
> | LowTimbale | HighAgogo | LowAgogo | Cabasa
> | Maracas | ShortWhistle | LongWhistle | ShortGuiro
> | LongGuiro | Claves | HiWoodBlock | LowWoodBlock
> | MuteCuica | OpenCuica | MuteTriangle
> | OpenTriangle
> deriving (Show,Eq,Ord,Enum)
> perc :: PercussionSound -> Dur -> Music Pitch
> perc ps dur = instrument Percussion $ note dur (pitch (fromEnum ps + 35))
> pMap :: (a -> b) -> Primitive a -> Primitive b
> pMap f (Note d x) = Note d (f x)
> pMap f (Rest d) = Rest d
> mMap :: (a -> b) -> Music a -> Music b
> mMap f (Prim p) = Prim (pMap f p)
> mMap f (m1 :+: m2) = mMap f m1 :+: mMap f m2
> mMap f (m1 :=: m2) = mMap f m1 :=: mMap f m2
> mMap f (Modify c m) = Modify c (mMap f m)
> instance Functor Primitive where
> fmap = pMap
> instance Functor Music where
> fmap = mMap
> mFold :: (Primitive a -> b) -> (b->b->b) -> (b->b->b) ->
> (Control -> b -> b) -> Music a -> b
> mFold f (+:) (=:) g m =
> let rec = mFold f (+:) (=:) g
> in case m of
> Prim p -> f p
> m1 :+: m2 -> rec m1 +: rec m2
> m1 :=: m2 -> rec m1 =: rec m2
> Modify c m -> g c (rec m)
Sometimes we may wish to alter the internal structure of a Music value
rather than wrapping it with Modify. The following functions allow this.
> shiftPitches :: AbsPitch -> Music Pitch -> Music Pitch
> shiftPitches k = mMap (trans k)
> shiftPitches1 :: AbsPitch -> Music (Pitch, b) -> Music (Pitch, b)
> shiftPitches1 k = mMap (\(p,xs) -> (trans k p, xs))
> scaleDurations :: Rational -> Music a -> Music a
> scaleDurations r (Prim (Note d p)) = note (d/r) p
> scaleDurations r (Prim (Rest d)) = rest (d/r)
> scaleDurations r (m1 :+: m2) = scaleDurations r m1 :+: scaleDurations r m2
> scaleDurations r (m1 :=: m2) = scaleDurations r m1 :=: scaleDurations r m2
> scaleDurations r (Modify c m) = Modify c (scaleDurations r m)
> changeInstrument :: InstrumentName -> Music a -> Music a
> changeInstrument i m = Modify (Instrument i) $ removeInstruments m
> removeInstruments :: Music a -> Music a
> removeInstruments (Modify (Instrument i) m) = removeInstruments m
> removeInstruments (Modify c m) = Modify c $ removeInstruments m
> removeInstruments (m1 :+: m2) = removeInstruments m1 :+: removeInstruments m2
> removeInstruments (m1 :=: m2) = removeInstruments m1 :=: removeInstruments m2
> removeInstruments m = m