{-# OPTIONS_HADDOCK not-home #-}
{-|
A bridge between evaluated Tidal patterns and MIDI events.

This module contains functions necessary to mediate between
'Sound.Tidal.Time.Event's generated from a Tidal 'Sound.Tidal.Pattern.Pattern'
and plain MIDI events sent through 'Sound.PortMidi.PMStream'.
-}
module Sound.Tidal.MIDI.Output (
  -- * Types
  Output(..),
  OutputState,
  MidiDeviceMap,
  TimedNote,
  -- * Initialization
  makeConnection,
  flushBackend,
  -- * Scheduling
  sendevents,
  store,
  mkStore,
  storeParams,
  scheduleTime,
  -- * Converters
  toMidiValue,
  cutShape,
  stripDefaults,
  -- * State handling
  changeState,
  readState,
  -- * Low-level functions
  useOutput,
  displayOutputDevices,
  outputDevice,
  makeRawEvent,
  noteOn,
  noteOff,
  makeCtrl
                               ) where

-- generics
import           Control.Applicative ((<$>), (<*>), pure)
import           Control.Monad
import           Control.Concurrent
import           Control.Concurrent.MVar ()
import           Data.Bits
import           Data.List (sortBy, find, partition)
import qualified Data.Map as Map
import           Data.Maybe
import           Data.Ord (comparing)
import           Data.Ratio (Ratio)
import           Data.Time (getCurrentTime, UTCTime)
import           Data.Time.Clock.POSIX
import           Foreign.C
import           Numeric

-- Tidal specific
import           Sound.Tidal.Tempo (Tempo(Tempo))
import           Sound.Tidal.Stream as S

-- MIDI specific
import           Sound.Tidal.MIDI.Device
import           Sound.Tidal.MIDI.Control
import qualified Sound.PortMidi as PM

type ConnectionCount = Int
type TickedConnectionCount = Int
type OutputOnline = Bool
{- |
Keep track of virtual streams

* Reflects the number of virtual streams that have already stored their events for this tick. Every time 'TickedConnectionCount' cycles, MIDI events will be sent out.
* 'ConnectionCount' is increased on every new stream created via `midiSetters`
* For each channel, currently used params and their values are kept.
* Output will only be scheduling, once __online__, i.e. when the first stream is initialized
-}
type OutputState = (
  TickedConnectionCount, 
  ConnectionCount,
  [ParamMap], 
  OutputOnline 
  )

type Tick = Int
type Onset = Double
type Offset = Double
type RelativeOffset = Double
type MIDITime = (Tempo, Tick, Onset, RelativeOffset)
type MIDIEvent = (MIDITime, MIDIMessage)
type MIDIChannel = CLong
type MIDIStatus = CLong
type MIDINote = MIDIDatum
type MIDIVelocity = MIDIDatum
type MIDIDatum = CLong
type MIDIDuration = Ratio Integer
type MIDIMessage = (MIDIChannel, MIDIStatus, MIDINote, MIDIVelocity)
-- | A Triplet of the deviation from the note @a5@, velocity and duration
type TimedNote = (CLong, MIDIVelocity, MIDIDuration)
type SentEvent = (CULong, Double, PM.PMEvent, CULong, UTCTime)
{-|
An abstract definition of a physical MIDI Output.

Manages virtual streams to multiple channels of a single connection to a MIDI device.
-}
data Output = Output {
  cshape :: ControllerShape, -- ^ The ControllerShape defining which 'Param's will be available for use
  conn :: PM.PMStream, -- ^ The physical connection to the device, uses 'PortMidi'
  buffer :: MVar ([ParamMap], [MIDIEvent]), -- ^ A buffer of currently used 'Param's and their 'Value's as well as a list of 'MIDIEvent's to be sent on the next tick.
  bufferstate :: MVar OutputState, -- ^ Keeps track of connected virtual streams during one tick
  midistart :: CULong, -- ^ the MIDI time when this output was created
  rstart :: UTCTime -- ^ the real time when this output was created
  }

type MidiMap = Map.Map S.Param (Maybe Int)
type MidiDeviceMap = Map.Map String Output


-- | Initialize a connection to the given MIDI device by Name
makeConnection :: MVar MidiDeviceMap -- ^ The current list of already connected devices
               -> String -- ^ The MIDI device name
               -> Int -- ^ The MIDI channel
               -> ControllerShape -- ^ The definition of useable 'Control's
               -> IO (S.ToMessageFunc, Output) -- ^ A function to schedule MIDI events and the output that keeps track of connections
makeConnection devicesM displayname channel controllershape = do
  moutput <- useOutput devicesM displayname controllershape
  case moutput of
    Just o -> do
      s <- connected channel displayname o
      return (s, o)
    Nothing ->
      error "Failed initializing MIDI connection"


{- |
Sends out MIDI events once all virtual streams have buffered their events.

This will be called after every tick
-}
flushBackend :: Output -> S.Shape -> Tempo -> Int -> IO ()
flushBackend o shape change ticks = do
  changeState tickConnections o
  cycling <- readState isCycling o

  Control.Monad.when cycling (do
      -- gather last sent params, update state with new
      let buf = buffer o
      (states, events) <- takeMVar buf

      ((_,_,newstates,_), (_,_,oldstates,_)) <- changeState' (resetParamStates states) o

      -- find params that were removed
      let mapDefaults = Map.mapWithKey (\k _ -> defaultValue k)
          diffs = map mapDefaults $ zipWith Map.difference oldstates newstates
      -- store additional "reset" events in buffer
      -- schedule time must be exactly before/ontime with the next regular event to be sent. otherwise we risk
      -- mixing order of ctrl messages, and resets get overridden
      -- FIXME: when scheduling, note late CC messages and DROP THEM, otherwise everything is screwed
      let offset = S.latency shape
          mididiffs = map ((toMidiMap (cshape o)).(stripShape (toShape $ cshape o))) $ diffs          
          resetevents = concat $ zipWith (\x y -> makectrls o x (change,ticks,1,offset) y) [1..] mididiffs

      -- send out MIDI events
      (late, later) <- sendevents o shape change ticks events resetevents
      -- finally clear buffered ParamMap for next tick
      putMVar buf (replicate 16 Map.empty, later)
      let len = length late
      case len of
        0 ->
          return ()
        _ -> do
          putStrLn $ showLate $ head late
          putStrLn $ "and " ++ show (len - 1) ++ " more")


-- Scheduling

{- |
Sends out MIDI events due for this tick.
-}
sendevents :: Output -- ^ The connection to be used
           -> S.Shape -- ^ The shape to be queried for latency
           -> Tempo -- ^ The current speed
           -> Tick -- ^ The number of ticks elapsed since start, may be reset when using @cps (-1)@
           -> [MIDIEvent] -- ^ A list of events potentially needed to be sent
           -> [MIDIEvent] -- ^ A list of reset events potentially needed to be sent
           -> IO ([SentEvent], [MIDIEvent]) -- ^ A list of events sent late and a list of events to send later
sendevents _ _ _ _ [] [] = return ([],[])
sendevents s shape change ticks evts resets = do
  -- assumptions:
  -- all reset events have the same timestamp
  -- questions:      
  -- could there be any events in `evts` at all that need reset? or are these just in late from the last tick?
  let output = conn s
      toDescriptor midiTime now (o,_,t,e) = (o,t,e, midiTime, now)
      calcOnsets (a@(tempo, tick, onset, offset), e) = (a, logicalOnset' tempo tick onset offset, e)

  midiTime <- PM.time
  now <- getCurrentTime
  let offset = S.latency shape
      nextTick = logicalOnset' change (ticks+1) 0 offset
      mkEvent (t, o, e) = (midionset, t, o, makeRawEvent e midionset)
        where midionset = scheduleTime (midistart s, rstart s) o     
      onsets = map calcOnsets evts
      -- calculate temporary scheduling for resetevts
      resetevts = map calcOnsets resets
      -- split into events sent now and later (e.g. a noteOff that would otherwise cut off noteOn's in the next tick)
      (evts', later) = span ((< nextTick).(\(_,o,_) -> o)) $ sortBy (comparing (\(_,o,_) -> o)) onsets
      -- calculate MIDI time to schedule events, putting time into fn to create PM.PMEvents
      evts'' = map mkEvent evts'
      -- a list CC `names` that need to be reset
      resetccs = map (\(_, _, (_, _, d1, _)) -> d1) resetevts
      later' = map (\(t,_,e) -> (t,e)) later
      findCC match list = find (\(_, _, (_, st, d1, _)) -> st == 0xB0 && (d1 `elem` match)) $ reverse list


      -- 1. find the ccs that needs reset (search in `later` then in `evts`)
      (evtstosend, laterevts) = case findCC resetccs later of
        Nothing -> case findCC resetccs evts' of
          -- 1c. no events at all need to be reset
          --      1cI. use the default passed in midionset for resets
          --      1cII. append `resets` to `evts` FIXME: make sure we really do by timing
          --      1cIII. send `evts`
          Nothing -> (evts'' ++ map mkEvent resetevts, later')
          -- 1b. only `evts` contain a CC to be reset
          --      1bI. set scheduletime for reset __after__ the latest CC that needs to be reset in `evts`
          --      1bII. add `resets` to `evts`
          --      1bIII. send `evts`                
          Just (_, latestO, _) -> (before ++
                                      map (
                                          \(t, o, e) ->
                                          let midionset = scheduleTime (midistart s, rstart s) latestO
                                          in (midionset, t,o,makeRawEvent e midionset)
                                          ) resetevts ++ after, later')
            where
              (before, after) = partition (\(m,_,o,_) -> m > scheduleTime (midistart s, rstart s) o) evts''

        -- 1a. `later` contains a cc to be reset, (omit searching in evts)
        --      1aI. set scheduletime for reset __after__ the latest CC that needs to be reset in `later`
        --      1aII. add `resetevts` to `later`
        --      1aIII. send `evts`                
        Just (latestT, _, _) -> (evts'', later' ++ map (\(_, _, e) -> (latestT, e)) resetevts)
      evtstosend' = map (\(_,_,_,e) -> e) evtstosend
      -- filter events that are too late
      late = map (toDescriptor midiTime now) $ filter (\(_,_,t,_) -> t < realToFrac (utcTimeToPOSIXSeconds now)) evtstosend
      -- drop late CC events to avoid glitches
--      evtstosend'' = map (\(_,_,e,_,_) -> e) $ filter (not.isCC) late
  -- write events for this tick to stream
  err <- PM.writeEvents output evtstosend'

  case err of
   PM.NoError -> return (late, laterevts)  -- return events for logging in outer scope
   e -> do
     putStrLn ("sending failed: " ++ show e)
     return (late, laterevts)

isCC :: SentEvent -> Bool
isCC (_,_,e,_,_) = (0x0f .&. cc) == 0xB0
  where
    cc = PM.status $ PM.decodeMsg $ PM.message $ e


    
-- | Buffer a single tick's MIDI events for a single channel of a single connection 
store :: Output -> Int -> Tempo -> Tick -> Onset -> Offset -> MidiMap -> ParamMap -> IO ()
store s ch change tick on off ctrls note = storemidi s ch' note' (change, tick, on, offset) ctrls
    where
      (note', nudge) = computeTiming' change on off note
      ch' = fromIntegral ch
      cshape' = cshape s
      offset = Sound.Tidal.MIDI.Control.latency cshape' + nudge

{- |
Returns a function to be called on every tick,
splits the given @ParamMap@ into MIDI note information
and CCs.
-}
mkStore :: Int -> Output -> IO ToMessageFunc
mkStore channel s = return $ \ shape change tick (on,off,m) -> do
                        let ctrls = cutShape shape m
                            props = cutShape midiShape m
                            ctrls' = stripDefaults ctrls
                            ctrls'' = toMidiMap (cshape s) <$> ctrls'
                            store' = store s channel change tick on off <$> ctrls''
                        -- store even non-midi params, otherwise removing last ctrl results in a missing reset since diff in `flushBackend` would be empty
                        -- then buffer ctrl messages to be sent
                        -- with the appropriate note properties
                        ($) <$> (storeParams s channel <$> stripDefaults (applyShape' shape m)) <*> (($) <$> store' <*> props)


-- | Union the currently stored paramstate for certain channel with the given one
storeParams :: Output -> Int -> ParamMap -> IO () -> IO ()
storeParams o ch m action = do
  modifyMVar_ (buffer o) $ \(states, events) -> do
    let (before,current:after) = splitAt (ch - 1) states
        state' = Map.union m current
        states' = before ++ [state'] ++ after
    return (states', events)
  action

-- | Thin wrapper around @computeTiming@ to convert onset/offset into onset/duration relative
computeTiming' :: Tempo -> Double -> Double -> ParamMap -> (TimedNote, Double)
computeTiming' tempo on off note = ((fromIntegral n, fromIntegral v, d), nudge)
  where
    ((n,v,d), nudge) = computeTiming tempo (realToFrac (off - on) / S.ticksPerCycle) note

{- | Schedule sending all CC's default values.
Produces an `onTick` handler.
-}
connected :: Int -> String -> Output -> IO ToMessageFunc
connected channel displayname s = do
  let cshape' = cshape s
      shape = toShape $ cshape s
      defaultParams = S.defaultMap shape
      allctrls = toMidiMap cshape' defaultParams
  putStrLn ("Successfully initialized Device '" ++ displayname ++ "'")
  changeState goOnline s
  now <- getCurrentTime
  _ <- storeevents s $ makectrls s (fromIntegral channel) (Tempo now 0 1 False 0,0,0,0) allctrls
  mkStore channel s

-- State handling

readState :: (OutputState -> b) -> Output -> IO b
readState f o = do
  s <- readMVar $ bufferstate o

  return $ f s

isCycling :: OutputState -> Bool
isCycling (0, _, _, True) = True
isCycling _ = False

-- displayState :: OutputState -> String
-- displayState (ticked, conns, paramstate, online) = show ticked ++ "/" ++ show conns ++ "[" ++ show online ++ "]" ++ " active params: " ++ show paramstate

changeState :: (OutputState -> OutputState) -> Output -> IO ()
changeState f o = do
  _ <- changeState' f o
  return ()

changeState' :: (OutputState -> OutputState) -> Output -> IO (OutputState, OutputState)
changeState' f o = do
  bs <- takeMVar stateM
  let fs = f bs
  putMVar stateM fs
  return (fs, bs)
    where
      stateM = bufferstate o

-- | Params in use get overwritten by new ones, except if new ones means _no params_, in this case keep old
resetParamStates :: [ParamMap] -> OutputState -> OutputState
resetParamStates newstates (ticked, conns, paramstates, online) = (ticked, conns, zipWith resetParamState newstates paramstates, online)

resetParamState :: ParamMap -> ParamMap -> ParamMap
resetParamState newstate currentstate
  | Map.empty == newstate = currentstate -- updating with an empty state is a noop
  | otherwise = newstate

goOnline :: OutputState -> OutputState
goOnline (ticked, conns, paramstate, _) = (ticked, conns, paramstate, True)

addConnection :: OutputState -> OutputState
addConnection (ticked, conns, paramstate, online) = (ticked, conns + 1, paramstate, online)

tickConnections :: OutputState -> OutputState
tickConnections (ticked, conns, paramstate, online) = ((ticked + 1) `mod` conns, conns, paramstate, online)

-- | open named MIDI output or use cached (PortMIDI doesn't like opening two connections to the same device!)
useOutput :: MVar MidiDeviceMap -> String -> ControllerShape -> IO (Maybe Output)
useOutput outsM displayname controllershape = do
  outs <- readMVar outsM -- blocks
  let outM = Map.lookup displayname outs -- maybe
  -- if we have a valid output by now, return
  case outM of
    Just o -> do
      putStrLn "Cached Device Output"
      changeState addConnection o -- blocks
      return $ Just o
    Nothing -> do
      -- otherwise open a new output and store the result in the mvar
      devidM <- (>>= maybe (failed displayname "Failed opening MIDI Output Device ID") return) (getIDForDeviceName displayname)
      econn <- outputDevice devidM 1 controllershape  -- either
      case econn of
        Left o -> do
          changeState addConnection o
          _ <- swapMVar outsM $ Map.insert displayname o outs
          return $ Just o
        Right _ -> return Nothing


-- | Turn logicalOnset into MIDITime
scheduleTime :: (CULong, UTCTime)-> Double -> CULong
scheduleTime (mstart', rstart') logicalOnset = (+) mstart $ floor $ 1000 * (logicalOnset - rstart'')
  where
    rstart'' = realToFrac $ utcTimeToPOSIXSeconds rstart'
    mstart = fromIntegral mstart'
    
-- Converters

{-|
Convert a @Param@'s @Value@ into a MIDI consumable datum.

Applies range mapping and scaling functions according to @ControllerShape@
-}
toMidiValue :: ControllerShape -> S.Param -> Value -> Maybe Int
toMidiValue s p (VF x) = ($) <$> mscale <*> mrange <*> pure x
    where
      mrange = fmap range mcc
      mscale = fmap scalef mcc
      mcc = paramN s p
toMidiValue _ _ (VI x) = Just x
toMidiValue _ _ (VS _) = Nothing -- ignore strings for now, we might 'read' them later

-- | Translates generic params into midi params
toMidiMap :: ControllerShape -> S.ParamMap -> MidiMap
toMidiMap s m = Map.mapWithKey (toMidiValue s) m

-- | Keep only params that are in a given shape, replace missing with defaults
cutShape :: S.Shape -> ParamMap -> Maybe ParamMap
cutShape s m = flip Map.intersection (S.defaultMap s) <$> S.applyShape' s m

-- | Keep only params that are in a given shape
stripShape :: S.Shape -> ParamMap -> ParamMap
stripShape s = Map.intersection p'
  where
    p' = S.defaultMap s

-- | Keep only params that are explicitly set (i.e. not default)
stripDefaults :: Maybe ParamMap -> Maybe ParamMap
stripDefaults m = Map.filterWithKey (\k v -> v /= defaultValue k) <$> m


-- Event creation

-- FIXME: throws if param cannot be found
makectrls :: Output -> MIDIChannel -> MIDITime -> MidiMap -> [MIDIEvent]
makectrls o ch t ctrls = concatMap (\(param', ctrl) -> makeCtrl ch (fromJust $ paramN shape param') (fromIntegral ctrl) t) ctrls'
  where
    shape = cshape o
    ctrls' = filter ((>=0) . snd) $ Map.toList $ Map.mapMaybe id ctrls

makenote :: MIDIChannel -> TimedNote -> MIDITime -> [MIDIEvent]
makenote ch (note,vel,dur) (tempo,tick,onset,offset) = noteon' ++ noteoff'
  where
    noteon' = noteOn ch midinote vel (tempo,tick,onset,offset)
    noteoff' = noteOff ch midinote (tempo,tick,onset,offset + fromRational dur)
    midinote = note + 60

makemidi :: Output -> MIDIChannel -> TimedNote -> MIDITime -> MidiMap -> [MIDIEvent]
makemidi o ch (128,_,_) t ctrls = makectrls o ch t ctrls -- HACK: to send only CC use (n + 60) == 128
makemidi o ch note t ctrls = makectrls o ch t ctrls ++ makenote ch note t

-- Event buffering
storemidi :: Output -> MIDIChannel -> TimedNote -> MIDITime -> MidiMap -> IO ()
storemidi o ch n t ctrls = do
  _ <- storeevents o $ makemidi o ch n t ctrls
  return ()


makeEvent :: MIDIStatus -> MIDINote -> MIDIChannel -> MIDIVelocity -> MIDITime -> MIDIEvent
makeEvent st n ch v t = (t, msg)
  where
    msg = (ch, st, n, v)

storeevents :: Output -> [MIDIEvent] -> IO (Maybe a)
storeevents o evts = do
  let buf = buffer o
  (paramstate, cbuf) <- takeMVar buf
  putMVar buf (paramstate, cbuf ++ evts)
  return Nothing

-- Misc helpers

showLate :: SentEvent -> String
showLate (o, t, e, m, n) =
  unwords ["late",
           show $ (\x -> [PM.status x, PM.data1 x, PM.data2 x]) $ PM.decodeMsg $ PM.message e,
           "midi now ", show m, " midi onset: ", show o,
           "onset (relative): ", show $ showFFloat (Just 3) (t - realToFrac (utcTimeToPOSIXSeconds n)) "",
           ", sched: ", show $ PM.timestamp e]

showEvent :: PM.PMEvent -> String
showEvent e = show t ++ " " ++ show msg
  where msg = PM.decodeMsg $ PM.message e
        t = PM.timestamp e

showRawEvent :: (CULong, MIDITime, Double, PM.PMEvent) -> String
showRawEvent (_, (_,_,onset,offset), logicalOnset, e) = "(" ++ show onset ++ "," ++ show offset ++ ") / " ++ show logicalOnset ++ " " ++  showEvent e

failed :: (Show a, Show b) => a -> b -> c
failed di err = error (show err ++ ": " ++ show di)


---------------
-- LOW LEVEL --
---------------

-- MIDI Event wrapping
makeRawEvent :: MIDIMessage -> CULong -> PM.PMEvent
makeRawEvent (ch, st, n, v) = PM.PMEvent msg
  where msg = PM.encodeMsg $ PM.PMMsg (encodeChannel ch st) n v


-- MIDI Utils
encodeChannel :: MIDIChannel -> MIDIStatus -> CLong
encodeChannel ch cc = (-) ch 1 .|. cc


-- MIDI Messages
noteOn :: MIDIChannel -> MIDINote -> MIDIVelocity -> MIDITime -> [MIDIEvent]
noteOn ch val vel t = [makeEvent 0x90 val ch vel t]

noteOff :: MIDIChannel -> MIDINote -> MIDITime -> [MIDIEvent]
noteOff ch val t = [makeEvent 0x80 val ch 60 t]

makeCtrl :: MIDIChannel -> ControlChange -> MIDIDatum -> MIDITime -> [MIDIEvent]
makeCtrl ch CC {midi=midi'} n t = makeCC ch (fromIntegral midi') n t -- FIXME: no SysEx support right now
makeCtrl ch NRPN {midi=midi'} n t = makeNRPN ch (fromIntegral midi') n t

makeCC :: MIDIChannel -> MIDIDatum -> MIDIDatum -> MIDITime -> [MIDIEvent]
makeCC ch c n t = [makeEvent 0xB0 c ch n t]

makeNRPN :: MIDIChannel -> MIDIDatum -> MIDIDatum -> MIDITime -> [MIDIEvent]
makeNRPN ch c n t = [
  nrpn 0x63 ch (shift (c .&. 0x3F80) (-7)) t,
  nrpn 0x62 ch (c .&. 0x7F) t,
  nrpn 0x06 ch (shift (n .&. 0x3F80) (-7)) t,
  nrpn 0x26 ch (n .&. 0x7F) t
  ]
  where
    nrpn = makeEvent 0xB0


-- | Creates an 'Output' wrapping a PortMidi device
outputDevice :: PM.DeviceID -> Int -> ControllerShape -> IO (Either Output PM.PMError)
outputDevice deviceID latency' shape = do
  _ <- PM.initialize
  result <- PM.openOutput deviceID latency'
  bs <- newMVar (0, 0, replicate 16 Map.empty, False)
  case result of
    Left dev ->
      do
        info <- PM.getDeviceInfo deviceID
        time <- getCurrentTime        
        mstart <- PM.time        
        putStrLn ("Opened: " ++ show (PM.interface info) ++ ": " ++ show (PM.name info))
        b <- newMVar (replicate 16 Map.empty, [])

        return (Left Output { cshape=shape, conn=dev, buffer=b, bufferstate=bs, midistart=mstart, rstart=time })
    Right err -> return (Right err)