module GloriousKingdom where

import Instrument
import Drum
import Chords
import Pitch
import Midi
import List
import ListLive ( iterateInteger )
import Function ( flip )
import Prelude
          ( Num, Integer, Int, negate, div, (+), (-), (*),
            ($), (.) ) ;


main, prelude, verseStart, verse12, verse3
   :: [Midi.Event (Midi.Channel Midi.Message)] ;
main =
   prelude ++
   verseStart ++ verse12 ++
   verseStart ++ verse12 ++
   verseStart ++ verse3 ;

prelude =
   block [] (rest ddn ++ fillin0)
      (abba marimbaPattern0 marimbaPattern1)
      (abba bassPattern0 bassPattern1) ;

verseStart =
   block0 bassPattern0 (drum crashCymbal1 hn) (rest ddn ++ fillin1)
   ++
   block0 (doubleDeep heCame) (drum crashCymbal1 hn) []
   ++
   block
      (steelDrumChannel melodyA3)
      (drum crashCymbal1 hn)
      (aaaa marimbaPattern0)
      (doubleDeep $ downHeCame +:+ downHeCame)
   ++
   block
      (steelDrumChannel melodyA4)
      (rest ddn ++ fillin2)
      (aaaa marimbaPattern0)
      (doubleDeep $ downHeCame +:+ downPeriod)
   ;

verse12 =
   block
      (trumpetChannel melodyB0)
      (rhythm0 6 =:= drum crashCymbal1 hn)
      (bababa marimbaPattern0 marimbaPattern2)
      (bababa bassPattern0 bassPattern2)
   ++
   block
      (trumpetChannel melodyB1)
      (rhythm0 3 =:= (rest dn ++ fillin0))
      (aaa marimbaPattern0)
      (aaa bassPattern0) ;

verse3 =
   block
      (trumpetChannel melodyB2)
      (rhythm0 6 =:= drum crashCymbal1 hn)
      (bababa marimbaPattern0 marimbaPattern2)
      (bababa bassPattern0 bassPattern2)
   ++
   ritardando 20 (iterateInteger (inc 1) 20)
      (block (trumpetChannel melodyB3) [] [] bassTrailer) ;

block ::
   [Event (Channel Message)] ->
   [Event Message] ->
   [Event Message] ->
   [Event Message] ->
   [Event (Channel Message)] ;
block melody rhythm pattern bass =
   melody
   =:=
   drumChannel rhythm
   =:=
   patternChannel (
      program xylophone ++
      pattern
   )
   =:=
   bassChannel (
      controller volumeCC 100 ++
      program synthBass1 ++
      bass
   ) ;

steelDrumChannel, trumpetChannel
   :: [Event Message] -> [Event (Channel Message)] ;
steelDrumChannel melody =
   melodyChannel (
      controller volumeCC 80 ++
      program steelDrums ++
      melody
   ) ;

trumpetChannel melody =
   melodyChannel (
      controller volumeCC trumpetVolume ++
      program trumpet ++
      melody
   ) ;

crescendo :: [Event Message] -> [Event Message] ;
crescendo melody =
   ( melody =:=
     ( concatMap (addPause (div dhn 10) . controller volumeCC) $
       take 10 (iterateInteger (inc 6) 60) ) )
   ++
   controller volumeCC trumpetVolume ;

type Volume = Integer ;

trumpetVolume :: Volume ;
trumpetVolume = 80 ;

inc :: (Num a) => a -> a -> a ;
inc dv v = dv + v ;

addPause :: Time -> [Event a] -> [Event a] ;
addPause dur evs = evs ++ [ Wait dur ] ;


ritardando :: Integer -> [Integer] -> [Event a] -> [Event a] ;
ritardando denom (num : nums) (Wait dur : evs) =
   Wait (div (dur * num) denom) : ritardando denom nums evs ;
ritardando denom nums (event : evs) =
   event : ritardando denom nums evs ;
ritardando _denom _nums evs = evs ;


block0 ::
   [Event Message] ->
   [Event Message] ->
   [Event Message] ->
   [Event (Channel Message)] ;
