{- |
Convert MIDI events of a MIDI controller to a control signal.
-}
module Synthesizer.Storable.ALSA.MIDI where

import qualified Sound.Alsa           as ALSASig
import qualified Sound.Alsa.Sequencer as ALSA

import qualified Sound.Sox.Play as Play
import qualified Sound.Sox.Option.Format as SoxOpt
import qualified Synthesizer.Basic.Binary as BinSmp
-- import Data.Int (Int16)

import qualified Synthesizer.Storable.Cut        as CutSt

import qualified Synthesizer.Storable.Signal     as SigSt
import qualified Data.StorableVector.Lazy.Pattern as SigStV
import qualified Data.StorableVector.Lazy        as SVL
import qualified Data.StorableVector.Base        as SV

import qualified Data.EventList.Relative.TimeBody  as EventList
import qualified Data.EventList.Relative.TimeTime  as EventListTT
import qualified Data.EventList.Relative.MixedBody as EventListMB
-- import qualified Data.EventList.Relative.BodyMixed as EventListBM
import qualified Data.EventList.Relative.TimeMixed as EventListTM
import qualified Data.EventList.Relative.MixedTime as EventListMT
import qualified Data.EventList.Relative.BodyTime  as EventListBT
import qualified Data.EventList.Absolute.TimeBody  as AbsEventList

import qualified Foreign
import Foreign.Storable (Storable)

import System.IO.Unsafe (unsafeInterleaveIO, )
import Control.Concurrent (threadDelay)
import System.Time (ClockTime(TOD), getClockTime, )
import Control.Exception (bracket, )

import Control.Monad.Trans.State (State, state, )

-- import qualified Numeric.NonNegative.Class   as NonNeg
import qualified Numeric.NonNegative.Wrapper as NonNegW
import qualified Numeric.NonNegative.ChunkyPrivate as NonNegChunky

import qualified Algebra.RealField as RealField

import Data.Tuple.HT (mapPair, mapSnd, )
import Data.Maybe.HT (toMaybe, )
-- import Data.Maybe (mapMaybe, )
import Control.Monad (liftM, liftM2, guard, )

import NumericPrelude (round, )
import Prelude hiding (round, break, )


{-
readMIDIController ::
   Storable a =>
   Int -> Int -> Int -> IO (SigSt.T a)
readMIDIController chunkSize sampleRate ctrl =
   withInPort ALSA.Block $ \ h _p ->
   do let loop = do putStrLn "waiting for an event:"
                    e <- ALSA.event_input h
                    print e
                    loop
      loop
      return SigSt.empty
-}


getTimeSeconds :: Fractional time => IO time
getTimeSeconds =
   fmap clockTimeToSeconds getClockTime

clockTimeToSeconds :: Fractional time => ClockTime -> time
clockTimeToSeconds (TOD secs picos) =
   fromInteger secs + fromInteger picos * 1e-12


type ALSAEvent = (Double, ALSA.Event)

{- | only use it for non-blocking sequencers -}
getStampedEvent :: ALSA.SndSeq -> IO ALSAEvent
getStampedEvent h =
   liftM2 (,)
      getTimeSeconds
      (ALSA.event_input h)

{- | only use it for non-blocking sequencers -}
getWaitingEvents :: ALSA.SndSeq -> IO [ALSAEvent]
getWaitingEvents h =
   let loop =
          ALSA.alsa_catch
             (liftM2 (:) (getStampedEvent h) loop)
             (const $ return [])
   in  loop


type StrictTime = NonNegW.Integer

{-
ghc -i:src -e 'withMIDIEventsNonblock 44100 print' src/Synthesizer/Storable/ALSA/MIDI.hs
-}
-- as a quick hack, we neglect the ALSA time stamp and use getTime or so
withMIDIEventsNonblock ::
   Double -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a
withMIDIEventsNonblock rate proc =
   withInPort ALSA.Nonblock $ \ h _p ->
   do l <- ioToLazyList $ threadDelay 10000 >>
              liftM2 (:)
                 (liftM (\t->(t,Nothing)) getTimeSeconds)
                 (liftM (map (mapSnd Just)) (getWaitingEvents h))
      proc $
         discretizeTime rate $
         AbsEventList.fromPairList $ concat l

withMIDIEventsNonblockSimple ::
   Double -> (EventList.T StrictTime ALSA.Event -> IO a) -> IO a
