% GHC-6.4.1 runs out of memory with optimization.
% Unfortunately we cannot override Cabal's option here,
% so you have to configure with --disable-optimization
% {-# OPTIONS_GHC -Onot #-}
New Resolutions by Jean-Luc Ponty, Scott O'Neil, and John Garvin
> module Haskore.Example.NewResolutions where
> import qualified Haskore.Basic.Pitch as Pitch
> import qualified Haskore.Basic.Tempo as Tempo
> import qualified Haskore.Interface.MIDI.Write as WriteMidi
> import qualified Sound.MIDI.File.Save as SaveMidi
> import qualified Sound.MIDI.File as MidiFile
> import qualified Haskore.Performance.Context as Context
> import qualified Haskore.Performance.Fancy as FancyPf
> import Haskore.Basic.Duration((%+))
> import Haskore.Basic.Pitch
> import Haskore.Basic.Interval as Interval
> import qualified Haskore.Music as Music
> import Haskore.Melody as Melody
> import Haskore.Melody.Standard as StdMelody
> import Haskore.Music.GeneralMIDI as MidiMusic
> import qualified Haskore.Music.Rhythmic as RhyMusic
> import qualified Data.List as List
> import qualified Numeric.NonNegative.Wrapper as NonNeg
> import qualified Data.Accessor.Basic as Accessor
> piano, marimba, xylo, vib, glock :: MidiMusic.Instr
> piano = MidiMusic.AcousticGrandPiano
> marimba = MidiMusic.Marimba
> xylo = MidiMusic.Xylophone
> vib = MidiMusic.Vibraphone
> glock = MidiMusic.Glockenspiel
> pattern, melPattern,
> melody1, bellPart, vibesLine, vibesPart,
> melody2, vibeLine3, vibePart3,
> melody3, endRun :: StdMelody.T
> part1, part2, part3, bridge, ending, harmony3 :: MidiMusic.T
> comp2 :: (c -> d) -> (a -> b -> c) -> (a -> b -> d)
> comp2 func = ((func .) .)
% comp2 func1 func0 = curry (func1 . uncurry func0)
> arpeggio :: [Int] -> Pitch.T -> Dur -> StdMelody.T
> arpeggio trs p d' = line (map (\tr -> note (Pitch.transpose tr p) d' na) trs)
> minArpegUp, minArpegDown, majArpegDown, six3ArpegDown
> :: Pitch.T -> Dur -> StdMelody.T
> minArpegUp = arpeggio [unison, minorThird, fifth, octave]
> minArpegDown = arpeggio [octave, fifth, minorThird, unison]
> majArpegDown = arpeggio [octave, fifth, majorThird, unison]
> six3ArpegDown = arpeggio [octave, majorSixth, majorThird, unison]
> pattern = minArpegUp (5,D) sn
> +:+ minArpegDown (5,C) sn
> +:+ minArpegUp (4,A) sn
> +:+ minArpegDown (4,G) sn
> +:+ minArpegUp (4,F) sn
> +:+ d 5 sn na +:+ a 4 sn na +:+ f 4 sn na +:+ a 4 sn na
> melPattern = d 6 en na +:+ c 6 en na +:+ d 6 en na
> +:+ snr
> +:+ a 5 en na +:+ g 5 en na +:+ a 5 en na
> melody1 = melPattern +:+ enr +:+ d 5 sn na
> +:+ f 5 sn na +:+ g 5 en na +:+ f 5 sn na +:+ d 5 en na +:+ c 5 en na
> +:+ d 5 en na +:+ melPattern +:+ d 5 sn na
> +:+ f 5 sn na +:+ f 5 sn na +:+ g 5 sn na +:+ f 5 sn na
> +:+ d 5 sn na +:+ c 5 en na +:+ d 5 den na
> +:+ melPattern +:+ d 5 sn na
> +:+ f 5 sn na +:+ g 5 sn na +:+ f 5 sn na +:+ d 5 en na
> +:+ c 5 sn na +:+ d 5 en na
> +:+ d 6 en na +:+ c 6 en na +:+ d 6 den na +:+ c 6 en na
> +:+ a 5 en na +:+ c 6 en na +:+ a 5 sn na +:+ g 5 en na
> +:+ f 5 en na +:+ af 5 en na
> +:+ g 5 sn na +:+ f 5 sn na +:+ d 5 sn na +:+ c 5 sn na
>
> bellPart = d 7 en na +:+ f 7 en na +:+ c 7 en na +:+ d 7 en na
> +:+ a 6 en na +:+ c 7 en na +:+ g 6 en na +:+ a 6 en na
> +:+ f 6 en na +:+ g 6 en na
> +:+ d 6 sn na +:+ f 6 sn na +:+ a 6 sn na +:+ c 7 sn na
> vibesLine = d 5 qn na +:+ c 5 qn na +:+ a 4 qn na
> +:+ g 4 qn na +:+ f 4 qn na +:+ d 4 qn na
> vibesPart = vibesLine =:= Music.transpose 12 vibesLine
> cMajorScale, gMajorScale, dPentMinScale :: [Pitch.T]
> cMajorScale = [(0,C), (0,D), (0,E), (0,F), (0,G), (0,A), (0,B)]
> gMajorScale = [(0,G), (0,A), (0,B), (1,C), (1,D), (1,E), (1,Fs)]
> dPentMinScale = [(0,D), (0,F), (0,G), (0,A), (1,C)]
> prevNote, nextNote :: [Pitch.T] -> Pitch.T -> Pitch.T
> prevNote [] _ = error ("Scale empty")
> prevNote [_] _ = error ("Note not found in scale")
> prevNote ((n,y):ys) (oct,p) | y == p = let (m,x) = last ys
> in (oct + m n 1, x)
> prevNote ((m,x):(n,y):xys) (oct,p) | y == p = (oct + m n, x)
> | otherwise = prevNote ((n,y):xys) (oct,p)
> nextNote scale n = nextNote' (head scale) scale n
> nextNote' :: Pitch.T -> [Pitch.T] -> Pitch.T -> Pitch.T
> nextNote' _ [] _ = error ("Scale empty")
> nextNote' (fstO,fstP) [(m,x)] (oct,p)
> | x == p = (oct m + fstO + 1, fstP)
> | otherwise = error ("Note not found in scale")
> nextNote' fst' ((m,x):(n,y):xys) (oct,p)
> | x == p = (oct m + n, y)
> | otherwise = nextNote' fst' ((n,y):xys) (oct,p)
> back2Note :: [Pitch.T] -> Pitch.T -> Pitch.T
> back2Note s = prevNote s . prevNote s
> nextNR, prevNR, back2NR :: Pitch.T -> Pitch.T
> nextNR = nextNote dPentMinScale
> prevNR = prevNote dPentMinScale
> back2NR = back2Note dPentMinScale
> makeSN, diddle :: Pitch.T -> StdMelody.T
> makeSN p = note p sn na
> diddle p = line $ snr : map makeSN [p, prevNR p, p]
> melody2 = d 6 sn na +:+ d 6 en na +:+ c 6 en na +:+ d 6 sn na +:+ c 6 en na
> +:+ a 5 en na +:+ g 5 sn na +:+ f 5 sn na
> +:+ g 5 sn na +:+ f 5 sn na +:+ d 5 sn na +:+ f 5 sn na
> +:+ diddle (5,D) +:+ diddle (5,C)
> +:+ diddle (6,D) +:+ diddle (6,C) +:+ diddle (5,A)
> +:+ diddle (5,G) +:+ diddle (5,F) +:+ diddle (5,D)
> +:+ snr +:+ d 6 en na +:+ c 6 en na +:+ d 6 den na
> +:+ c 6 en na +:+ a 5 en na +:+ g 5 den na
> +:+ f 5 en na +:+ g 5 en na +:+ f 5 sn na
> +:+ g 5 sn na +:+ f 5 sn na +:+ d 5 sn na +:+ c 5 sn na
> +:+ d 5 den na +:+ d 6 en na +:+ c 6 den na +:+ a 5 en na +:+ g 5 den na
> +:+ f 5 en na +:+ d 5 den na +:+ c 5 en na +:+ d 5 qn na
> part1 = MidiMusic.fromStdMelody marimba (loudness1 0.7 pattern)
> +:+
> MidiMusic.fromStdMelody xylo (loudness1 1.2 melody1)
> =:= MidiMusic.fromStdMelody marimba (loudness1 0.7 (Music.replicate 4 pattern))
> bridge = MidiMusic.fromStdMelody xylo (d 5 hn (Accessor.set velocity1 1.2 na))
> =:= (Music.replicate 2 $
> MidiMusic.fromStdMelody marimba (loudness1 0.6 (Music.transpose (12) bellPart))
> =:= MidiMusic.fromStdMelody vib (loudness1 0.4 vibesPart)
> =:= MidiMusic.fromStdMelody glock (loudness1 0.8 bellPart))
> part2 = MidiMusic.fromStdMelody xylo (loudness1 1.2 melody2)
> =:= MidiMusic.fromStdMelody marimba (loudness1 0.7 (Music.replicate 3 pattern
> +:+ minArpegUp (5,D) sn
> +:+ minArpegDown (5,C) sn
> +:+ minArpegUp (4,A) sn
> +:+ minArpegDown (4,G) sn
> +:+ minArpegUp (4,F) sn
> +:+ d 5 sn na))
> =:= Music.replicate 4 (MidiMusic.fromStdMelody vib (loudness1 0.4 vibesPart))
> run1, run2, run3 :: Pitch.T -> Dur -> StdMelody.T
> run1 = arpeggio [unison, minorThird, fifth,
> minorSeventh, octave, octaveMinorThird,
> octaveFifth, octaveMinorThird, octave,
> minorSeventh, fifth, minorThird]
> part3Pattern :: (Num t) =>
> ((t, Pitch.Class) -> Dur -> StdMelody.T) -> MidiMusic.T
> part3Pattern el = MidiMusic.fromStdMelody piano $
> el (4,D) sn +:+ el (4,C) sn +:+ el (4,D) sn +:+ el (4,F) sn
> run2 = Music.replicate 2 `comp2`
> arpeggio [fifth, minorSeventh, octave,
> octaveMinorThird, octave, minorSeventh]
> run3 = Music.replicate 3 `comp2`
> arpeggio [octaveMinorThird, octave, minorSeventh, fifth]
> vibeLine3 = let el p = arpeggio [octave, fifth, minorSeventh, octave] p den
> in el (4,D) +:+ el (4,C) +:+ el (4,D)
> +:+ f 5 den na +:+ c 5 den na
> +:+ ef 5 en na +:+ f 5 en na +:+ af 5 en na
> vibePart3 = vibeLine3 =:= Music.transpose 12 vibeLine3
> melody3 = a 5 (11%+16) na +:+ f 6 sn na
> +:+ ef 6 en na +:+ d 6 en na +:+ c 6 en na +:+ g 5 dqn na
> +:+ Music.replicate 3 (a 5 sn na +:+ f 6 en na) +:+ a 5 en na
> +:+ f 6 en na +:+ af 5 en na +:+ f 6 en na +:+ af 5 en na
> +:+ minArpegDown (5,F) sn +:+ snr
> +:+ majArpegDown (5,F) sn +:+ snr
> +:+ six3ArpegDown (5,F) sn +:+ snr +:+ f 6 sn na +:+ d 6 sn na
> +:+ ef 6 sn na +:+ d 6 sn na +:+ c 6 sn na +:+ g 5 sn na +:+ snr
> +:+ majArpegDown (5,Ef) sn +:+ snr +:+ ef 6 sn na +:+ c 6 sn na
> +:+ majArpegDown (5,F) sn +:+ snr
> +:+ six3ArpegDown (5,F) sn +:+ snr +:+ f 6 sn na +:+ d 6 sn na
> +:+ minArpegDown (5,F) sn +:+ snr
> +:+ minArpegDown (5,F) sn +:+ af 5 sn na +:+ c 6 sn na +:+ f 6 sn na
> +:+ line (map (Music.replicate 2) [f 6 sn na, d 6 sn na, c 6 sn na,
> a 5 sn na, g 5 sn na, f 5 sn na])
> +:+ ef 5 sn na +:+ f 5 sn na +:+ g 5 sn na +:+ bf 5 sn na
> +:+ c 6 sn na +:+ d 6 sn na +:+ ef 6 sn na +:+ d 6 sn na
> +:+ c 6 sn na +:+ bf 5 sn na +:+ a 5 sn na +:+ g 5 sn na
> +:+ Music.replicate 4 (a 5 sn na +:+ a 5 sn na +:+ g 5 sn na)
> +:+ Music.replicate 2 (af 5 sn na +:+ af 5 sn na +:+ g 5 sn na)
> +:+ Music.replicate 2 (af 5 sn na +:+ g 5 sn na +:+ f 5 sn na)
> +:+ a 5 dqn na
> +:+ f 6 sn na +:+ d 6 sn na +:+ c 6 sn na
> +:+ a 5 sn na +:+ g 5 sn na +:+ f 5 sn na
> +:+ g 5 sn na +:+ bf 5 sn na +:+ ef 6 dqn na
> +:+ bf 6 den na +:+ bf 6 sn na
> +:+ a 6 en na +:+ a 6 sn na +:+ g 6 en na +:+ g 6 sn na
> +:+ f 6 den na +:+ a 5 sn na +:+ c 6 sn na +:+ d 6 sn na
> +:+ f 6 den na +:+ f 6 sn na +:+ d 6 sn na +:+ c 6 sn na
> +:+ af 5 sn na +:+ af 5 sn na +:+ g 5 sn na
> +:+ f 5 sn na +:+ d 5 sn na +:+ c 5 sn na
> harmony3 = loudness1 0.6 (part3Pattern run1
> =:= part3Pattern run2
> =:= Music.transpose 12 (part3Pattern run3))
> =:= loudness1 0.5 (MidiMusic.fromStdMelody vib vibePart3)
> part3 = loudness1 0.6 (part3Pattern run1)
> +:+ (loudness1 0.6 (part3Pattern run1)
> =:= loudness1 0.9 (part3Pattern run2))
> +:+ (loudness1 0.6 ((part3Pattern run1)
> =:= (part3Pattern run2))
> =:= loudness1 1.0 (Music.transpose 12 (part3Pattern run3)))
> +:+ loudness1 0.6 (part3Pattern run1
> =:= part3Pattern run2
> =:= Music.transpose 12 (part3Pattern run3))
> =:= loudness1 0.7 (MidiMusic.fromStdMelody vib vibePart3)
> +:+ (Music.replicate 4 harmony3 =:=
> loudness1 1.0 (MidiMusic.fromStdMelody xylo melody3 =:=
> MidiMusic.fromStdMelody marimba melody3))
> all3Insts :: StdMelody.T -> MidiMusic.T
> all3Insts m = chord [MidiMusic.fromStdMelody marimba m,
> MidiMusic.fromStdMelody xylo m,
> MidiMusic.fromStdMelody vib m]
> endEl :: Pitch.T -> StdMelody.T
> endEl p = line $ map makeSN [p, back2NR p, prevNR p, p]
> endRun = line $ map endEl $ List.take 10 $ iterate nextNR (5,D)
> ending = all3Insts $
> d 5 qn na
> +:+ loudness1 1.2 (endRun +:+ d 7 sn na)
> song :: MidiMusic.T
> song = Music.transpose (48) $ line [part1, bridge, part2, part3, ending]
>
>
> context :: Context.T NonNeg.Float Float (RhyMusic.Note MidiMusic.Drum MidiMusic.Instr)
> context =
> Context.setDur (Tempo.metro 120 qn) $
> FancyPf.context
>
> midi :: MidiFile.T
> midi = WriteMidi.fromGMMusicAuto (context, song)
>
> main :: IO ()
> main = SaveMidi.toFile "newresolutions.mid" midi