module Antrag where

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


main, infinite, song, refrain, refrainSimple,
    verse0, verse1, verse2, verse5, verse6 ::
  [Midi.Event (Midi.Channel Midi.Message)] ;
main = song ;

infinite = verse0 ++ infinite ;

song =
  verse0 ++
  verse1 ++
  verse2 ++
  verse1 ++
  verse1 ++
  verse5 ++
  verse6 ++
  [] ;

verse0 =
  (block melody0 [] [] [] =:= guitarTrack (concat prelude)) ++
  block melody1 guitar1 bass1 rhythm1 ++
  block melody2 guitar1 bass2 rhythm1 ++
  block melody3 guitar3 bass3 rhythm1 ++
  refrain ++
  [] ;

verse1 =
  (block melody0 [] [] rhythm0 =:= guitarTrack (concat prelude)) ++
  block melody1 guitar1 bass1 rhythm1 ++
  block melody2 guitar1 bass2 rhythm1 ++
  block melody3 guitar3 bass3 rhythm1 ++
  refrain ++
  [] ;

verse2 =
  verse1
  =:=
  fluteTrack (rest (26*wn-flute3prefetch) ++ concat flute3) ;

verse5 =
  verse1
  =:=
  fluteTrack (rest (4*wn) ++ times 2 (concat flute1) ++ concat flute2) ;

verse6 =
  (block melody0 [] [] rhythm0 =:= guitarTrack (concat prelude)) ++
  block melody1 guitar1 bass1 rhythm1 ++
  block melody2 guitar1 bass2 rhythm1 ++
  block melody3 guitar3 bass3 rhythm1 ++
  (bassTrack bass6 =:= rhythmTrack rhythm6) ++
  refrain ++
  (block [] [] [] rhythm7 =:= guitarTrack (concat prelude)) ++
  [] ;

refrain =
  block melody4 guitar4 bass4 rhythm1 ++
  (block melody5 guitar5a bass5a rhythm8
   =:=
   (rest (3*wn) ++
    (guitarTrack (note wn (a 6) ++ guitar5b)
     =:=
     bassTrack (note wn (f 4) ++ concatMap (note hn) bass5c)))) ++
  [] ;

refrainSimple =
  block melody4 guitar4 bass4 rhythm1 ++
  block melody5 guitar5 bass5 rhythm1 ++
  [] ;

block ::
  [[Event Message]] ->
  [Pitch] ->
  [Pitch] ->
  [Event Message] ->
  [Event (Channel Message)] ;
block mel guit bss rhy =
  mergeMany $
    melodyTrack (concat mel) :
    guitarTrack (concatMap (note en) guit) :
    bassTrack (concatMap (note hn) bss) :
    rhythmTrack rhy :
    [] ;


prelude, melody0, melody1, melody2, melody3, melody4, melody5
  :: [[Event Message]] ;
prelude =
  note qn  (a  7) :
  note en  (c  8) :
  note qn  (a  7) :
  note en  (g  7) :
  note qn  (f  7) :
  note qn  (e  7) :
  note en  (g  7) :
  note qn  (e  7) :
  note en  (d  7) :
  note qn  (c  7) :
  note qn  (d  7) :
  note en  (e  7) :
  note qn  (d  7) :
  note en  (c  7) :
  note qn  (b  6) :
  note hn  (c  7) :
  rest hn :
  [] ;

melody0 =
  rest (4*wn-hn) :
  note qn  (g  6) :
  note qn  (g  6) :
  [] ;

melody1 =
  note qn  (g  6) :
  note qn  (g  6) :
  note qn  (c  7) :
  note en  (d  7) :
  note qn  (e  7) :
  note dqn (e  7) :
  note qn  (d  7) :
  note qn  (c  7) :
  note qn  (f  6) :
  note qn  (f  6) :
  note qn  (a  6) :
  note en  (c  7) :
  note ehn (f  7) :
  note qn  (f  6) :
  note qn  (f  6) :
  note qn  (g  6) :
  note qn  (g  6) :
  note qn  (b  6) :
  note en  (d  7) :
  note qn  (g  7) :
  note dqn (g  7) :
  note qn  (g  7) :
  note qn  (g  7) :
  note qn  (a  7) :
  note qn  (a  7) :
  note qn  (g  7) :
  note en  (f  7) :
  note ehn (e  7) :
  note qn  (g  6) :
  note qn  (g  6) :
  [] ;