block0 extraBass rhy0 rhy1 =
   block
      (steelDrumChannel $ melodyA0 ++ melodyA1)
      (rhythm0 4 =:= rhy0)
      (abba marimbaPattern0 marimbaPattern1)
      (abba bassPattern0 bassPattern1)
   ++
   block
      (steelDrumChannel melodyA2)
      (rhythm0 4 =:= rhy1)
      (acba marimbaPattern0 marimbaPattern1 marimbaPattern2)
      (acb bassPattern0 bassPattern1 bassPattern2 ++ extraBass)
   ;

melodyA0, melodyA1, melodyA2, melodyA3, melodyA4
   :: [Midi.Event Midi.Message] ;

melodyA0 =
   notes [g 4, b 4, d 5, g 5] [qn, en, qn, en] ++
   notes [d 4, b 4, d 5, a 5] [en] ++
   notes [d 4, b 4, d 5, g 5] [en] ++
   rest en ++
   notes [a 4, c 5, d 5, fs 5] [qn] ++
   notes [d 4, c 5, fs 5, a 5] [en] ++
   notes [d 4, c 5, d 5] [hn] ++
   [] ;

melodyA1 =
   notes [d 4, d 5, fs 5, c 6] [qn, en] ++
   notes [e 4, e 5, g 5, c 6] [qn, en] ++
   notes [fs 4, e 5, a 5, c 6] [en, en] ++
   rest en ++
   notes [g 4, d 5, g 5, b 5] [qn] ++
   notes [g 3, g 4, d 5, g 5, b 5] [en] ++
   notes [g 3, g 4, b 4, d 5, g 5] [hn] ++
   [] ;

melodyA2 =
   notes [g 4, b 4, g 5, d 6] [qn, en] ++
   notes [g 4, d 5, b 5, f 6] [qn, en, en, en] ++
   rest en ++
   notes [c 4, c 5, g 5, e 6] [qn] ++
   notes [b 3, c 5, g 5, e 6] [en] ++
   notes [a 3, e 5, g 5, c 6] [qn] ++
   notes [c 4, e 5, a 5, c 6] [en] ++
   notes [c 4, e 5, g 5, c 6] [en] ++
   notes [d 4, c 5, fs 5, a 5] [qn, en, en, qn, qn] ++
   rest qn ++
   notes [g 4, b 4, d 5, g 5] [qn, qn] ++
   rest qn ++
   [] ;


melodyA3 =
   rest qn ++
   notes [b 4, d 5, g 5] [en, qn, qn, en, dqn] ++
   notes [d 5, g 5, b 5] [en+hn] ++
   rest qn ++
   notes [d 5, g 5, b 5] [en, qn, qn] ++
   notes [b 4, d 5, g 5] [en] ++
   notes [d 5, g 5, b 5] [en, en, en] ++
   notes [b 4, d  5, g 5] [en] ++
   notes [c 5, fs 5, a 5] [qn] ++
   notes [b 4, d  5, g 5] [qn] ++
   [] ;

melodyA4 =
   rest qn ++
   notes [b 4, d 5, g 5] [en, qn, qn, en] ++
   notes [c 5, e 5, g 5] [dqn] ++
   notes [d 5, g 5, b 5] [en+hn] ++
   rest qn ++
   notes [d 5, g 5, b 5] [en, qn] ++
   notes [c 5, g 5, b 5] [qn] ++
   notes [b 4, d 5, g 5] [en] ++
   notes [d 5, g 5, b 5] [en, en, en] ++
   notes [b 4, d  5, g 5] [en] ++
   notes [c 5, fs 5, a 5] [qn] ++
   notes [b 4, d  5, g 5] [qn] ++
   [] ;


melodyB0 :: [Event Message] ;
melodyB0 =
   melodyB0part [] [] ++
   melodyB0part [] [] ++
   melodyB0part [bf 5] [b 5] ++
   [] ;

melodyB0part :: [Pitch] -> [Pitch] -> [Event Message] ;
melodyB0part p0 p1 =
   rest qn ++
   crescendo (notes ([c 4, c 5, g 5, e 6] ++ p0) [dhn]) ++
   notes ([g 4, b 4, g 5, d 6] ++ p1) [en] ++ rest qn ++
   notes [g 4, d 5, g 5, b 5] [en, qn] ++
   notes [g 4, b 4, d 5, g 5] [qn] ++
   [] ;