withMIDIEventsNonblockSimple rate proc =
   withInPort ALSA.Nonblock $ \ h _p ->
   do l <- ioToLazyList $ threadDelay 10000 >> getWaitingEvents h
      proc $
         discretizeTime rate $
         AbsEventList.fromPairList $ concat l

withMIDIEventsBlock ::
   Double -> (EventList.T StrictTime ALSA.Event -> IO a) -> IO a
withMIDIEventsBlock rate proc =
   withInPort ALSA.Block $ \ h _p ->
   do l <- ioToLazyList $ getStampedEvent h
      proc $
         discretizeTime rate $
         AbsEventList.fromPairList l

withInPort ::
   ALSA.BlockMode -> (ALSA.SndSeq -> ALSA.Port -> IO t) -> IO t
withInPort blockMode act =
   bracket
      (ALSA.open ALSA.default_seq_name ALSA.open_input blockMode)
      (ALSA.close) $
   \h ->
   ALSA.set_client_name h "Haskell-Synthesizer" >>
   (bracket
      (ALSA.create_simple_port h "listener"
          (ALSA.caps [ALSA.cap_write, ALSA.cap_subs_write])
          ALSA.type_midi_generic)
      (ALSA.delete_port h) $
   \p ->
   act h p)

{- |
We first discretize the absolute time values,
then we compute differences,
in order to avoid rounding errors in further computations.
-}
discretizeTime :: Double -> AbsEventList.T Double a -> EventList.T StrictTime a
discretizeTime sampleRate =
   EventListMB.mapTimeHead (const 0) . -- clear first time since it is an absolute system time stamp
   EventList.fromAbsoluteEventList .
   AbsEventList.mapTime
      (NonNegW.fromNumberMsg "time conversion" . round . (sampleRate*))


type LazyTime = NonNegChunky.T NonNegW.Integer

{- |
We turn the strict time values into lazy ones
according to the breaks by our beat.
However for the laziness breaks we ignore the events that are filtered out.
That is we loose laziness granularity
but hopefully gain efficiency by larger blocks.
-}
getSlice ::
   (ALSA.Event -> Maybe a) ->
   State (EventList.T StrictTime (Maybe ALSA.Event)) (EventListTT.T LazyTime a)
getSlice f =
   fmap
      (EventListTT.catMaybesR .
       flip EventListTM.snocTime 0 .
       EventList.mapTime NonNegChunky.fromNumber) $
   state (partitionMaybeBeat f)
--   state (partitionMaybe (maybe (Just Nothing) (fmap Just . f)))

{- |
Move all elements that are mapped to @Just@ into another list.
-}
partitionMaybe ::
   (a -> Maybe b) -> EventList.T StrictTime a ->
   (EventList.T StrictTime b, EventList.T StrictTime a)
partitionMaybe f =
   mapPair (EventList.catMaybes, EventList.catMaybes) .
   EventList.foldrPair (\t a ->
      let (x,y) =
             case f a of
                Just b  -> (Just b,  Nothing)
                Nothing -> (Nothing, Just a)
      in  mapPair (EventList.cons t x, EventList.cons t y))
      (EventList.empty, EventList.empty)

{- |
Move all elements that are mapped to @Just@ into another list.
@Nothing@ elements in the source list
are maintained in both result lists as laziness breaks.
-}
partitionMaybeBeat ::
   (a -> Maybe b) -> EventList.T StrictTime (Maybe a) ->
   (EventList.T StrictTime (Maybe b), EventList.T StrictTime (Maybe a))
partitionMaybeBeat f =
   mapPair (EventList.catMaybes, EventList.catMaybes) .
   EventList.foldrPair (\t a0 ->
      let (x,y) =
             case a0 of
                Nothing -> (Just Nothing, Just Nothing)
                Just a1 ->
                   case f a1 of
                      Just b  -> (Just $ Just b,  Nothing)
                      Nothing -> (Nothing, Just $ Just a1)
      in  mapPair (EventList.cons t x, EventList.cons t y))
      (EventList.empty, EventList.empty)

maybeController :: Int -> Int -> ALSA.Event -> Maybe (Int, Int)
maybeController chan ctrl e =
   let ALSA.TickTime n = ALSA.ev_timestamp e
   in  case ALSA.ev_data e of
          ALSA.CtrlEv ALSA.Controller c ->
             toMaybe (fromIntegral (ALSA.ctrl_channel c) == chan &&
                      fromIntegral (ALSA.ctrl_param   c) == ctrl)
                (fromIntegral n, fromIntegral $ ALSA.ctrl_value c)
          _ -> Nothing

