module BlueMonday where

import SynthiLLVM
import Pitch
import Midi
import List ( (++), concatMap, concat, replicate )
import Prelude ( Int, (*), (-), ($) )


main, loop :: [Midi.Event (Midi.Channel Midi.Message)] ;
main = loop ;

loop =
   blockA ++ blockB ++
   loop ;

blockA, blockB :: [Midi.Event (Midi.Channel Midi.Message)] ;
blockA  = block bassA patternA ;
blockB  = block bassB patternB ;

block ::
   [Midi.Event Midi.Message] ->
   [Midi.Event Midi.Message] ->
   [Midi.Event (Midi.Channel Midi.Message)] ;
block bass pattern =
   bassTrack (transpose 2 bass) =:=
   patternTrack (transpose 14 pattern) ;

patternTrack, bassTrack ::
   [Midi.Event Midi.Message] ->
   [Midi.Event (Midi.Channel Midi.Message)] ;
patternTrack body =
   patternChannel $ slapSetup ++ body ;

patternA, patternB :: [Event Message] ;
patternA = patternGen (f 3) (g 3) ;
patternB = patternGen (g 3) (a 3) ;

patternGen :: Pitch -> Pitch -> [Event Message] ;
patternGen p0 p1 =
   note en p0 ++ note en p0 ++ note en p0 ++
   note en p1 ++
   note en (c 3) ++ note en (c 3) ++ note en (c 3) ++
   note en (d 3) ++
   note en (d 3) ++ note en (d 3) ++
   rest en ++
   note en (d 3) ++ note en (d 3) ++
   rest en ++
   note en (d 3) ++ note en (d 3) ++
   [] ;


bassTrack body =
   bassChannel $ bassSetup ++ body ;

bassA, bassB :: [Midi.Event Midi.Message] ;

bassA =
   bassPattern (f 2) ++
   bassPattern (c 2) ++
   double (bassPattern (d 2)) ;

bassB =
   bassPattern (g 2) ++
   bassPattern (c 2) ++
   double (bassPattern (d 2)) ;

bassPattern :: Pitch -> [Event Message] ;
bassPattern p0 =
   concatMap (note en) [p0-12, p0, p0-12, p0] ;


-- * concatenation

rep :: Int -> [a] -> [a] ;
rep n x  =  concat $ replicate n x ;

double :: [a] -> [a] ;
double x  =  x ++ x ;

quad :: [a] -> [a] ;
quad x  =  x ++ x ++ x ++ x ;

quadAlt :: [a] -> [a] -> [a] ;
quadAlt x y  =  x ++ x ++ x ++ y ;


-- * durations

en, qn, dqn, hn, dhn, wn, dwn, wn2 :: Midi.Time ;

en = 240 ;
qn = 2 * en ; dqn = 3 * en ;
hn = 2 * qn ; dhn = 3 * qn ;
wn = 2 * hn ; dwn = 3 * hn ;
wn2 = 2 * wn ;


-- * MIDI program

slapSetup, bassSetup :: [Event Message] ;
slapSetup =
   program slap ++
   controller decayCC 120 ++
   controller releaseCC 40 ++
   controller volumeCC 70 ++
   controller brightnessCC 100 ++
   controller filterDecayCC 124 ++
   [] ;

bassSetup =
   program ping ++
   controller decayCC 30 ++
   controller releaseCC 30 ++
   controller volumeCC 70 ++
   controller brightnessCC 50 ++
   [] ;


-- * MIDI channels

melodyChannel, patternChannel, chordChannel, bassChannel
   :: [Midi.Event a] -> [Midi.Event (Midi.Channel a)] ;

melodyChannel  = channel 0 ;
patternChannel = channel 1 ;
chordChannel   = channel 2 ;
bassChannel    = channel 3 ;