melodyB1 :: [Event Message] ;
melodyB1 =
   rest qn ++
   notes [g 4, d 5, g 5, b 5] [en, qn, qn] ++
   notes [g 4, b 4, d 5, g 5] [en] ++
   notes [g 4, d 5, g 5, b 5] [en, en] ++
   (note qn (g 4) =:=
      notes [d 5, g 5, b 5] [en] +:+
      notes [b 4, d 5, g 5] [en]) ++
   notes [d 4, c 5, fs 5, a 5] [qn] ++
   notes [g 3, b 4, d  5, g 5] [qn] ++
   rest wn ++
   [] ;


melodyB2 :: [Event Message] ;
melodyB2 =
   rest qn ++
   crescendo (notes [c 4, c 5, g  5, e 6] [dhn]) ++
   notes [d 4, b 4, g  5, d 6] [en] ++ rest qn ++
   notes [d 4, d 5, fs 5, b 5] [en] ++
   notes [d 4, c 5, e  5, b 5] [qn] ++
   notes [d 4, b 4, d  5, g 5] [qn] ++

   rest qn ++
   crescendo (notes [c 4, bf 4, g  5, c 6, e 6] [dhn]) ++
   notes [d 4, b  4, g  5, b 5, d 6] [en] ++ rest qn ++
   notes [d 4, d  5, fs 5, a 5, b 5] [en] ++
   notes [d 4, c  5, e  5, g 5, b 5] [qn] ++
   notes [d 4, b  4, d  5, g 5] [qn] ++

   rest qn ++
   crescendo (notes [d 4, c 5, g  5, bf 5, e 6] [dhn]) ++
   notes [g 4, d 5, g  5, b  5, d 6] [en] ++ rest qn ++
   notes [g 4, d 5, fs 5, a  5, b 5] [en] ++
   notes [g 4, c 5, e  5, g  5, b 5] [qn] ++
   notes [g 4, b 4, d  5, g  5] [qn] ++
   [] ;

melodyB3 :: [Event Message] ;
melodyB3 =
   rest qn ++
   notes [g 4, b 4, d 5, g 5, b 5] [en, qn] ++
   notes [e 4, b 4, d 5, g 5, b 5] [qn] ++
   notes [e 4, b 4, d 5, g 5] [en] ++
   notes [c 4, a 4, e 5, g 5, b 5] [en, en] ++
   (notes [c 4, a 4, e 5] [qn] =:=
    (note en (g 5) +:+ note en (g 5)
     =:=
     note en (b 5))) ++
   notes [d 4, c 5, d 5, fs 5, a 5] [qn] ++
   notes [g 3, g 4, b 4, d 5, g 5] [wn] ++
   rest qn ++
   [] ;


notes :: [Pitch] -> [Time] -> [Event Message] ;
notes ps durs =
   concatMap (flip chord ps) durs ;


marimbaPattern0, marimbaPattern1, marimbaPattern2
   :: [Midi.Event Midi.Message] ;

marimbaPattern0 =
   marimbaPattern (g 4) (e 4) (d 4) ;

marimbaPattern1 =
   marimbaPattern (fs 4) (e 4) (d 4) ;

marimbaPattern2 =
   marimbaPattern (e 4) (d 4) (c 4) ;

marimbaPattern ::
  Pitch -> Pitch -> Pitch ->
  [Midi.Event Midi.Message] ;
marimbaPattern p0 p1 p2 =
   rest en ++
   note qn p0 ++ note en p0 ++
   note en p0 ++ note en p0 ++
   note en p1 ++ note en p2 ;


bassPattern0, bassPattern1, bassPattern2
   :: [Midi.Event Midi.Message] ;

bassPattern0 =
   bassPattern (g 2) (b 2) (d 3) ;

bassPattern1 =
   bassPattern (d 2) (fs 2) (a 2) ;

bassPattern2 =
   bassPattern (c 2) (e 2) (g 2) ;

bassPattern ::
  Pitch -> Pitch -> Pitch ->
  [Midi.Event Midi.Message] ;
