module SilverLake where

import SilverLake.Chord
import SilverLake.Bass
import SilverLake.Drum

import Instrument
import Pitch
import Midi
import Prelude ( concat, replicate, (++), (-), (*), ($) )

main :: [Event (Channel Message)] ;
main = mergeMany $
    chordTrack en (harmoniesIntro ++ blockChords blocks) :
    drumTrack sn :
    bassTrack en (bassNotesIntro ++ blockBass blocks) :
    (rest dhn ++ blockMelody blocks) :
    [] ;

data Block =
    Block
        [Event (Channel Message)]
        [[Pitch]]
        [[Pitch]] ;

blockMelody :: Block -> [Event (Channel Message)] ;
blockMelody (Block melody _bass _chords) = melody ;

blockBass   :: Block -> [[Pitch]] ;
blockBass   (Block _melody bass _chords) = bass ;

blockChords :: Block -> [[Pitch]] ;
blockChords (Block _melody _bass chords) = chords ;

appendBlocks :: Block -> Block -> Block ;
appendBlocks (Block melody bass chord) future =
    Block
        (melody ++ blockMelody future)
        (bass   ++ blockBass   future)
        (chord  ++ blockChords future) ;

makeBlock :: Melody -> [[Pitch]] -> [[Pitch]] -> Block ;
makeBlock melody = Block (melodyTrack melody) ;

blocks, blockA, blockB,
    blockC, blockD, blockE :: Block ;

blockA = makeBlock melodyA bassNotesA harmoniesA ;
blockB = makeBlock melodyB bassNotesB harmoniesB ;
blockC = makeBlock melodyC bassNotesC harmoniesC ;
blockD = makeBlock melodyD bassNotesD harmoniesD ;
blockE = makeBlock melodyE bassNotesE harmoniesE ;

blocks =
    appendBlocks blockA $
    appendBlocks blockB $
    appendBlocks blockC $
    appendBlocks blockD $
    appendBlocks blockE $
    blocks ;

tn, sn, en, den, qn, hn, wn, dhn, dwn :: Time ;
tn = 85 ;
sn = 2 * tn ;
en = 2 * sn ; den = 3 * sn ;
qn = 2 * en ;
hn = 2 * qn ; dhn = 3 * qn ;
wn = 2 * hn ; dwn = 3 * hn ;

harmoniesIntro, harmoniesA, harmoniesB, harmoniesC, harmoniesD, harmoniesE :: [[Pitch]] ;
harmoniesIntro =
    [ c 4, e 4, g 4, c 5 ] :
    [] ;

harmoniesA =
    replicate 2 [ c 4, e 4, g 4, c 5 ] ++
    replicate 2 [ c 4, e 4, a 4, c 5 ] ++
    replicate 2 [ c 4, e 4, g 4, c 5 ] ++
    replicate 1 [ d 4, f 4, a 4, c 5 ] ++
    replicate 1 [ d 4, g 4, b 4, d 5 ] ++
    [] ;

harmoniesB =
    replicate 1 [ c 4, e 4, g 4, c 5 ] ++
    replicate 1 [ c 4, e 4, g 4, bf 4 ] ++
    replicate 1 [ c 4, f 4, a 4, c 5 ] ++
    replicate 1 [ d 4, f 4, a 4, d 5 ] ++
    replicate 1 [ c 4, e 4, g 4, c 5 ] ++
    replicate 1 [ c 4, f 4, a 4, c 5 ] ++
    replicate 2 [ c 4, e 4, g 4, c 5 ] ++
    [];

harmoniesC =
    replicate 2 [ c 4, e 4, g 4, c 5 ] ++
    replicate 2 [ d 4, f 4, a 4, c 5 ] ++
    replicate 2 [ d 4, g 4, b 4, d 5 ] ++
    replicate 1 [ c 4, e 4, g 4, c 5 ] ++
    replicate 1 [ c 4, e 4, g 4, bf 4 ] ++
    [] ;

harmoniesD =
    replicate 2 [ c 4, f 4, a 4, c 5 ] ++
    replicate 2 [ b 3, e 4, g 4, b 4 ] ++
    replicate 1 [ d 4, f 4, a 4, c 5 ] ++
    replicate 1 [ d 4, g 4, b 4, d 5 ] ++
    replicate 2 [ c 4, e 4, g 4, c 5 ] ++
    [] ;

harmoniesE =
    concat $ replicate 2 $
    replicate 1 [ c 4, e 4, g 4, c 5 ] ++
    replicate 1 [ d 4, g 4, b 4, d 5 ] ++
    replicate 1 [ c 4, e 4, a 4, c 5 ] ++
--    replicate 1 [ d 4, fs 4, a 4, d 5 ] ++
    replicate 1 [ d 4, g 4, b 4, d 5 ] ++
    [] ;

bassNotesIntro,
    bassNotesA, bassNotesB,
    bassNotesC, bassNotesD,
    bassNotesE :: [[Pitch]] ;
bassNotesIntro =
    [ c 2, c 2 ] :
    [];

