module KleeblattUnbekannt where

import Midi ;
import Pitch ;
import List ( (++), concatMap, concat, cycle, take )
import Prelude ( Int, negate, (-), (*), ($) ) ;


main, once, infinite, music ::
  [Midi.Event (Midi.Channel Midi.Message)] ;
main = song ;

test =
  --- bassTrack bass0 ++
  chorusMelodyTrack melody1 ++
  main ;

song =
  verseMelodyTrack melody0 ++
  verseMelodyTrack melody0 ++
  bassTrack bass0 ++
  chorusMelodyTrack melody1 ++ main ;

infinite =
  rest (8*hn) +:+ rhythmTrack
  =:=
  cycle music ;

once =
  rest (8*hn) +:+ takeTime (5*16*hn) rhythmTrack
  =:=
  music ;

music =
  block melody0 [] [] ++
  block melody1 guitar1 bass1 ++
  block melody2 guitar1 bass2 ++
  block melody3 guitar3 bass3 ++
  block melody4 guitar4 bass4 ++
  block melody5 guitar5 bass5 ++
  [] ;

block ::
  [[Event Message]] ->
  [Pitch] ->
  [Pitch] ->
  [Event (Channel Message)] ;
block mel guit bss =
  mergeMany $
    melodyTrack mel :
    guitarTrack guit :
    bassTrack bss :
    [] ;


-- melodyTrack melody0
melody0, melody1 :: [Event Message] ;
melody0 =
  note hn (f 5) ++ note dqn (e 5) ++
  note en (f 5) ++ note (wn-short) (d 5) ++
  note short (e 5) ++ note hn (f 5) ++ note dqn (e 5) ++
  note en (f 5) ++ note dhn (d 5) ++
  note (qn-sn) (g 5) ++
  note sn (f 5) ++
  note dhn (c 5) ++
  note qn (g 5) ++
  [] ;


melody1 =
  note qn (f 5) ++
  note sn (g 5) ++ note sn (a 5) ++ note sn (g 5) ++ note sn (f 5) ++
  note qn (a 5) ++
  note sn (g 5) ++ note sn (a 5) ++ note sn (g 5) ++ note sn (f 5) ++
  note den (d 5) ++ note den (f 5) ++ note dhn (f 5) ++

  note qn (f 5) ++
  note sn (g 5) ++ note sn (a 5) ++ note sn (g 5) ++ note sn (f 5) ++
  note den (d 6) ++ note den (c 6) ++ note wn (g 5) ++

  note qn (c 6) ++
  note en (f 5) ++ note en (g 5) ++ note en (a 5) ++
  note en (as 5) ++ note en (c 6) ++ note en (f 6) ++
  note den (d 6) ++ note den (c 6) ++ note den (c 6) ++
  note sn (as 5) ++ note qn (a 5) ++
  note en (c 6) ++ note den (c 6) ++ note den (as 5) ++
  note dhn (f 5) ++
  [] ;


guitar1, guitar3, guitar4, guitar5 :: [Pitch] ;
guitar1 =
  cyc 4 [g 6, c 7, e 7] ++
  cyc 4 [a 6, c 7, f 7] ++
  cyc 4 [g 6, b 6, d 7] ++
  cyc 1 [a 6, c 7, f 7] ++
  cyc 1 [g 6, b 6, d 7] ++
  cyc 2 [g 6, c 7, e 7] ++
  [] ;

guitar3 =
  cyc 8 [a  6, d 7, f 7] ++
  cyc 4 [g  6, c 7, e 7] ++
  cyc 2 [fs 6, a 6, d 7] ++
  cyc 2 [g  6, b 6, d 7] ++
  [] ;

guitar4 =
  cyc 4 [g 6, c 7, e 7] ++
  cyc 4 [a 6, d 7, f 7] ++
  cyc 2 [a 6, c 7, f 7] ++
  cyc 2 [g 6, b 6, d 7] ++
  cyc 1 [a 6, c 7, f 7] ++
  cyc 1 [g 6, b 6, d 7] ++
  cyc 2 [g 6, c 7, e 7] ++
  [] ;

