{-# 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 Codec.Midi hiding (Time)

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

log2 = logBase 2

-----------------------------------------------------------------
-- 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 = 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 = midiVol diap v
          pch = maybe (i, 0) midiPch p

clipToMidi :: (Num a, Ord a) => a -> a
clipToMidi = min 127 . max 0

-------------------
-- midi volume

midiVol (a', b') (Volume (a, b) l) = 
    clipToMidi $ round $ (127 * ) $ 
    x * logBase (b'/a') (b/a) + logBase (b'/a') (a/a')
    where x  = levelAsDoubleRel l
          
--------------------
-- midi pitch

midiPch :: Seg s => Pitch s -> PitchId
midiPch (Pitch s t) = properFraction $ clipToMidi $ 
      69 + 12 * (scaleStepFactor s n 
    + scaleOctaveFactor s k + scaleBendFactor s n r)
    where (d, r) = properFraction $ toneAsDouble t
          (k, n) = divMod d $  scaleSize s
     
-- log2 (f0 * s / 440)
scaleStepFactor :: Scale -> Int -> Double
scaleStepFactor s n = log2 $ scaleStep s n * f0 / 440
    where f0 = snd $ scaleBase s

-- k * log2 d
scaleOctaveFactor :: Scale -> Int -> Double
scaleOctaveFactor s k 
    | abs (d - 2) < 1e-9 = k'
    | otherwise          = k' * log2 d
    where d  = scaleOctave s
          k' = fromIntegral k 

-- x * log2 (r/l)
scaleBendFactor :: Scale -> Int -> Double -> Double
scaleBendFactor s n x 
    | abs x < 1e-9 = 0
    | x > 0        =     x * log2 (r / c)
    | otherwise    = abs x * log2 (l / c)
    where c = scaleStep s n
          l = scaleStep s $ n - 1
          r = scaleStep s $ n + 1

    
-------------------------

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