module Haskore.Example.Kantate147 where

{- Kantate 147 by Johann Sebastian Bach -}

import qualified Haskore.Basic.Pitch as Pitch
import qualified Haskore.Basic.Tempo as Tempo
import qualified Haskore.Music as Music
import           Haskore.Music (line, chord, (=:=))
import qualified Haskore.Melody   as Melody
import qualified Haskore.Music.GeneralMIDI as MidiMusic

import qualified Haskore.Performance.Context as Context

import qualified Haskore.Interface.MML as MML
import qualified Media.ContextFreeGrammar as Grammar
import qualified Haskore.General.MarkovChain as MarkovChain

import qualified Haskore.Interface.MIDI.File         as MidiFile
import qualified Haskore.Interface.MIDI.InstrumentMap as InstrumentMap
import qualified Haskore.Interface.MIDI.Write        as WriteMidi
import qualified Haskore.Interface.MIDI.Save         as SaveMidi
import qualified Haskore.Interface.MIDI.General      as GeneralMidi

import           Data.Ratio((%))
import qualified Data.List as List

import           Control.Monad.State
import           System.Random (mkStdGen, split)


initOctaves :: [Pitch.Octave]
initOctaves = [1, 0, 2, 2]

songMML :: [(String, String, String, String)]
songMML = [
  ("l2g>ge",       "l2p2de",           "l2p2l6g3f#g3a",   "l6p6gab>dcced"),
  ("<b>e<e",       "ge<b",             "b3ab3ge3d",       "dgf#gd<bgab"),
  ("ab>c",         "a>dc",             "e3f#g3de3<b",     ">cdedc<babg"),
  ("df#d",         "c<a>f#",           "a3>da3ga3f#",     "f#gadf#a>c<ba"),
  ("gec",          "g<g>e",            "d3f#g3f#g3a",     "bgab>dcced"),
  ("<b>ed",        "ge<b",             "b3ab3ge3g",       "dgf#gd<bgab"),
  ("cc#d",         ">ced",             "a3f#g3e<a3>c",    "e>dc<bagdgf#"),
  ("<gp3>g6d3<b6", "dp2b3g6",          "<b3>gb3>dg3d",    "gb>dgd<bgb>d"),
  ("g>f#e",        "d<gg",             "l2<g1g",          "l2<b1>c"),
  ("f#ed",         "agf#",             "a1b",             "d1d"),
  ("ef#g",         "gag",              "bag",             "c1<b"),
  ("dp3d6d3d6",    "f#a3a6>d3d6",      "al6d3ef#3g",      "l6adef#aga>c<b"),
  ("<d>p3d6d3d6",  "f#3a6f#3d6<a3>d6", "a3>c<a3f#d3f#",   ">c<af#df#a>c<ba"),
  ("gf#e",         "dde",              "g3dg3f#g3a",      "bgab>dcced"),
  ("b<b>e",        "gd<b",             "b3ag3f#e3g",      "dgf#gd<bgab"),
  ("cd<d",         "l4>c<a>d<b>c<al2", "a3gf#3ga3c",      "e>dc<bagdgf#"),
  ("g>ge",         "b>de",             "<b3>dg3f#g3a",    "gbab>dcced"),
  ("<b>e<e",       "ge<b",             "b3ab3ge3d",       "dgf#gd<bgab"),
  ("ab>c",         "a>dc",             "e3f#g3de3<b",     ">cdedc<babg"),
  ("df#d",         "c<a>f#",           "a3>f#a3ga3f#",    "f#gadf#a>c<ba"),
  ("gec",          "g<g>e",            "d3f#g3f#g3a",     "bgab>dcced"),
  ("<b>ed",        "ge<b",             "b3ab3ge3g",       "dgf#gd<bgab"),
  ("cc#d",         ">ced",             "a3f#g3e<a3>c",    "e>dc<bagdgf#"),
  ("<g>f#e",       "d<gg",             "l2b1>c",          "l2g1g"),
  ("f#ed",         "agf#",             "d1d",             "a1b"),
  ("ef#g",         "gag",              "c1<b",            "bag"),
  ("dp3d6d3d6",    "f#l6a3a>d3d",      "al6d3ef#3g",      "l6ddef#aga>c<b"),
  ("<dp3>d6d3d6",  "f#3af#3d<a3>d",    "a3>c<a3f#d3f#",   ">c<af#df#a>c<ba"),
  ("gf#e",         "l2dde",            "l2b1>c",          "bgab>dcced"),
  ("b<b>e",        "gd<b",             "d1<b",            "dgf#gd<bgab"),
  ("cd<d",         "l4>c<a>d<b>c<a",   "a4b8>c8<ba",      "e>dc<bagdgf#"),
  ("g>ge",         "l2b>de",           "l6g3dg3f#g3a",    "gbab>dcced"),
  ("<b>e<e",       "ge<b",             "b3ab3ge3d",       "dgf#gd<bgab"),
  ("ab>c",         "a>dc",             "e3f#g3de3<b",     ">cdedc<babg"),
  ("df#d",         "c<a>f#",           "a3>da3ga3f#",     "f#gadf#a>c<ba"),
  ("gec",          "g<g>e",            "d3f#g3f#g3a",     "bgab>dcced"),
  ("<b>ed",        "ge<b",             "b3ab3ge3g",       "dgf#gd<bgab"),
  ("cc#d",         ">ced",             "a3f#g3e<a3>c",    "e>dc<bagdgf#"),
  ("<gp3>g6f#3e6", "dp3g6d3e6",        "<b3>gb3>dg3<g",   "gb>dgd<bdb>c#"),
  ("dc<b",         "f#dd",             "l2a1b",           "d<def#ag#g#ba"),
  ("a>a4g4f4e4",   "e<a>a",            ">c1c",            "a>c<b>c<aecde"),
  ("d<b>e",        "aag#",             "<bb4>c8d8<b",     "f>dcd<bg#ef#g#"),
  ("a>fd",         "e<a>f#",           "al6a3g#a3b",      "a>c<b>ceddfe"),
  ("cfe",          "afc",              ">c3<b>c3<af3a",   "eag#aec<ab>c"),
  ("dd#e",         "df#e",             "a3g#a3f#<b3>d",   "fedc<baeag#"),
  ("<a>ab",        "c<ag",             ">l2c1d",          "a>ceap3l2d"),
  (">c<ae",        ">cag",             "e1e",             "l6ecdegfgb-a"),
  ("fdg",          "df#g",             "dd4e8f8d",        "a>c<b>c<afdef"),
  ("cec",          "geg",              "l6c3<g>c3<ge3d",  "egfgec<gab-"),
  ("fdg",          "fag",              "c3ef3ab3>d",      "a>c<b>c<afdef"),
  ("cp3c6<b3>d6",  "gp3d6d3d6",        "c3<g>c3<a>d3<f#", "ecdegf#gba"),
  ("<g>ge",        "dde",              "l2b1>c",          "bgab>dcced"),
  ("<b>e<e",       "ge<b",             "d1d",             "dgf#gd<bgab"),
  ("ab>c",         "a>dc",             "c<b1",            ">cdedc<babg"),
  ("dp3d6d3d6",    "cl6<a3a>d3d",      "l6a3c#d3ef#3g",   "f#def#aga>c<b"),
  ("<dp3>d6d3d6",  "f#3af#3d<a3>d",    "a3>c<a3f#d3f#",   ">c<af#df#a>c<ba"),
  ("gf#e",         "l2dde",            "l2b1>c",          "bgab>dcced"),
  ("b<b>e",        "gd<b",             "d1<b",            "dgf#gd<bgab"),
  ("cd<d",         "l4>c<a>d<b>c<a",   "a4b8>c8<ba",      "e>dc<bagdgf#"),
  ("g1g2",         "l2gp3>g6d3g6",     "gl6<b3>dg3d",     "gb>dgd<bgb>a"),
  ("g1g2",         "dp3g6e3c6",        "<b3g>d3b>c2",     "fd<bgb>ded<a"),
  ("g1g2",         "<ap3>d6<b3>e6",    "c3<ab2b3g",       "f#a>cd<bgegb"),
  ("g1g2",         "<e3a6f#3>a6f#3d6", "a2a3f#d3f#",      ">c<af#df#a>c<ba"),
  ("g>ge",         "dde",              "g3dg3f#g3a",      "bgab>dcced"),
  ("<b>e<e",       "ge<b",             "b3ab3ge3d",       "dgf#gd<bgab"),
  ("ab>c",         "a>d<c",            "e3f#g3de3<b",     ">cdedc<babg"),
  ("df#d",         "c<a>f#",           "a3>da3ga3f#",     "f#gadf#a>c<ba"),
  ("gec",          "g<g>e",            "d3f#g3f#g3a",     "bgab>dcced"),
  ("<b>ed",        "ge<d",             "b3ab3ge3g",       "dgf#gd<bgab"),
  ("cc#d",         "d1d2",             "a3f#g3e<a3>c",    "e>dc<bagdgf#"),
  ("<g1g2",        "p2",               "<b1b2",           "g1g2"),
  ("p1",           "p1",               "p1",              "p1")
  ]