getControllerEvents ::
   Int -> Int ->
   State (EventList.T StrictTime (Maybe ALSA.Event)) (EventListTT.T LazyTime Int)
getControllerEvents chan ctrl =
   getSlice (fmap snd . maybeController chan ctrl)

controllerValuesToSignal ::
   Double -> EventListTT.T LazyTime Double -> SigSt.T Double
controllerValuesToSignal initial =
   EventListBT.foldrPair
      (\y t -> SigSt.append (SigStV.replicate (chunkSizesFromLazyTime t) y)) SigSt.empty .
   EventListMT.consBody initial

chunkSizesFromLazyTime :: LazyTime -> NonNegChunky.T SigSt.ChunkSize
chunkSizesFromLazyTime =
   NonNegChunky.fromChunks .
   map (SVL.ChunkSize . fromInteger . NonNegW.toNumber) .
   NonNegChunky.toChunks .
   NonNegChunky.normalize


controllerValueToSample ::
   (Double,Double) -> Int -> Double
controllerValueToSample (lower,upper) n =
   let k = fromIntegral n / 127
   in  (1-k) * lower + k * upper

getControllerSignal ::
   Int -> Int ->
   (Double,Double) -> Double ->
   State (EventList.T StrictTime (Maybe ALSA.Event)) (SigSt.T Double)
getControllerSignal chan ctrl bnd initial =
   liftM (controllerValuesToSignal initial .
          EventListTT.mapBody (controllerValueToSample bnd)) $
   getControllerEvents chan ctrl


controllerValueToSampleExp ::
   (Double,Double) -> Int -> Double
controllerValueToSampleExp (lower,upper) n =
   let k = fromIntegral n / 127
   in  lower**(1-k) * upper**k

getControllerSignalExp ::
   Int -> Int ->
   (Double,Double) -> Double ->
   State (EventList.T StrictTime (Maybe ALSA.Event)) (SigSt.T Double)
getControllerSignalExp chan ctrl bnd initial =
   liftM (controllerValuesToSignal initial .
          EventListTT.mapBody (controllerValueToSampleExp bnd)) $
   getControllerEvents chan ctrl


maybePitchBend :: Int -> ALSA.Event -> Maybe Int
maybePitchBend chan e =
   case ALSA.ev_data e of
      ALSA.CtrlEv ALSA.PitchBend c ->
         toMaybe (fromIntegral (ALSA.ctrl_channel c) == chan)
            (fromIntegral $ ALSA.ctrl_value c)
      _ -> Nothing

pitchBendValueToSample ::
   Double -> Double -> Int -> Double
pitchBendValueToSample range center n =
   center * range ** (fromIntegral n / 8192)

{- |
@getPitchBendSignal channel range center@:
emits frequencies on an exponential scale from
@center/range@ to @center*range@.
-}
getPitchBendSignal ::
   Int ->
   Double -> Double ->
   State (EventList.T StrictTime (Maybe ALSA.Event)) (SigSt.T Double)
getPitchBendSignal chan range center =
   liftM (controllerValuesToSignal center .
          EventListTT.mapBody (pitchBendValueToSample range center)) $
   getSlice (maybePitchBend chan)
--   getPitchBendEvents chan

{-
We could also provide a function which filters for specific programs/presets.
-}
getNoteEvents ::
   Int ->
   State
      (EventList.T StrictTime (Maybe ALSA.Event))
      (EventListTT.T LazyTime (Int,Int,Bool))
getNoteEvents chan =
   getSlice $ \e ->
      case ALSA.ev_data e of
         ALSA.NoteEv notePart note ->
            do guard (fromIntegral (ALSA.note_channel note) == chan)
               (vel,press) <-
                  case notePart of
                     ALSA.NoteOn ->
                        return $
                        let v = ALSA.note_velocity note
                        in  if v==0
                              then (64, False)
                              else (fromIntegral v, True)
                     ALSA.NoteOff ->
                        return
                           (fromIntegral $ ALSA.note_velocity note, False)
                     _ -> Nothing
               return (fromIntegral $ ALSA.note_note note, vel, press)
         _ -> Nothing

matchNoteEventsAlt ::
   EventListTT.T LazyTime (Int,Int,Bool) ->
   EventListTT.T LazyTime (Int,Int,LazyTime)
matchNoteEventsAlt =
   EventListTT.catMaybesR .
   matchNoteEventsMaybe .
   EventListTT.mapBody Just

