module Euterpea.Music.Note.MoreMusic where
import Euterpea.Music.Note.Music
line, chord :: [Music a] -> Music a
line = foldr (:+:) (rest 0)
chord = foldr (:=:) (rest 0)
line1, chord1 :: [Music a] -> Music a
line1 = foldr1 (:+:)
chord1 = foldr1 (:=:)
delayM :: Dur -> Music a -> Music a
delayM d m = rest d :+: m
timesM :: Int -> Music a -> Music a
timesM 0 m = rest 0
timesM n m = m :+: timesM (n1) m
repeatM :: Music a -> Music a
repeatM m = m :+: repeatM 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"
invert :: Music Pitch -> Music Pitch
invert m =
let l@(Prim (Note _ r) : _) = lineToList m
inv (Prim (Note d p)) =
note d (pitch (2 * absPitch r absPitch p))
inv (Prim (Rest d)) = rest d
in line (map inv l)
retro, retroInvert, invertRetro :: Music Pitch -> Music Pitch
retro = line . reverse . lineToList
retroInvert = retro . invert
invertRetro = invert . retro
pr1, pr2 :: Pitch -> Music Pitch
pr1 p = tempo (5/6)
( tempo (4/3) ( mkLn 1 p qn :+:
tempo (3/2) ( mkLn 3 p en :+:
mkLn 2 p sn :+:
mkLn 1 p qn ) :+:
mkLn 1 p qn) :+:
tempo (3/2) ( mkLn 6 p en))
pr2 p =
let m1 = tempo (5/4) (tempo (3/2) m2 :+: m2)
m2 = mkLn 3 p en
in tempo (7/6) ( m1 :+:
tempo (5/4) (mkLn 5 p en) :+:
m1 :+:
tempo (3/2) m2)
mkLn :: Int -> p -> Dur -> Music p
mkLn n p d = line $ take n $ repeat $ note d p
pr12 :: Music Pitch
pr12 = pr1 (C,4) :=: pr2 (G,4)
(=:=) :: Dur -> Dur -> Music a -> Music a
old =:= new = tempo (new/old)
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
revM :: Music a -> Music a
revM n@(Prim _) = n
revM (Modify c m) = Modify c (revM m)
revM (m1 :+: m2) = revM m2 :+: revM m1
revM (m1 :=: m2) =
let d1 = dur m1
d2 = dur m2
in if d1>d2 then revM m1 :=: (rest (d1d2) :+: revM m2)
else (rest (d2d1) :+: revM m1) :=: revM m2
takeM :: Dur -> Music a -> Music a
takeM d m | d <= 0 = rest 0
takeM d (Prim (Note oldD p)) = note (min oldD d) p
takeM d (Prim (Rest oldD)) = rest (min oldD d)
takeM d (m1 :=: m2) = takeM d m1 :=: takeM d m2
takeM d (m1 :+: m2) = let m'1 = takeM d m1
m'2 = takeM (d dur m'1) m2
in m'1 :+: m'2
takeM d (Modify (Tempo r) m) = tempo r (takeM (d*r) m)
takeM d (Modify c m) = Modify c (takeM d m)
cut :: Dur -> Music a -> Music a
cut = takeM
dropM :: Dur -> Music a -> Music a
dropM d m | d <= 0 = m
dropM d (Prim (Note oldD p)) = note (max (oldDd) 0) p
dropM d (Prim (Rest oldD)) = rest (max (oldDd) 0)
dropM d (m1 :=: m2) = dropM d m1 :=: dropM d m2
dropM d (m1 :+: m2) = let m'1 = dropM d m1
m'2 = dropM (d dur m1) m2
in m'1 :+: m'2
dropM d (Modify (Tempo r) m) = tempo r (dropM (d*r) m)
dropM d (Modify c m) = Modify c (dropM 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'
takeML :: LazyDur -> Music a -> Music a
takeML [] m = rest 0
takeML (d:ds) m | d <= 0 = takeML ds m
takeML ld (Prim (Note oldD p)) = note (minL ld oldD) p
takeML ld (Prim (Rest oldD)) = rest (minL ld oldD)
takeML ld (m1 :=: m2) = takeML ld m1 :=: takeML ld m2
takeML ld (m1 :+: m2) =
let m'1 = takeML ld m1
m'2 = takeML (map (\d -> d dur m'1) ld) m2
in m'1 :+: m'2
takeML ld (Modify (Tempo r) m) = tempo r (takeML (map (*r) ld) m)
takeML ld (Modify c m) = Modify c (takeML ld m)
(/=:) :: Music a -> Music a -> Music a
m1 /=: m2 = takeML (durL m2) m1 :=: takeML (durL m1) m2
trill :: Int -> Dur -> Music Pitch -> Music Pitch
trill i sDur (Prim (Note tDur p)) =
if sDur >= tDur then note tDur p
else note sDur p :+:
trill (negate i) sDur
(note (tDursDur) (trans i p))
trill i d (Modify (Tempo r) m) = tempo r (trill i (d*r) m)
trill i d (Modify c m) = Modify c (trill i d m)
trill _ _ _ =
error "trill: input must be a single note."
trill' :: Int -> Dur -> Music Pitch -> Music Pitch
trill' i sDur m = trill (negate i) sDur (transpose i m)
trilln :: Int -> Int -> Music Pitch -> Music Pitch
trilln i nTimes m = trill i (dur m / fromIntegral nTimes) m
trilln' :: Int -> Int -> Music Pitch -> Music Pitch
trilln' i nTimes m = trilln (negate i) nTimes (transpose i m)
roll :: Dur -> Music Pitch -> Music Pitch
rolln :: Int -> Music Pitch -> Music Pitch
roll dur m = trill 0 dur m
rolln nTimes m = trilln 0 nTimes m
ssfMel :: Music Pitch
ssfMel = line (l1 ++ l2 ++ l3 ++ l4)
where l1 = [ trilln 2 5 (bf 6 en), ef 7 en, ef 6 en, ef 7 en ]
l2 = [ bf 6 sn, c 7 sn, bf 6 sn, g 6 sn, ef 6 en, bf 5 en ]
l3 = [ ef 6 sn, f 6 sn, g 6 sn, af 6 sn, bf 6 en, ef 7 en ]
l4 = [ trill 2 tn (bf 6 qn), bf 6 sn, denr ]
starsAndStripes :: Music Pitch
starsAndStripes = instrument Flute ssfMel
grace :: Int -> Rational -> Music Pitch -> Music Pitch
grace n r (Prim (Note d p)) =
note (r*d) (trans n p) :+: note ((1r)*d) p
grace n r _ =
error "grace: can only add a grace note to a note"
grace2 :: Int -> Rational ->
Music Pitch -> Music Pitch -> Music Pitch
grace2 n r (Prim (Note d1 p1)) (Prim (Note d2 p2)) =
note (d1r*d2) p1 :+: note (r*d2) (trans n p2) :+: note d2 p2
grace2 _ _ _ _ =
error "grace2: can only add a grace note to a note"
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 = note dur (pitch (fromEnum ps + 35))
funkGroove :: Music Pitch
funkGroove
= let p1 = perc LowTom qn
p2 = perc AcousticSnare en
in tempo 3 $ instrument Percussion $ takeM 8 $ repeatM
( ( p1 :+: qnr :+: p2 :+: qnr :+: p2 :+:
p1 :+: p1 :+: qnr :+: p2 :+: enr)
:=: roll en (perc ClosedHiHat 2) )
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)
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)
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)
rep :: (Music a -> Music a) -> (Music a -> Music a) -> Int
-> Music a -> Music a
rep f g 0 m = rest 0
rep f g n m = m :=: g (rep f g (n1) (f m))
run, cascade, cascades, final :: Music Pitch
run', cascade', cascades', final' :: Music Pitch
run = rep (transpose 5) (delayM tn) 8 (c 4 tn)
cascade = rep (transpose 4) (delayM en) 8 run
cascades = rep id (delayM sn) 2 cascade
final = cascades :+: revM cascades
run' = rep (delayM tn) (transpose 5) 8 (c 4 tn)
cascade' = rep (delayM en) (transpose 4) 8 run'
cascades' = rep (delayM sn) id 2 cascade'
final' = cascades' :+: revM cascades'