module Music where import qualified Haskore as H default (Int, Float) infixr 9 ! infixr 8 & infix 9 !> infix 9 !< type MusicChanger = Music -> Music type MusicGlue = Music -> Music -> Music type NoteChanger = Note -> Note type PitchChanger = Pitch -> Pitch play :: Music -> IO () play = namedPlay "test" namedPlay :: String -> Music -> IO () namedPlay name m = H.outputMidiFile (name++".mid") (H.testMidi (toHaskore m)) toHaskore (N n ) = let l = realToFrac (noteDur n) / 4 -- kluge! -- Haskore wants # of whole notes, -- with default wn = 2 seconds in case notePitch n of Just p -> H.Instr (noteInstr n) $ H.Note (H.pitch p) l [H.Volume (max 0 (min 100 (100 * noteVol n * noteVolMul n)))] Nothing -> H.Rest l toHaskore (P m1 m2) = toHaskore m1 H.:=: toHaskore m2 toHaskore (S m1 m2) = toHaskore m1 H.:+: toHaskore m2 data Music = N Note | P Music Music -- parallel | S Music Music -- sequential instance Show Music where show _ = "\n" ++ "You probably meant to say\n" ++ "\n" ++ " play \n" ++ "\n" ++ "instead of\n" ++ "\n" ++ " \n" ++ "\n" data Note = Note { noteInstr :: Instrument , notePitch :: Maybe Pitch , noteVol :: Volume , noteVolMul :: Float , noteDur :: Duration } deriving (Show) type Instrument = String type Pitch = Int -- in semitones; 60 is middle C (c4) type Interval = Int type Volume = Float -- 0 to 1 type Duration = Float -- in seconds -- useful defaults default_note :: Note default_note = Note { noteInstr = default_instr , notePitch = default_pitch , noteVol = default_vol , noteVolMul = default_volmul , noteDur = default_dur } default_instr :: Instrument default_instr = "Acoustic Grand Piano" default_pitch :: Maybe Pitch default_pitch = Nothing default_vol :: Volume default_vol = 7/10 default_volmul :: Float default_volmul = 1 default_dur :: Duration default_dur = 4 * 60/default_tempo default_tempo :: Float default_tempo = 120 -- m ! m' plays m and m' in parallel (!) :: MusicGlue (!) = P -- m & m' plays m and m' in sequence (&) :: MusicGlue (&) = S void :: Music void = slower 0 r chord :: [Music] -> Music chord = foldl (!) void line :: [Music] -> Music line = foldl (&) void (!<), (!>) :: MusicGlue m !< m' = m ! cut (duration m) m' (!>) = flip (!<) cut :: Duration -> MusicChanger cut l (N n) = if l <= 0 then void else N (n { noteDur = min l (noteDur n) }) cut l (P m1 m2) = cut l m1 ! cut l m2 cut l (S m1 m2) = let m1' = cut l m1 l' = l - duration m1' in if l' > 0 then m1' & cut l' m2 else void lift :: NoteChanger -> MusicChanger lift f (N n) = N (f n) lift f (P m1 m2) = lift f m1 ! lift f m2 lift f (S m1 m2) = lift f m1 & lift f m2 mapPitches :: PitchChanger -> MusicChanger mapPitches f = lift (\n -> n { notePitch = notePitch n >>= \p -> return (f p) }) changeNotes :: MusicChanger -> MusicChanger changeNotes f (P m1 m2) = changeNotes f m1 ! changeNotes f m2 changeNotes f (S m1 m2) = changeNotes f m1 & changeNotes f m2 changeNotes f m = f m changePitches :: MusicChanger -> MusicChanger changePitches f = changeNotes (\n -> if hasPitch n then f n else n) toNote :: Music -> Note toNote (N n) = n toNote _ = error "I was expecting a single note." hasPitch :: Music -> Bool hasPitch m = notePitch (toNote m) /= Nothing eqPitchClass :: Music -> Music -> Bool eqPitchClass m1 m2 = if not (hasPitch m1) then not (hasPitch m2) else hasPitch m2 && pitch m1 `mod` 12 == pitch m2 `mod` 12 pitch :: Music -> Pitch pitch m = case notePitch (toNote m) of Just p -> p Nothing -> error "I was expecting a note with a pitch." withPitch :: Pitch -> MusicChanger withPitch p m = let n = toNote m in N $ n { notePitch = Just p } duration :: Music -> Duration duration (N n) = noteDur n duration (P m1 m2) = duration m1 `max` duration m2 duration (S m1 m2) = duration m1 + duration m2 withDuration :: Duration -> MusicChanger withDuration d m = faster (duration m / d) m -- instruments withInstr :: Instrument -> MusicChanger withInstr i = lift (\n -> n { noteInstr = i }) piano :: MusicChanger piano = withInstr "Acoustic Grand Piano" harpsichord :: MusicChanger harpsichord = withInstr "Harpsichord" organ :: MusicChanger organ = withInstr "Church Organ" guitar :: MusicChanger guitar = withInstr "Acoustic Guitar (nylon)" bass :: MusicChanger bass = withInstr "Acoustic Bass" violin :: MusicChanger violin = withInstr "Violin" viola :: MusicChanger viola = withInstr "Viola" cello :: MusicChanger cello = withInstr "Cello" harp :: MusicChanger harp = withInstr "Orchestral Harp" trumpet :: MusicChanger trumpet = withInstr "Trumpet" horn :: MusicChanger horn = withInstr "French Horn" sax :: MusicChanger sax = withInstr "Tenor Sax" oboe :: MusicChanger oboe = withInstr "Oboe" bassoon :: MusicChanger bassoon = withInstr "Bassoon" clarinet :: MusicChanger clarinet = withInstr "Clarinet" flute :: MusicChanger flute = withInstr "Flute" pan_flute :: MusicChanger pan_flute = withInstr "Pan Flute" -- transpose by i semitones up, down :: Interval -> MusicChanger up i = mapPitches (\p -> p+i) down i = mapPitches (\p -> p-i) -- ordered interval in semitones btw. a and b interval :: Music -> Music -> Interval interval a b = pitch b - pitch a invert :: Music -> MusicChanger invert i = mapPitches (\p -> 2 * pitch i - p) per1 :: Interval per1 = 0 min2 :: Interval min2 = 1 maj2 :: Interval maj2 = 2 min3 :: Interval min3 = 3 maj3 :: Interval maj3 = 4 per4 :: Interval per4 = 5 aug4 :: Interval aug4 = 6 dim5 :: Interval dim5 = 6 per5 :: Interval per5 = 7 min6 :: Interval min6 = 8 maj6 :: Interval maj6 = 9 min7 :: Interval min7 = 10 maj7 :: Interval maj7 = 11 per8 :: Interval per8 = 12 -- volume transforms withVol :: Volume -> MusicChanger withVol v = lift (\n -> n { noteVol = v }) pp, p, mp, mf, f, ff :: MusicChanger pp = withVol (1/7) p = withVol (2/7) mp = withVol (3/7) mf = withVol (4/7) f = withVol (5/7) ff = withVol (6/7) louder :: Float -> MusicChanger louder c = lift (\n -> n { noteVolMul = noteVolMul n * c }) softer :: Float -> MusicChanger softer c = lift (\n -> n { noteVolMul = noteVolMul n / c }) accent :: MusicChanger accent = louder (3/2) -- scale durations by c faster :: Float -> MusicChanger faster c = lift (\n -> n { noteDur = noteDur n / c}) slower :: Float -> MusicChanger slower c = lift (\n -> n { noteDur = noteDur n * c}) -- duration transforms dw, w, dh, h, dq, q, de, e, ds, s, dot :: MusicChanger w = id h = faster 2 q = faster 4 e = faster 8 s = faster 16 dot = slower (3/2) dw = dot . w dh = dot . h dq = dot . q de = dot . e ds = dot . s -- pitch names mkPitch :: Maybe Pitch -> Music mkPitch p = N (default_note { notePitch = p }) r :: Music r = mkPitch Nothing cf1 :: Music cf1 = mkPitch (Just 23) c1 :: Music c1 = mkPitch (Just 24) cs1 :: Music cs1 = mkPitch (Just 25) df1 :: Music df1 = mkPitch (Just 25) d1 :: Music d1 = mkPitch (Just 26) ds1 :: Music ds1 = mkPitch (Just 27) ef1 :: Music ef1 = mkPitch (Just 27) e1 :: Music e1 = mkPitch (Just 28) es1 :: Music es1 = mkPitch (Just 29) ff1 :: Music ff1 = mkPitch (Just 28) f1 :: Music f1 = mkPitch (Just 29) fs1 :: Music fs1 = mkPitch (Just 30) gf1 :: Music gf1 = mkPitch (Just 30) g1 :: Music g1 = mkPitch (Just 31) gs1 :: Music gs1 = mkPitch (Just 32) af1 :: Music af1 = mkPitch (Just 32) a1 :: Music a1 = mkPitch (Just 33) as1 :: Music as1 = mkPitch (Just 34) bf1 :: Music bf1 = mkPitch (Just 34) b1 :: Music b1 = mkPitch (Just 35) bs1 :: Music bs1 = mkPitch (Just 36) cf2 :: Music cf2 = mkPitch (Just 35) c2 :: Music c2 = mkPitch (Just 36) cs2 :: Music cs2 = mkPitch (Just 37) df2 :: Music df2 = mkPitch (Just 37) d2 :: Music d2 = mkPitch (Just 38) ds2 :: Music ds2 = mkPitch (Just 39) ef2 :: Music ef2 = mkPitch (Just 39) e2 :: Music e2 = mkPitch (Just 40) es2 :: Music es2 = mkPitch (Just 41) ff2 :: Music ff2 = mkPitch (Just 40) f2 :: Music f2 = mkPitch (Just 41) fs2 :: Music fs2 = mkPitch (Just 42) gf2 :: Music gf2 = mkPitch (Just 42) g2 :: Music g2 = mkPitch (Just 43) gs2 :: Music gs2 = mkPitch (Just 44) af2 :: Music af2 = mkPitch (Just 44) a2 :: Music a2 = mkPitch (Just 45) as2 :: Music as2 = mkPitch (Just 46) bf2 :: Music bf2 = mkPitch (Just 46) b2 :: Music b2 = mkPitch (Just 47) bs2 :: Music bs2 = mkPitch (Just 48) cf3 :: Music cf3 = mkPitch (Just 47) c3 :: Music c3 = mkPitch (Just 48) cs3 :: Music cs3 = mkPitch (Just 49) df3 :: Music df3 = mkPitch (Just 49) d3 :: Music d3 = mkPitch (Just 50) ds3 :: Music ds3 = mkPitch (Just 51) ef3 :: Music ef3 = mkPitch (Just 51) e3 :: Music e3 = mkPitch (Just 52) es3 :: Music es3 = mkPitch (Just 53) ff3 :: Music ff3 = mkPitch (Just 52) f3 :: Music f3 = mkPitch (Just 53) fs3 :: Music fs3 = mkPitch (Just 54) gf3 :: Music gf3 = mkPitch (Just 54) g3 :: Music g3 = mkPitch (Just 55) gs3 :: Music gs3 = mkPitch (Just 56) af3 :: Music af3 = mkPitch (Just 56) a3 :: Music a3 = mkPitch (Just 57) as3 :: Music as3 = mkPitch (Just 58) bf3 :: Music bf3 = mkPitch (Just 58) b3 :: Music b3 = mkPitch (Just 59) bs3 :: Music bs3 = mkPitch (Just 60) cf4 :: Music cf4 = mkPitch (Just 59) c4 :: Music c4 = mkPitch (Just 60) cs4 :: Music cs4 = mkPitch (Just 61) df4 :: Music df4 = mkPitch (Just 61) d4 :: Music d4 = mkPitch (Just 62) ds4 :: Music ds4 = mkPitch (Just 63) ef4 :: Music ef4 = mkPitch (Just 63) e4 :: Music e4 = mkPitch (Just 64) es4 :: Music es4 = mkPitch (Just 65) ff4 :: Music ff4 = mkPitch (Just 64) f4 :: Music f4 = mkPitch (Just 65) fs4 :: Music fs4 = mkPitch (Just 66) gf4 :: Music gf4 = mkPitch (Just 66) g4 :: Music g4 = mkPitch (Just 67) gs4 :: Music gs4 = mkPitch (Just 68) af4 :: Music af4 = mkPitch (Just 68) a4 :: Music a4 = mkPitch (Just 69) as4 :: Music as4 = mkPitch (Just 70) bf4 :: Music bf4 = mkPitch (Just 70) b4 :: Music b4 = mkPitch (Just 71) bs4 :: Music bs4 = mkPitch (Just 72) cf5 :: Music cf5 = mkPitch (Just 71) c5 :: Music c5 = mkPitch (Just 72) cs5 :: Music cs5 = mkPitch (Just 73) df5 :: Music df5 = mkPitch (Just 73) d5 :: Music d5 = mkPitch (Just 74) ds5 :: Music ds5 = mkPitch (Just 75) ef5 :: Music ef5 = mkPitch (Just 75) e5 :: Music e5 = mkPitch (Just 76) es5 :: Music es5 = mkPitch (Just 77) ff5 :: Music ff5 = mkPitch (Just 76) f5 :: Music f5 = mkPitch (Just 77) fs5 :: Music fs5 = mkPitch (Just 78) gf5 :: Music gf5 = mkPitch (Just 78) g5 :: Music g5 = mkPitch (Just 79) gs5 :: Music gs5 = mkPitch (Just 80) af5 :: Music af5 = mkPitch (Just 80) a5 :: Music a5 = mkPitch (Just 81) as5 :: Music as5 = mkPitch (Just 82) bf5 :: Music bf5 = mkPitch (Just 82) b5 :: Music b5 = mkPitch (Just 83) bs5 :: Music bs5 = mkPitch (Just 84) cf6 :: Music cf6 = mkPitch (Just 83) c6 :: Music c6 = mkPitch (Just 84) cs6 :: Music cs6 = mkPitch (Just 85) df6 :: Music df6 = mkPitch (Just 85) d6 :: Music d6 = mkPitch (Just 86) ds6 :: Music ds6 = mkPitch (Just 87) ef6 :: Music ef6 = mkPitch (Just 87) e6 :: Music e6 = mkPitch (Just 88) es6 :: Music es6 = mkPitch (Just 89) ff6 :: Music ff6 = mkPitch (Just 88) f6 :: Music f6 = mkPitch (Just 89) fs6 :: Music fs6 = mkPitch (Just 90) gf6 :: Music gf6 = mkPitch (Just 90) g6 :: Music g6 = mkPitch (Just 91) gs6 :: Music gs6 = mkPitch (Just 92) af6 :: Music af6 = mkPitch (Just 92) a6 :: Music a6 = mkPitch (Just 93) as6 :: Music as6 = mkPitch (Just 94) bf6 :: Music bf6 = mkPitch (Just 94) b6 :: Music b6 = mkPitch (Just 95) bs6 :: Music bs6 = mkPitch (Just 96) cf7 :: Music cf7 = mkPitch (Just 95) c7 :: Music c7 = mkPitch (Just 96) cs7 :: Music cs7 = mkPitch (Just 97) df7 :: Music df7 = mkPitch (Just 97) d7 :: Music d7 = mkPitch (Just 98) ds7 :: Music ds7 = mkPitch (Just 99) ef7 :: Music ef7 = mkPitch (Just 99) e7 :: Music e7 = mkPitch (Just 100) es7 :: Music es7 = mkPitch (Just 101) ff7 :: Music ff7 = mkPitch (Just 100) f7 :: Music f7 = mkPitch (Just 101) fs7 :: Music fs7 = mkPitch (Just 102) gf7 :: Music gf7 = mkPitch (Just 102) g7 :: Music g7 = mkPitch (Just 103) gs7 :: Music gs7 = mkPitch (Just 104) af7 :: Music af7 = mkPitch (Just 104) a7 :: Music a7 = mkPitch (Just 105) as7 :: Music as7 = mkPitch (Just 106) bf7 :: Music bf7 = mkPitch (Just 106) b7 :: Music b7 = mkPitch (Just 107) bs7 :: Music bs7 = mkPitch (Just 108)