{-# LANGUAGE ExistentialQuantification #-}

-- | Library provides functions to render 'Score' made with
-- 'temporal-music-notation' library to midi file from 'HCodecs' package.
module Temporal.Music.Notation.Demo(
    -- * Types
    MidiEvent,

    -- * Instruments
    instr, drumInstr, 

    -- * Render
    renderMidi, FilePath, exportMidi)
where

import Data.List(sortBy, partition)
import Data.Function(on)

import Data.Word

import Data.Binary
import Data.Binary.Put

import Foreign.C.Math.Double(log10)
import Codec.Midi hiding (Time)

import Temporal.Music.Notation
import Temporal.Music.Notation.Note

-- cmath

log2 :: Double -> Double
log2 x = log10 x / log10 2

logB :: Double -> Double -> Double
logB b x = log10 x / log10 b


-----------------------------------------------------------------
-- Types

type Instr    = Int
type VolumeId = Int
type PitchId  = (Int, Bend)


data MidiEvent = forall nVol nPch . (
    Seg nVol, Seg nPch) => MidiEvent
    { meventInstr  :: Instr
    , meventVol    :: Volume nVol
    , meventPch    :: Maybe (Pitch nPch)
    }


data LowMidiEvent = LowMidiEvent
    { lmeventVol   :: VolumeId
    , lmeventPch   :: PitchId
    }


instance LevelFunctor MidiEvent where
    mapLevel f (MidiEvent i v p) = MidiEvent i (mapLevel f v) p 

instance VolumeFunctor MidiEvent where
    mapVolume f (MidiEvent i v p) = MidiEvent i (mapVolume f v) p 

instance ToneFunctor MidiEvent where
    mapTone f (MidiEvent i v p) = MidiEvent i v (fmap (mapTone f) p) 

instance PitchFunctor MidiEvent where
    mapPitch f (MidiEvent i v p) = MidiEvent i v (fmap (mapPitch f) p) 


-----------------------------------------------------------------
-- instruments

-- | Apply midi instrument.
instr :: (Seg nVol, Seg nPch) => 
    Preset -> Score (Note nVol nPch a) -> Score MidiEvent
instr id = fmap $ \(Note v p a) -> MidiEvent id v (Just p)


-- | Apply midi drum instrument.
drumInstr :: Seg nVol => 
    Key -> Score (Drum nVol a) -> Score MidiEvent
drumInstr id = fmap $ \(Drum v a) -> MidiEvent id v drumPch

drumPch :: Maybe (Pitch DrumPitch)
drumPch = Nothing

data DrumPitch = DrumPitch
    deriving (Enum, Bounded)

instance Seg DrumPitch

-----------------------------------------------------------------
-- interpretation

-- | Render 'Score' to midi file and save results in current
-- directory.
exportMidi :: FilePath -> Score MidiEvent -> IO ()
exportMidi file sco = exportFile file $ renderMidi sco

-- | Render to 'Midi'.
renderMidi :: Score MidiEvent -> Midi
renderMidi = render' . renderScore

render' :: EventList Dur MidiEvent -> Midi
render' (EventList totalDur xs) = setMidi tracks 
    where td = totalDiapason $ map eventContent xs          
          tracks = map (formTrack td totalDur) $ 
                    assignChannels $ groupByInstr xs


formTrack :: Diapason -> Dur 
    -> (Channel, (Maybe Instr, [Event Dur MidiEvent]))
    -> Track Ticks
formTrack td d (ch, (i, es)) = 
    renderTrack d i ch $ fmap (fmap $ lowLevel td) $ sortEvents es
            

sortEvents :: Ord t => [Event t a] -> [Event t a]
sortEvents = sortBy (compare `on` eventStart)

setMidi :: [Track Ticks] -> Midi
setMidi = Midi MultiTrack (TicksPerBeat division) 

assignChannels :: [(Maybe Instr, [Event Dur MidiEvent])] 
    -> [(Channel, (Maybe Instr, [Event Dur MidiEvent]))]
assignChannels xs = zip (assignIds xs') xs'
    where xs' = sortBy (compare `on` fst) $ take 16 xs
          assignIds = maybe drumIds (const noteIds) . fst . head
          drumIds = 9 : [0 .. 8] ++ [10 .. 15]
          noteIds = [0 .. 15]

groupByInstr :: [Event Dur MidiEvent] 
    -> [(Maybe Instr, [Event Dur MidiEvent])]
groupByInstr es = 
    case es of
        []   -> []
        x:xs -> 
            let (a, b) = partition ((instrId x == ) . instrId) xs
            in  (instrId x, x : a) : groupByInstr b 

instrId :: Event Dur MidiEvent -> Maybe Instr
instrId x = 
    case eventContent x of
        MidiEvent i _ p -> fmap (const i) p


defST :: Int
defST = 1000000

renderTrack :: Dur -> Maybe Instr -> Channel 
    -> [Event Dur LowMidiEvent] -> Track Ticks
renderTrack totalDur instr ch xs = sets ++ body
    where sets = trackSettings instr ch 
          body = fromAbsTime $ trackBody ch xs 
                  ++ return (toTicks totalDur, TrackEnd)


trackSettings :: Maybe Instr -> Channel -> Track Ticks 
trackSettings instr ch = tempo : program
    where tempo   = (0, TempoChange defST) 
          program = maybe [] 
                (return . \x -> (0, ProgramChange ch x)) instr 


trackBody :: Channel 
    -> [Event Dur LowMidiEvent] -> Track Ticks
trackBody ch es =
    case es of
        []   -> []
        x:xs -> let (n, m) = toMessages ch $ eventContent x
                    tn  = toTicks $ eventStart x  
                    tm  = toTicks $ eventStart x + eventDur x
                    xs' = insertNoteOff (tm, m) (trackBody ch xs) 
                in  map (markTime tn) n ++ xs'

markTime :: t -> Message -> (t, Message)
markTime = (,)

insertNoteOff :: (Ticks, Message) -> Track Ticks -> Track Ticks
insertNoteOff a ms = 
    case ms of
        []   -> [a]
        x:xs -> if t a <= t x 
                    then a:ms 
                    else x:insertNoteOff a xs
    where t = fst



{-
toMessages :: Channel -> LowMidiEvent -> (Message, Message) 
toMessages ch x = (NoteOn ch key vel, NoteOff ch key 64)
    where key = fst $ lmeventPch x
          vel = lmeventVol x  
-}

toMessages :: Channel -> LowMidiEvent -> ([Message], Message) 
toMessages ch x = toMessages' ch vel key tune
    where key  = fst $ lmeventPch x
          vel  = lmeventVol x  
          tune = uncurry tuneParams $ lmeventPch x

toMessages' :: Channel -> VolumeId -> Key -> Maybe TuneId 
    -> ([Message], Message)
toMessages' ch v p t = (tune ++ [NoteOn ch p v], NoteOff ch p 64)
    where tune = maybe [] (return . tuneMessage) t

totalDiapason :: [MidiEvent] -> Diapason
totalDiapason = foldl1 merge . map diap 
    where diap (MidiEvent _ v _) = volumeDiapason v
          merge (a, b) (a', b') = (min a a', max b b')
                


lowLevel :: Diapason -> MidiEvent -> LowMidiEvent
lowLevel diap (MidiEvent i v p) = LowMidiEvent vol pch
    where vol = fitToMidiDiapason diap $ absVolume v
          pch = maybe (i, 0) (midiPch . absPitch) p

fitToMidiDiapason :: Diapason -> Amplitude -> VolumeId
fitToMidiDiapason (a, b) x = round $ 127 * logB (b/a) (x/a) 
        {- logBase (b/a) (x/a) -}

midiPch :: Frequency -> PitchId
midiPch x = properFraction $ bound $ 69 + 12 * log2 (x/440) 
        {- logBase 2 (x / 440) -}
    where bound = max 0 . min 127 



toTicks :: Time -> Ticks
toTicks = round . ( * division2)

division :: Ticks
division = 96

division2 :: Time
division2 = fromIntegral 96


-----------------------------------------------------
-- Microsound

type TuneId = (KeyId, Cents)
type KeyId = Word8

type Cent0 = Word8
type Cent1 = Word8

type Cents = (Cent0, Cent1)

tuneParams :: Int -> Double -> Maybe TuneId
tuneParams p d = Just (fromIntegral p, c) 
 --   | c == (0, 0) = Nothing
 --   | otherwise   = Just (fromIntegral p, c)
    where c = cents d

cents :: Double -> (Cent0, Cent1)
cents d = (fromIntegral c0, fromIntegral c1)
    where (c0, c1) = flip divMod (128::Int) $ 
                        fst $ properFraction (d/deltaTune)

-- | 1 semitone / 2^14 
deltaTune :: Double
deltaTune = 0.000061


tuneMessage :: TuneId -> Message 
tuneMessage (x, (a, b)) = Sysex 240 $ 
    runPut $ do
        putWord8 127
        putWord8 0
        putWord8 8
        putWord8 2
        putWord8 0
        putWord8 1
        putWord8 x
        putWord8 x
        putWord8 a
        putWord8 b
        putWord8 247