    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 Haskore.Basic.Duration (qn, (%+), )

    import qualified Haskore.Performance.Context as Context
    import qualified Haskore.Performance.Default as DefltPf

    import qualified Numeric.NonNegative.Wrapper as NonNeg

    import qualified Haskore.Interface.MML as MML
    -- import qualified Medium.Controlled.List as CtrlMedium
    import qualified Medium.Controlled.ContextFreeGrammar as Grammar
    import qualified Data.MarkovChain as MarkovChain

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

    import qualified Data.List as List

    import           Control.Monad.Trans.State (state, evalState, )
    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.Control (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.fromMedium (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.run 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 NonNeg.Float Float MidiMusic.Note
    context =
       Context.setDur (Tempo.metro 105 qn) $
       DefltPf.context

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

    midi :: MidiFile.T
    midi = toMidi song

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