bassNotesA =
    [ c 2, g 1 ] :
    [ c 2, c 2 ] :
    [ a 1, e 1 ] :
    [ a 1, a 1 ] :
    [ c 2, g 1 ] :
    [ c 2, c 2 ] :
    [ d 2, d 2 ] :
    [ g 1, g 1 ] :
    [];

bassNotesB =
    [ c 2, c 2 ] :
    [ bf 1, bf 1 ] :
    [ f 1, f 1 ] :
    [ d 2, d 2 ] :
    [ c 2, c 2 ] :
    [ f 1, g 1 ] :
    [ c 2, c 2 ] :
    [ c 2, c 2 ] :
    [];

bassNotesC =
    [ c 2, g 1 ] :
    [ c 2, c 2 ] :
    [ d 2, a 1 ] :
    [ d 2, d 2 ] :
    [ g 1, g 1 ] :
    [ g 1, g 1 ] :
    [ c 2, g 1 ] :
    [ c 2, c 2 ] :
    [];

bassNotesD =
    [ f 1, c 2 ] :
    [ f 1, f 1 ] :
    [ e 2, b 1 ] :
    [ e 2, e 2 ] :
    [ d 2, g 1 ] :
    [ d 2, g 1 ] :
    [ c 2, c 2 ] :
    [ c 2, c 2 ] :
    [];

bassNotesE =
    concat $ replicate 2 $
    [ c 2, c 2 ] :
    [ g 1, g 1 ] :
    [ a 1, d 2 ] :
    [ g 1, g 1 ] :
    [];


data Melody = Melody Instrument [Event Message] ;

melodyTrack :: Melody -> [Event (Channel Message)] ;
melodyTrack (Melody instr xs) = channel 1 (program instr ++ xs) ;

upA, upC, upD :: [Event Message] ;
upA = concat $
    note sn (g 4) : note tn (a 4) : note tn (b 4) :
    note tn (c 5) : note tn (d 5) : note tn (e 5) : note tn (f 5) :
    [] ;

vibnote :: Time -> Pitch -> [Event Message] ;
vibnote dur p =
   note dur p
   =:=
   ( Wait en :
     controller modulationCC 16 ++
     Wait en :
     controller modulationCC 32 ++
     Wait (dur-qn) :
     controller modulationCC 0 );

modulationCC :: Controller ;
modulationCC = 1 ;

melodyA, melodyB, melodyC, melodyD, melodyE :: Melody ;
melodyA = Melody stringEnsemble1 $ concat $
    upA           : note qn (g 5) : note wn  (e 5) : rest qn :
    note qn (g 5) : note qn (e 5) : note dwn (a 5) : rest qn :
    note qn (b 5) : note qn (g 5) : note wn  (e 5) : rest qn :
    note qn (a 5) : note qn (g 5) : note dwn (d 5) : rest qn :
    [] ;

melodyB = Melody stringEnsemble1 $ concat $
    upA           : note qn (g 5) : note wn (e 5) : rest qn :
    note qn (d 5) : note qn (c 5) : note qn (c 6) : note dwn (a 5) :
    note qn (f 5) : note dhn (g 5) :
    note qn (c 5) : note qn (d 5) : note qn (e 5) :
    note qn (c 5) : note qn (a 4) : note dwn (c 5) : rest qn :
    [] ;

upC = concat $
    note den (g 4) : note tn (a 4) : note tn (b 4) :
    [] ;

melodyC = Melody accordion $ concat $
    note qn (g 4) : vibnote dhn (c 5) :
    note qn (g 4) : note qn (c 5) : note qn (d 5) :
    note qn (e 5) : note qn (g 5) : vibnote dwn (d 5) : rest qn :
    note qn (g 4) : vibnote dhn (d 5) :
    note qn (g 4) : note qn (d 5) : note qn (e 5) :
    note qn (f 5) : note qn (g 5) : vibnote dwn (e 5) : rest qn :
    [] ;

upD = concat $
    note den (c 5) : note tn (d 5) : note tn (e 5) :
    [] ;

melodyD = Melody accordion $ concat $
    upD : vibnote dhn (f 5) :
    note qn (c 5) : note qn (f 5) : note qn (g 5) :
    note qn (a 5) : note qn (c 6) : note qn (b 5) : vibnote wn (g 5) : rest qn :
    note qn (a 5) : note qn (g 5) : vibnote dhn (d 5) :
    note qn (g 4) : note qn (d 5) : note qn (e 5) :
    note qn (c 5) : note qn (a 4) : vibnote dwn (c 5) : rest qn :
    [] ;

melodyE = Melody stringEnsemble1 $ concat $
    note qn (g 4) : note qn (g 5) : note hn (e 5) :
    note en (d 5) : note en (c 5) : note dhn (d 5) :
    note qn (g 4) : note qn (a 4) : note qn (c 5) :
    note qn (e 5) : note qn (fs 5) : note dhn (d 5) :

    note qn (g 4) : note qn (g 5) : note hn (e 5) :
    note en (d 5) : note en (c 5) : note dhn (d 5) :
    note qn (g 4) : note qn (a 4) : note qn (b 4) :
    note qn (g 4) : note qn (a 4) : note dhn (g 4) :
    [] ;