melody2 =
  note qn  (g  6) :
  note qn  (g  6) :
  note qn  (c  7) :
  note en  (d  7) :
  note qn  (e  7) :
  note dqn (e  7) :
  note qn  (d  7) :
  note qn  (c  7) :
  note qn  (f  6) :
  note qn  (f  6) :
  note qn  (a  6) :
  note en  (c  7) :
  note ehn (f  7) :
  note qn  (f  6) :
  note qn  (f  6) :
  note qn  (g  6) :
  note qn  (g  6) :
  note qn  (b  6) :
  note en  (d  7) :
  note qn  (g  7) :
  note dqn (g  7) :
  note qn  (g  7) :
  note qn  (g  7) :
  note qn  (a  7) :
  note qn  (g  7) :
  note qn  (f  7) :
  note en  (b  6) :
  note ehn (c  7) :
  note qn  (d  7) :
  note qn  (e  7) :
  [] ;

melody3 =
  note qn  (f  7) :
  note qn  (e  7) :
  note qn  (d  7) :
  note en  (e  7) :
  note qn  (f  7) :
  note dqn (e  7) :
  note qn  (d  7) :
  note qn  (e  7) :
  note qn  (f  7) :
  note qn  (e  7) :
  note qn  (d  7) :
  note en  (e  7) :
  note ehn (f  7) :
  note qn  (c  7) :
  note qn  (d  7) :
  note qn  (e  7) :
  note qn  (d  7) :
  note qn  (c  7) :
  note en  (d  7) :
  note qn  (e  7) :
  note dqn (d  7) :
  note qn  (c  7) :
  note qn  (d  7) :
  note qn  (e  7) :
  note qn  (e  7) :
  note qn  (d  7) :
  note en  (c  7) :
  note ehn (g  7) :
  note dqn (g  7) :
  note en  (g  7) :
  [] ;

melody4 =
  note qn  (g  7) :
  note qn  (e  7) :
  note qn  (e  7) :
  note en  (e  7) :
  note qn  (e  7) :
  note dqn (d  7) :
  note qn  (d  7) :
  note qn  (c  7) :
  note qn  (c  7) :
  note qn  (a  6) :
  note qn  (a  6) :
  note en  (a  6) :
  note ehn (a  6) :
  note qn  (a  7) :
  note qn  (a  7) :
  note qn  (a  7) :
  note qn  (a  7) :
  note qn  (a  7) :
  note qn  (a  7) :
  note qn  (a  7) :
  note en  (g  7) :
  note qn  (g  7) :
  note dqn (g  7) :
  note qn  (a  7) :
  note qn  (a  7) :
  note qn  (g  7) :
  note en  (f  7) :
  note ehn (e  7) :
  note qn  (e  7) :
  note qn  (f  7) :
  [] ;

melody5 =
  note qn  (g  7) :
  note qn  (g  7) :
  note qn  (g  7) :
  note en  (g  7) :
  note qn  (a  7) :
  note dqn (g  7) :
  note qn  (f  7) :
  note qn  (e  7) :
  note qn  (d  7) :
  note qn  (cs 7) :
  note qn  (d  7) :
  note en  (f  7) :
  note ehn (a  7) :
  note qn  (d  7) :
  note qn  (e  7) :
  note qn  (f  7) :
  note qn  (a  7) :
  note qn  (f  7) :
  note en  (d  7) :
  note qn  (e  7) :
  note qn  (g  7) :
  note qn  (e  7) :
  note dqn (c  7) :
  note qn  (f  7) :
  note qn  (d  7) :
  note qn  (c  7) :
  note en  (b  6) :
  note ln  (c  7) :
  [] ;


guitar1, guitar3, guitar4, guitar5, guitar5a :: [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] ++
  [] ;

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

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

short :: Time ;
short = 30 ;

gchord3 :: Time -> Pitch -> Pitch -> Pitch -> [Event Message] ;
gchord3 dur p0 p1 p2 =
  note dur p0
  =:=
  (rest short ++ note (dur - short) p1)
  =:=
  (rest (2*short) ++ note (dur - 2*short) p2) ;

guitar5b :: [Event Message] ;
guitar5b =
  gchord3 hn (a 6) (c 7) (f 7) ++
  gchord3 hn (c 7) (f 7) (a 7) ++
  gchord3 hn (g 6) (b 6) (e 7) ++
  gchord3 hn (b 6) (e 7) (g 7) ++
  gchord3 hn (g 6) (b 6) (d 7) ++
  gchord3 hn (b 6) (d 7) (g 7) ++
  gchord3 wn (e 6) (g 6) (c 7) ++
  [] ;


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


