module Tomatensalat where

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


main :: [Midi.Event (Midi.Channel Midi.Message)] ;
main =
  (changeTempo tempoUnit $ channel 0 $
   cyclePrograms programs $
     transpose (3*12) melodyLoop
     =:=
     rest dhn +:+ transpose (2*12) chordLoop )
  ++
  main ;


-- * melody

melody, melodyLoop, melodyIntro,
  melodyA, melodyB0, melodyB1, melodyC :: [Midi.Event Midi.Message] ;
melody = melodyIntro ++ melodyA ++ melodyB1 ++ melodyC ;

melodyLoop = melody ++ melodyLoop ;

melodyIntro =
  note dhn (g 0) ++
  [] ;

melodyA =
  note  qn (c 1) ++
  note  qn (c 1) ++
  note  qn (c 1) ++
  note  qn (e 1) ++
  note  qn (d 1) ++
  note  qn (c 1) ++
  note  qn (d 1) ++
  note  qn (g 0) ++
  note  qn (g 0) ++
  note dhn (g 0) ++
  [] ;

melodyB0 =
  note  qn (c 1) ++
  note  qn (c 1) ++
  note  qn (c 1) ++
  note  qn (e 1) ++
  note  qn (d 1) ++
  note  qn (c 1) ++
  note dhn (g 1) ++
  note dhn (e 1) ++
  [] ;

melodyB1 =
  note  qn (d 1) ++
  note  qn (d 1) ++
  note  qn (d 1) ++
  note  qn (f 1) ++
  note  qn (e 1) ++
  note  qn (d 1) ++
  note dhn (g 1) ++
  note dhn (e 1) ++
  [] ;

melodyC =
  note  qn (f 1) ++
  note  qn (f 1) ++
  note  qn (f 1) ++
  note  qn (a 1) ++
  note  qn (g 1) ++
  note  qn (f 1) ++
  note  qn (e 1) ++
  note  qn (e 1) ++
  note  qn (e 1) ++
  note  qn (g 1) ++
  note  qn (f 1) ++
  note  qn (e 1) ++
  note  qn (d 1) ++
  note  qn (d 1) ++
  note  qn (d 1) ++
  note  qn (f 1) ++
  note  qn (e 1) ++
  note  qn (d 1) ++
  note dhn (c 1) ++
  [] ;


-- * chord

{-
introChords =
  chord (c 1)  (e 1) (g 1) :
  chord (g 0)  (e 1) (g 1) :
  chord (c 1)  (e 1) (g 1) :
  chord (g 0)  (e 1) (g 1) :
  []
-}

chords, chordLoop :: [Midi.Event Midi.Message] ;
chordLoop = chords ++ chordLoop ;
chords =
  concat $
  chord3 dhn (c 1)  (e 1) (g 1) :
  chord3 dhn (g 0)  (e 1) (g 1) :
  chord3 dhn (b 0)  (d 1) (g 1) :
  chord3 dhn (g 0)  (d 1) (g 1) :
  chord3 dhn (b 0)  (f 1) (g 1) :
  chord3 dhn (g 0)  (f 1) (g 1) :
  chord3 dhn (c 1)  (e 1) (g 1) :
  chord3 dhn (g 0)  (g 1) (as 1) :
  chord3 dhn (c 1)  (f 1) (a 1) :
  chord3 dhn (a 0)  (f 1) (a 1) :
  chord3 dhn (c 1)  (e 1) (g 1) :
  chord3 dhn (cs 1) (e 1) (a 1) :
  chord3 dhn (b 0)  (d 1) (g 1) :
  chord3 dhn (g 0)  (d 1) (g 1) :
  chord3 dhn (c 1)  (e 1) (g 1) :
  chord3 dhn (g 0)  (e 1) (g 1) :
  [] ;


-- * cycle programs

{-
It assumes that there are no

* Wait 0 and

* no adjacent Waits

The way we construct the melody this is always satisfied.
If not, we could easily normalize the stream.
-}
cyclePrograms ::
  [Program] ->
  [Midi.Event Midi.Message] ->
  [Midi.Event Midi.Message] ;
cyclePrograms (p:ps) (Wait n : evs) =
  Wait n : program p ++ cyclePrograms ps evs ;
cyclePrograms ps (ev:evs) =
  ev : cyclePrograms ps evs ;
cyclePrograms _ evs = evs ;

programs :: [Program] ;
programs = 13 : 14 : 15 : 16 : 17 : programs ;


-- * time & tempo

qn, dhn :: Time ;
qn = 1 ;
dhn = 3 ;

tempoUnit :: Time ;
tempoUnit = 250 ;