matchNoteEventsMaybe ::
   EventListTT.T LazyTime (Maybe (Int,Int,Bool)) ->
   EventListTT.T LazyTime (Maybe (Int,Int,LazyTime))
matchNoteEventsMaybe =
   EventListMT.mapTimeTail $ \r0 ->
   flip (EventListMT.switchBodyL EventListBT.empty) r0 $
   \ev r1 ->
      case ev of
         Nothing ->
            EventListMT.consBody Nothing $ matchNoteEventsMaybe r1
         Just (pitchOn,velOn,pressOn) ->
            let (dur,r2) =
                   if not pressOn
                     then (0, r1) -- isolated NoteOff event
                     else
                        let (prefix,_noteOff,suffix) =
                               break (maybe False
                                  (\(pitchOff,_velOff,pressOff) ->
                                     pitchOn == pitchOff && not pressOff)) r1
                        in  (lazyDuration prefix,
                             EventListTM.prependBodyEnd
                                (EventListTM.snocBody prefix Nothing) suffix)
            in  EventListMT.consBody (Just (pitchOn,velOn,dur)) $ matchNoteEventsMaybe r2

{-
We need a version of 'append' which is specialised to the lazy time type.
Otherwise @append (2 /. 'a' ./ 4 /. 'b' ./ 3 /. undefined) undefined@
does not return the @'b'@.
This makes 'testKeyboard7' omitting the last defined note.
In realtime performance this leads to the effect,
that notes are only played after the key is released.
-}
matchNoteEvents ::
   EventListTT.T LazyTime (Int,Int,Bool) ->
   EventListTT.T LazyTime (Int,Int,LazyTime)
matchNoteEvents =
   EventListMT.mapTimeTail $ \r0 ->
   flip (EventListMT.switchBodyL EventListBT.empty) r0 $
   \(pitchOn,velOn,pressOn) r1 ->
   let (dur,r2) =
          if not pressOn
            then (0, r1) -- isolated NoteOff event
            else
               let (prefix,_noteOff,suffix) =
                      break (\(pitchOff,_velOff,pressOff) ->
                          pitchOn == pitchOff && not pressOff) r1
               in  (lazyDuration prefix,
                    appendTTLazy prefix suffix)
   in  EventListMT.consBody (pitchOn,velOn,dur) $ matchNoteEvents r2

{- |
This is like 'EventListTT.append' but more lazy,
because it uses the structure of the time value.
-}
appendTTLazy ::
   EventListTT.T LazyTime body ->
   EventListTT.T LazyTime body ->
   EventListTT.T LazyTime body
appendTTLazy xs ys =
   EventListTT.foldr
      (\t zs ->
          let (d,ws) = either EventListMT.viewTimeL ((,) NonNegChunky.zero) zs
          in  EventListMT.consTime (t + d) ws)
      (\b zs -> Right $ EventListMT.consBody b zs)
      (Left ys) xs

lazyDuration :: EventListTT.T LazyTime body -> LazyTime
lazyDuration = foldr (+) 0 . EventListTT.getTimes


{- |
Find the first matching body element.
Event list must be infinite or it must contain a matching body element,
otherwise 'body' and the end of the returned list will be undefined.
-}
break ::
   (body -> Bool) -> EventListTT.T LazyTime body ->
   (EventListTT.T LazyTime body, body, EventListTT.T LazyTime body)
break p =
   EventListMT.switchTimeL $ \t xs ->
      let (prefix,suffix) = EventListBT.span (not . p) xs
          (b,r) =
             EventListMT.switchBodyL
                (error "no matching body element found",
                 error "list ended before matching element found")
                (,)
                suffix
      in  (EventListMT.consTime t prefix, b, r)

{- |
Remove the first matching body element.
Event list must be infinite or it must contain a matching body element,
otherwise 'body' and the end of the returned list will be undefined.
-}
remove ::
   (body -> Bool) -> EventListTT.T LazyTime body ->
   (body, EventListTT.T LazyTime body)
remove p =
   EventListMT.switchTimeL $ \t xs ->
      let (prefix,suffix) = EventListBT.span p xs
          (b,r) =
             EventListMT.switchBodyL
                (error "no matching body element found",
                 error "list ended before matching element found")
                (,)
                suffix
      in  (b, EventListTT.append (EventListMT.consTime t prefix) r)


type Instrument = LazyTime -> Double -> Double -> SigSt.T Double