bass, bass1, bass2, bass3, bass4, bass5 :: [Pitch] ;
bass =
  bass1 ++ bass2 ++ bass3 ++ bass4 ++ bass5 ;

bass1 = [
  c  5, g  5, c  5, g  5, f  4, c  5, f  4, c  5,
  g  4, d  5, g  4, d  5, f  4, g  4, c  5, g  4 ] ;

bass2 = [
  c  5, g  5, c  5, g  5, f  4, c  5, f  4, c  5,
  g  4, d  5, g  4, d  5, f  4, g  4, c  5, c  5 ] ;

bass3 = [
  d  5, a  4, d  5, a  4, d  5, a  4, d  5, a  4,
  c  5, g  4, c  5, g  4, fs 4, a  4, g  4, d  5 ] ;

bass4 = [
  c  5, g  5, c  5, g  5, d  5, a  4, d  5, a  4,
  f  4, c  5, g  4, d  5, f  4, g  4, c  5, g  4 ] ;


bass5a, bass5b, bass5c :: [Pitch] ;
bass5a = [
  c  5, g  5, c  5, g  5, d  5, a  4 ] ;

bass5b = [
  f  4, c  5 ] ;

bass5c = [
  f  4, c  5, b  4, e  5, g  4, d  5, c  5, g  4 ] ;

bass5 = bass5a ++ bass5b ++ bass5c ;

bass6 :: [Event Message] ;
bass6 = times 4 (note dn (c 5)) ;


flute1, flute2, flute3 :: [[Event Message]] ;
flute1 =
  map (emphasize (negate 20)) $
  chord3 dn (g 3) (c 4) (e 4) :
  chord3 dn (a 3) (c 4) (f 4) :
  chord3 dn (b 3) (d 4) (g 4) :
  chord3 hn (a 3) (c 4) (f 4) :
  chord3 hn (b 3) (d 4) (g 4) :
  chord3 wn (g 3) (c 4) (e 4) :
  [] ;

flute2 =
  note wn (d 4) : note wn (cs 4) : note wn (c 4) : note wn (b 3) :
  note wn (c 4) : note wn (e 4) : note wn (fs 4) : note wn (g 4) :
  [] ;

flute3prefetch :: Time ;
flute3prefetch = 3*sn ;

flute3 =
  note sn (d 4) : note sn (e 4) : note sn (fs 4) :
  note en (g 4) : rest en : note qn (fs 4) :
  note en (f 4) : note en (fs 4) : note en (f 4) : note en (e 4) :
  note en (ds 4) : rest en : note en (d 4) : rest en :
  note qn (cs 4) : note qn (d 4) :
  [] ;



rhythm :: [Event Message] ;
rhythm =
  (lowDrum hn ++ highDrum hn)
  =:=
  (rest qn ++ hihat (en+dev) ++ hihat (en-dev) ++
   rest qn ++ hihat (en+dev) ++ hihat (en-dev)) ;

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


rhythm0, rhythm1, rhythm6, rhythm7, rhythm8 :: [Event Message] ;
rhythm0 = times 4 rhythm ;
rhythm1 = times 8 rhythm ;
rhythm6 = times 16 (lowDrum hn) ;
rhythm7 = times 3 rhythm ++ lowDrum hn ;
rhythm8 = times 3 rhythm ++ times 8 (lowDrum hn) ++ times 1 rhythm ;

times :: Int -> [a] -> [a] ;
times n = concat . replicate n ;


-- * durations

dev, sn, en, den, qn, dqn, hn, ehn, wn, dn, ln :: Midi.Time ;

dev = 37 ;
sn = 75 ;
en = 2*sn ; den = 3*sn ;
qn = 2*en ; dqn = 3*en ;
hn = 2*qn ; ehn = 5*en ;
wn = 2*hn ;
dn = 2*wn ;
ln = 9*en ;


-- * configuration

{- Yamaha SY35

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


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


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


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

rhythmLoop = rhythmTrack ++ rhythmLoop ;

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 -}

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


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


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


fluteTrack :: [Event Message] -> [Event (Channel Message)] ;
fluteTrack xs =
  channel 3 $
  controller volumeCC 48 ++
  program 71 ++ transpose 12 xs ;


rhythmTrack :: [Event Message] -> [Event (Channel Message)] ;
rhythmTrack rhy =
  channel 9 rhy ;




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

lowDrum  dur = emphasize 30 (note dur 47) ;
highDrum dur = note dur 40 ; -- 77 ;


volumeCC :: Midi.Controller ;
volumeCC = 7 ;