guitar5 =
  cyc 4 [g 6, c 7, e 7] ++
  cyc 2 [a 6, d 7, f 7] ++
  cyc 4 [a 6, c 7, f 7] ++
  cyc 4 [g 6, b 6, d 7] ++
  cyc 2 [g 6, c 7, e 7] ++
  [] ;

cyc :: Int -> [a] -> [a] ;
cyc n xs = take (4*n) $ cycle xs ;


bass0 :: [Event Message] ;
bass0 =
  note den (as 4) ++ note den (a 4) ++
  note sn (as 4) ++ note sn (c 5) ++
  note den (d 5) ++ note den (c 5) ++
  note sn (d 5) ++ note sn (e 5) ++
  note den (f 5) ++ note den (e 5) ++
  note sn (g 5) ++ note sn (a 5) ++
  note qn (as 5) ++
  [] ;


rhythm :: [Event Message] ;
rhythm =
  bassDrum qn ++ hihat qn ++
  snareDrum qn ++ hihat qn ++
  rhythm ;

-- * durations

short, sn, en, qn, dqn, hn, ehn, ln :: Midi.Time ;

short = 50 ;
sn = 175 ;
en = 2*sn ; den = 3*sn ;
qn = 2*en ; dqn = 3*en ;
hn = 2*qn ; dhn = 3*qn ; ehn = 5*en ;
wn = 2*hn ;


-- * configuration

{- Yamaha SY35

melodyTrack :: [[Event Message]] -> [Event (Channel Message)] ;
melodyTrack xs =
  channel 0 $
  program 5 ++ controller volumeCC 127 ++
  transpose (negate 36) (concat xs) ;


guitarTrack :: [Pitch] -> [Event (Channel Message)] ;
guitarTrack xs =
  channel 6 $
  program 54 ++ controller volumeCC 110 ++
  transpose (negate 36) (concatMap (note en) xs) ;


bassTrack :: [Pitch] -> [Event (Channel Message)] ;
bassTrack xs =
  channel 2 $
  program 32 ++ controller volumeCC 127 ++
  transpose (negate 24) (concatMap (note hn) xs) ;


rhythmTrack :: [Event (Channel Message)] ;
rhythmTrack =
  channel 15 $
  program 63 ++ controller volumeCC 115 ++
  rhythm ;

drumKey :: Pitch ;
drumKey = 60 ;

bassDrum, snareDrum, hihat :: Time -> [Event Message] ;
bassDrum  dur = note dur (drumKey-15) ;
snareDrum dur = note dur (drumKey-8) ;
hihat     dur = note dur (drumKey-1) ;

-}

{- General MIDI -}

verseMelodyTrack :: [Event Message] -> [Event (Channel Message)] ;
verseMelodyTrack xs =
  channel 0 $
--  program 53 ++
  program 88 ++
--  program 79 ++
  transpose 0 xs ;


chorusMelodyTrack :: [Event Message] -> [Event (Channel Message)] ;
chorusMelodyTrack xs =
  channel 0 $
  program 73 ++
  transpose 0 xs ;


guitarTrack :: [Pitch] -> [Event (Channel Message)] ;
guitarTrack xs =
  channel 1 $
  program 24 ++
  transpose (negate 36) (concatMap (note en) xs) ;


bassTrack :: [Pitch] -> [Event (Channel Message)] ;
bassTrack xs =
  channel 2 $
  program 32 ++
  transpose (negate 36) xs ;


rhythmTrack :: [Event (Channel Message)] ;
rhythmTrack =
  channel 9 $
  program 63 ++
  rhythm ;

bassDrum, snareDrum, hihat :: Time -> [Event Message] ;
bassDrum  dur = note dur 37 ;
snareDrum dur = note dur 38 ;
hihat     dur = note dur 46 ;


volumeCC :: Midi.Controller ;
volumeCC = 7 ;