{- |
Instrument parameters are:
velocity from -1 to 1 (0 is the normal pressure, no pressure aka NoteOff is not supported),
frequency is given in Hertz
-}
makeInstrumentSounds ::
   Instrument ->
   EventListTT.T time (Int,Int,LazyTime) ->
   EventListTT.T time (SigSt.T Double)
makeInstrumentSounds instrument =
   EventListTT.mapBody
      (\(pitch, vel, dur) ->
          instrument
             dur
             (fromIntegral (vel-64)/63)
--             (880 * 2 ** (fromIntegral (pitch + 3 - 6*12) / 12)))
             (440 * 2 ** (fromIntegral (pitch + 3 - 6*12) / 12)))


{- |
Turn an event list with lazy times
to an event list with strict times.
This is much like the version we started on.
We could avoid this function with a more sophisticated version of 'arrange'.
-}
insertBreaks ::
   EventListTT.T LazyTime   (SigSt.T Double) ->
   EventListTT.T StrictTime (SigSt.T Double)
insertBreaks =
   EventListTT.foldr
      (\lt r ->
         case NonNegChunky.toChunksUnsafe (NonNegChunky.normalize lt) of
            [] -> EventListMT.consTime 0 r
            (t:ts) ->
               EventListMT.consTime t $
               foldr (\dt ->
                   EventListMT.consBody SigSt.empty .
                   EventListMT.consTime dt) r ts)
      EventListMT.consBody
      EventListBT.empty

getNoteSignal ::
   Int ->
   Instrument ->
   State
      (EventList.T StrictTime (Maybe ALSA.Event))
      (SigSt.T Double)
getNoteSignal chan instr =
   fmap (CutSt.arrangeEquidist defaultChunkSize .
         EventListTM.switchTimeR const .
         EventListTT.mapTime fromIntegral .
         insertBreaks .
         makeInstrumentSounds instr .
         matchNoteEvents) $
   getNoteEvents chan



ioToLazyList :: IO a -> IO [a]
ioToLazyList m =
   unsafeInterleaveIO $
      liftM2 (:) m (ioToLazyList m)


dump :: IO ()
dump =
   do putStrLn "Starting."
      h <- ALSA.open ALSA.default_seq_name ALSA.open_input ALSA.Block
      ALSA.set_client_name h "Haskell-Synthesizer"
      putStrLn "Created sequencer."
      p <- ALSA.create_simple_port h "one"
             (ALSA.caps [ALSA.cap_write, ALSA.cap_subs_write]) ALSA.type_midi_generic
      let loop = do putStrLn "waiting for an event:"
                    e <- ALSA.event_input h
                    print e
                    loop
      loop
      ALSA.delete_port h p
      putStrLn "Deleted ports."
      ALSA.close h
      putStrLn "Closed sequencer."


{- |
Latency is high using Sox -
Can we achieve better results using ALSA's sound output?
-}
playMonoSox ::
   (Storable a, RealField.C a) =>
   a -> SigSt.T a -> IO ()
playMonoSox rate =
   fmap (const ()) .
   Play.simple SigSt.hPut SoxOpt.none (round rate) .
   SigSt.map BinSmp.int16FromCanonical


defaultSampleRate :: Num a => a
defaultSampleRate = 48000
-- defaultSampleRate = 44100

bufferSize :: Int
bufferSize = 256

defaultChunkSize :: SigSt.ChunkSize
defaultChunkSize = SigSt.chunkSize bufferSize

latency :: Int
latency = 1000


{-
alsaOpen: only few buffer overruns with
       let buffer_time = 200000 -- 0.20s
           period_time =  40000 -- 0.04s

However the delay is still perceivable.
-}
playMono ::
   (Storable a, RealField.C a) =>
   a -> SigSt.T a -> IO ()
playMono rate xs =
   let sink = ALSASig.alsaSoundSink "plughw:0,0" soundFormat
       ys   = SigSt.map BinSmp.int16FromCanonical xs

       soundFormat :: ALSASig.SoundFmt
       soundFormat =
          ALSASig.SoundFmt {
             ALSASig.sampleFmt   = ALSASig.SampleFmtLinear16BitSignedLE,
             ALSASig.sampleFreq  = round rate,
             ALSASig.numChannels = 1
            }

   in  ALSASig.withSoundSink sink $ \to ->
       flip mapM_ (SVL.chunks (SigSt.append (SigSt.replicate defaultChunkSize latency 0) ys)) $ \c ->
       SV.withStartPtr c $ \ptr size ->
       ALSASig.soundSinkWrite sink to (Foreign.castPtr ptr) size