musicTracks :: [[[Melody.T ()]]]
musicTracks =
   let (track0, track1, track2, track3) = List.unzip4 songMML
       trackToMusic tr oct =
          (evalState (mapM (MML.toMusicState) tr) (0, oct))
   in  zipWith trackToMusic [track0, track1, track2, track3]
                            initOctaves

song :: Melody.T ()
song = line (map (chord . map line) (List.transpose musicTracks))


{- Try to reconstruct a structure of the music. -}

grammar :: Grammar.T String (Music.Primitive (Melody.Note ()))
grammar =
   let songTrackwise = chord (map (line . concat) musicTracks)
       songConvDurs  = fmap (\(Music.Atom dr at) -> Music.Atom (dr * (3%4)) at) songTrackwise
   in  Grammar.fromMedia (map (("part"++) . show) [(0 :: Int) ..]) 4 songConvDurs


{- Try to create new music by reordering the notes using Markov chains. -}

markovChain :: Melody.T ()
markovChain =
   let tracks = map concat musicTracks
       gs     = evalState (sequence (repeat (State split))) (mkStdGen 147)
       chains = zipWith (\track g -> line (MarkovChain.walk 3 track 0 g)) tracks gs
   in  chains !! 2 =:= chains !! 3


markovChainMidi :: MidiFile.T
markovChainMidi = toMidi (Music.take 100 markovChain)



----- Player details

cm :: InstrumentMap.ChannelTable MidiMusic.Instrument
cm = [(MidiMusic.ChurchOrgan, MidiMusic.toChannel 1),
      (MidiMusic.Viola,       MidiMusic.toChannel 2)]

context :: Context.T Float MidiMusic.Note
context =
   Context.setDur (Tempo.metro 105 Music.qn) $
   Context.deflt

toMidi :: Melody.T () -> MidiFile.T
toMidi m =
   WriteMidi.fromGMMusic (cm, context,
         MidiMusic.fromMelodyIgnoreAttr MidiMusic.ChurchOrgan m)


midi :: MidiFile.T
midi = toMidi song

main :: IO ()
main = SaveMidi.toFile "test.mid" midi