module TausendSterne where

import SynthiLLVM
import Midi
import Pitch
import Chords
import Bool
import List ( concat, concatMap, zipWith, cycle, (++), replicate )
import Prelude
          ( Bool(False, True),
            Integer, Int, fromIntegral, (+), (-), (*), div,
            id, ($), (.) )

main :: [Event (Channel Message)] ;
main =
  channel 0
    (program star ++
     controller brightnessCC 127 ++
     controller timbreCC 110 ++
     melody ++ melody ++ melody ++ [])
  =:=
  channel 1
    (program pad ++
     controller brightnessCC 24 ++
     controller attackCC 120 ++
     controller releaseCC 127 ++
     chordsA ++ chordsA ++
     program synthString ++
     controller brightnessCC 100 ++
     controller attackCC 80 ++
     controller releaseCC 100 ++
     chordsB ++
     controller releaseCC 127 ++
     chord3 wn (c 4) (e 4) (g 4) ++
     [])
  =:=
  channel 2
    (program bassString ++
     controller brightnessCC 100 ++
     controller volumeCC 115 ++
     rest (8*wn) ++ bass False ++ bass True ++
     note wn (c 2) ++
     [])
  =:=
  channel 3
    (program bell ++
     controller releaseCC 120 ++
     controller brightnessCC 30 ++
     controller timbreCC 60 ++
     rest (8*wn) ++ bellMelody ++
     [])
  ;

melody :: [Event Message] ;
melody =
  concat $
  dnote qn (e 4) : dnote qn (g 4) : dnote qn (a 4) : note dqn (e 4) :
  note en (e 4) : dnote qn (g 4) : dnote qn (c 5) : dnote qn (f 5) : note dqn (d 5) :
  note en (d 5) : note qn (e 5) : note en (d 5) : note en (e 5) : dnote qn (c 5) :
  note qn (d 5) : note en (c 5) : note en (d 5) : note qn (b 4) :
  note qn (e 4) : dnote qn (a 4) : dnote qn (c 5) :
  note en (d 5) : note en (c 5) : note qn (b 4) : note hn (c 5) :
  [] ;

dnote :: Time -> Pitch -> [Event Message] ;
dnote dur p =
  note dur p ++ note dur p ;


bellMelody :: [Event Message] ;
bellMelody =
  concatMap triplet $
  zipWith id (cycle [id, transposeTriple 12]) $
  concatMap replicateTriple $
  harmonies False ;


data Triple = Triple Pitch Pitch Pitch ;

replicateTriple :: RepTriple -> [Triple] ;
replicateTriple (RepTriple n p0 p1 p2) =
  replicate n $ Triple p0 p1 p2 ;

transposeTriple :: Integer -> Triple -> Triple ;
transposeTriple n (Triple p0 p1 p2) =
  Triple (p0+n) (p1+n) (p2+n) ;

triplet :: Triple -> [Event Message] ;
triplet (Triple p0 p1 p2) =
  note tqn p0 ++ note tqn p1 ++ note tqn p2 ;


chordsA :: [Event Message] ;
chordsA =
  concatMap achord3 $ harmonies False ;

achord3 :: RepTriple -> [Event Message] ;
achord3 (RepTriple n p0 p1 p2) =
  chord3 (fromIntegral n * qn) p0 p1 p2 ;

chordsB :: [Event Message] ;
chordsB =
  merge chordTimbre $ concatMap dchord3 $ harmonies True ;

dchord3 :: RepTriple -> [Event Message] ;
dchord3 (RepTriple n p0 p1 p2) =
  concat $
  replicate n (chord3 en p0 p1 p2 ++ rest en) ;

chordTimbre :: [Event Message] ;
chordTimbre =
  concatMap (addRest qn . controller timbreCC) $
  concat $
  replicate 4 [127, 112, 96, 80, 64, 80, 96, 112] ;

addRest :: Time -> [Event a] -> [Event a] ;
addRest dur xs = xs ++ rest dur ;


data RepTriple = RepTriple Int Pitch Pitch Pitch ;

harmonies :: Bool -> [RepTriple] ;
harmonies var =
  RepTriple 2 (c 4) (e 4) (g 4) :
  RepTriple 2 (b 3) (d 4) (g 4) :
  RepTriple 2 (c 4) (e 4) (a 4) :
  RepTriple 2 (b 3) (e 4) (g 4) :

  RepTriple 2 (c 4) (e 4) (g 4) :
  RepTriple 2 (c 4) (e 4) (a 4) :
  RepTriple 2 (d 4) (f 4) (a 4) :
  RepTriple 2 (b 3) (d 4) (g 4) :

  RepTriple 2 (b 3) (e 4) (g 4) :
  RepTriple 2 (c 4) (f 4) (a 4) :
  RepTriple 2 (d 4) (f 4) (a 4) :
  ifThenElse var
     (RepTriple 2 (b 3) (e 4) (gis 4))
     (RepTriple 2 (d 4) (g 4) (b 4)) :

  RepTriple 2 (c 4) (f 4) (a 4) :
  RepTriple 2 (c 4) (e 4) (g 4) :
  RepTriple 1 (d 4) (f 4) (a 4) :
  RepTriple 1 (d 4) (g 4) (b 4) :
  RepTriple 2 (c 4) (e 4) (g 4) :
  [] ;


bass :: Bool -> [Event Message] ;
bass var =
  concat $
  note hn (c 2) : note hn (g 1) : note hn (a 1) : note hn (e 1) :
  note hn (c 2) : note hn (a 1) : note hn (d 2) : note hn (g 1) :
  note hn (e 1) : note hn (f 1) : note hn (d 1) :
    ifThenElse var (note hn (e 1)) (note hn (g 1)) :
  note hn (f 1) : note hn (c 2) : note qn (d 2) : note qn (g 1) : note hn (c 2) :
  [] ;

en, qn, dqn, hn, wn, tqn :: Time ;
en = 420 ;
qn = 2 * en ; dqn = 3 * en ; tqn = div qn 3 ;
hn = 2 * qn ;
wn = 2 * hn ;