bassPattern p0 p1 p2 =
   note dqn p0 ++ note dqn p1 ++ note qn p2 ;

heCame, downHeCame, downPeriod :: [ Event Message ] ;
heCame =
   rest (hn+en) ++ note en (d 4) ++ note qn (d 4) ;

downHeCame =
   note dwn (g 3) ++ rest en ++ note en (d 4) ++ note qn (d 4) ;

downPeriod =
   note dwn (g 3) ++ rest hn ;

doubleDeep :: [Event Message] -> [Event Message] ;
doubleDeep evs =
   transpose (negate 12) evs
   =:=
   transpose (negate 24) evs ;

bassTrailer :: [Event Message] ;
bassTrailer =
   rest qn ++
   note dqn (g 2) ++
   note dqn (e 2) ++
   note hn  (c 2) ++
   note qn  (d 2) ++
   note wn  (g 1) ++
   rest qn ++
   [] ;


fillin0 :: [Event Message] ;
fillin0 =
   rest (hn-en) ++
   timb2 sn ++ timb1 sn ++
   timb0 den ++ timb0 den ++ timb0 en ++
   [] ;

fillin1 :: [Event Message] ;
fillin1 =
   timb0 dqn ++ timb0 dqn ++ timb0 qn ++ [] ;

fillin2 :: [Event Message] ;
fillin2 =
   rest hn ++
   timb0 en ++ timb2 sn ++ timb1 sn ++
   timb0 en ++ timb0 en ++ [] ;


timb2, timb1, timb0 :: Time -> [Event Message] ;
timb2 dur = emphasize (negate 20) (drum highTimbale dur) ;
timb1 dur = emphasize (negate 10) (drum highTimbale dur) ;
timb0 dur = drum highTimbale dur ;


rhythm0 :: Int -> [Event Message] ;
rhythm0 n =
   concat $ take n $ cycle [rhythm0a, rhythm0b] ;

rhythm0a, rhythm0b :: [Event Message] ;
rhythm0a =
   drum lowBongo dqn ++ drum lowConga qn ++
   drum lowConga en  ++ drum lowConga qn ++
   [] ;

rhythm0b =
   drum lowBongo dqn ++ drum lowConga qn ++
   drum lowConga en ++ drum lowConga en ++ drum lowConga en ++
   [] ;



aaa :: [a] -> [a] ;
aaa pa =
   pa ++ pa ++ pa ;

aaaa :: [a] -> [a] ;
aaaa pa =
   pa ++ pa ++ pa ++ pa ;

abba :: [a] -> [a] -> [a] ;
abba pa pb =
   pa ++ pb ++ pb ++ pa ;

bababa :: [a] -> [a] -> [a] ;
bababa pa pb =
   pb ++ pa ++ pb ++ pa ++ pb ++ pa ;

acba :: [a] -> [a] -> [a] -> [a] ;
acba pa pb pc =
   pa ++ pc ++ pb ++ pa ;

acb :: [a] -> [a] -> [a] -> [a] ;
acb pa pb pc =
   pa ++ pc ++ pb ;


-- * durations

sn, en, den, qn, dqn, hn, dhn, wn, dwn, dn, ddn :: Time ;

sn = 85 ;
en = 2 * sn ; den = 3 * sn ;
qn = 2 * en ; dqn = 3 * en ;
hn = 2 * qn ; dhn = 3 * qn ;
wn = 2 * hn ; dwn = 3 * hn ;
dn = 2 * wn ; ddn = 3 * wn ;


-- * MIDI channels

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

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


-- * MIDI controllers

volumeCC :: Midi.Controller ;
volumeCC = 7 ;


{-
Spiritual
based on arrangement by Wolfgang Kleber

Lyrics:

1.
Virgin Mary had a baby boy,
Virgin Mary had a baby boy,
Virgin Mary had a baby boy
and they say that his name was Jesus.

He came from the Glory,
he came from the Glorious Kingdom.
He came from the Glory,
he came from the Glorious Kingdom.

Oh, yes, believe us!
Oh, yes, believe us!
Oh, yes, believe us!
He came from the Glorious Kingdom.

2.
Was born in a town called Bethlehem ... and they say ...

3.
Sent to us from our father above ... and they say ...
-}