module Reactive.Banana.ALSA.Common where

import qualified Reactive.Banana.ALSA.Time as Time

import qualified Sound.ALSA.Sequencer as SndSeq
import qualified Sound.ALSA.Sequencer.Address as Addr
import qualified Sound.ALSA.Sequencer.Client as Client
import qualified Sound.ALSA.Sequencer.Port as Port
import qualified Sound.ALSA.Sequencer.Port.InfoMonad as PortInfo
import qualified Sound.ALSA.Sequencer.Queue as Queue
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.ALSA.Sequencer.Connect as Connect
import qualified Sound.ALSA.Sequencer.Time as ATime

import qualified Control.Exception.Extensible as Exc
import qualified Sound.ALSA.Exception as AExc
import qualified Foreign.C.Error as Err

import qualified Sound.MIDI.ALSA as MALSA
import qualified Sound.MIDI.Message.Channel as ChannelMsg
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import qualified Sound.MIDI.Message.Channel.Mode as Mode

import Sound.MIDI.ALSA (normalNoteFromEvent, )
import Sound.MIDI.Message.Channel (Channel, )
import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, Controller, Program, )

import qualified Data.EventList.Relative.TimeBody as EventList

import Data.Accessor.Basic ((^.), (^=), )

import Control.Monad (mplus, )
import Data.List (intercalate, )
import Data.Maybe.HT (toMaybe, )
import Data.Tuple.HT (mapFst, mapSnd, )
import Data.Bool.HT (if', )

import qualified Data.Map as Map

import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.Trans.Reader as Reader
import Control.Monad.Trans.Reader (ReaderT, )

import qualified Numeric.NonNegative.Class as NonNeg

import qualified Data.Monoid as Mn

import Prelude hiding (init, filter, reverse, )


-- * helper functions

data Handle =
   Handle {
      sequ :: SndSeq.T SndSeq.DuplexMode,
      client :: Client.T,
      portPublic, portPrivate :: Port.T,
      queue :: Queue.T
   }

init :: IO Handle
init = do
   h <- SndSeq.open SndSeq.defaultName SndSeq.Block
   Client.setName h "Haskell-Filter"
   c <- Client.getId h
   ppublic <-
      Port.createSimple h "inout"
         (Port.caps [Port.capRead, Port.capSubsRead,
                     Port.capWrite, Port.capSubsWrite])
         Port.typeMidiGeneric
   pprivate <-
      Port.createSimple h "private"
         (Port.caps [Port.capRead, Port.capWrite])
         Port.typeMidiGeneric
   q <- Queue.alloc h
   let hnd = Handle h c ppublic pprivate q
   Reader.runReaderT setTimeStamping hnd
   return hnd

exit :: Handle -> IO ()
exit h = do
   _ <- Event.outputPending (sequ h)
   Queue.free (sequ h) (queue h)
   Port.delete (sequ h) (portPublic h)
   Port.delete (sequ h) (portPrivate h)
   SndSeq.close (sequ h)

with :: ReaderT Handle IO a -> IO a
with f =
   SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do
   Client.setName h "Haskell-Filter"
   c <- Client.getId h
   Port.withSimple h "inout"
         (Port.caps [Port.capRead, Port.capSubsRead,
                     Port.capWrite, Port.capSubsWrite])
         Port.typeMidiGeneric $ \ppublic -> do
   Port.withSimple h "private"
         (Port.caps [Port.capRead, Port.capWrite])
         Port.typeMidiGeneric $ \pprivate -> do
   Queue.with h $ \q ->
      flip Reader.runReaderT (Handle h c ppublic pprivate q) $
      setTimeStamping >> f

-- | make ALSA set the time stamps in incoming events
setTimeStamping :: ReaderT Handle IO ()
setTimeStamping =
   Reader.ReaderT $ \h ->
   PortInfo.modify (sequ h) (portPublic h) $ do
      PortInfo.setTimestamping True
      PortInfo.setTimestampReal True
      PortInfo.setTimestampQueue (queue h)


startQueue :: ReaderT Handle IO ()
startQueue = Reader.ReaderT $ \h -> do
   Queue.control (sequ h) (queue h) Event.QueueStart Nothing
   _ <- Event.drainOutput (sequ h)
   return ()


{- |
Connect ourselve to an input client and an output client.
The function expects a list of alternative clients
that are checked successively.
-}
connect :: [String] -> [String] -> ReaderT Handle IO ()
connect fromNames toNames = do
   _ <- connectFrom =<< parseAddresses fromNames
   _ <- connectTo   =<< parseAddresses toNames
   return ()

connectFrom, connectTo :: Addr.T -> ReaderT Handle IO Connect.T
connectFrom from = Reader.ReaderT $ \h ->
   Connect.createFrom (sequ h) (portPublic h) from
connectTo   to   = Reader.ReaderT $ \h ->
   Connect.createTo   (sequ h) (portPublic h) to

timidity, haskellSynth :: String
timidity = "TiMidity"
haskellSynth = "Haskell-LLVM-Synthesizer"

inputs, outputs :: [String]
inputs = ["ReMOTE SL", "E-MU Xboard61", "USB Midi Cable", "SAMSON Graphite 49"]
outputs = [timidity, haskellSynth, "Haskell-Synthesizer", "Haskell-Supercollider"]

connectTimidity :: ReaderT Handle IO ()
connectTimidity =
   connect inputs [timidity]

connectLLVM :: ReaderT Handle IO ()
connectLLVM =
   connect inputs [haskellSynth]

connectAny :: ReaderT Handle IO ()
connectAny =
   connect inputs outputs

parseAddresses :: [String] -> ReaderT Handle IO Addr.T
parseAddresses names = Reader.ReaderT $ \h ->
   let notFoundExc = Err.Errno 2
       go [] =
          Exc.throw $
          AExc.Cons
             "parseAdresses"
             ("could not find any of the clients: " ++ intercalate ", " names)
             notFoundExc
       go (x:xs) =
          AExc.catch (Addr.parse (sequ h) x) $
          \exc ->
             if AExc.code exc == notFoundExc
               then go xs
               else Exc.throw exc
   in  go names



-- * send single events

sendNote :: Channel -> Time.T -> Velocity -> Pitch -> ReaderT Handle IO ()
sendNote chan dur vel pit =
   let note = simpleNote chan pit vel
       t = Time.inc dur 0
   in  do outputEvent 0 (Event.NoteEv Event.NoteOn note)
          outputEvent t (Event.NoteEv Event.NoteOff note)

sendKey :: Channel -> Bool -> Velocity -> Pitch -> ReaderT Handle IO ()
sendKey chan noteOn vel pit =
   outputEvent 0 $
      Event.NoteEv
         (if noteOn then Event.NoteOn else Event.NoteOff)
         (simpleNote chan pit vel)

sendController :: Channel -> Controller -> Int -> ReaderT Handle IO ()
sendController chan ctrl val =
   outputEvent 0 $
      Event.CtrlEv Event.Controller $
      MALSA.controllerEvent chan ctrl (fromIntegral val)

sendProgram :: Channel -> Program -> ReaderT Handle IO ()
sendProgram chan pgm =
   outputEvent 0 $
      Event.CtrlEv Event.PgmChange $
      MALSA.programChangeEvent chan pgm

sendMode :: Channel -> Mode.T -> ReaderT Handle IO ()
sendMode chan mode =
   outputEvent 0 $
      Event.CtrlEv Event.Controller $
      MALSA.modeEvent chan mode


-- * constructors

channel :: Int -> Channel
channel = ChannelMsg.toChannel

pitch :: Int -> Pitch
pitch = VoiceMsg.toPitch

velocity :: Int -> Velocity
velocity = VoiceMsg.toVelocity

controller :: Int -> Controller
controller = VoiceMsg.toController

program :: Int -> Program
program = VoiceMsg.toProgram


normalVelocity :: VoiceMsg.Velocity
normalVelocity = VoiceMsg.normalVelocity



defaultTempoCtrl :: (Channel,Controller)
defaultTempoCtrl =
   (ChannelMsg.toChannel 0, VoiceMsg.toController 16)



-- * events

{- |
This class unifies several ways of handling multiple events at once.
-}
class Events ev where
   flattenEvents :: ev -> [Future Event.Data]

instance Events Event.Data where
   flattenEvents = singletonBundle

instance Events NoteBoundary where
   flattenEvents = singletonBundle . noteFromBnd

instance Events ev => Events (Future ev) where
   flattenEvents (Future dt ev) =
      map (\(Future t e) -> Future (Mn.mappend t dt) e) $
      flattenEvents ev

instance Events ev => Events (Maybe ev) where
   flattenEvents ev = maybe [] flattenEvents ev

instance Events ev => Events [ev] where
   flattenEvents = concatMap flattenEvents

instance (Events ev0, Events ev1) => Events (ev0,ev1) where
   flattenEvents (ev0,ev1) = flattenEvents ev0 ++ flattenEvents ev1

instance (Events ev0, Events ev1, Events ev2) => Events (ev0,ev1,ev2) where
   flattenEvents (ev0,ev1,ev2) =
      flattenEvents ev0 ++ flattenEvents ev1 ++ flattenEvents ev2


makeEvent :: Handle -> Time.Abs -> Event.Data -> Event.T
makeEvent h t e =
   (Event.simple (Addr.Cons (client h) (portPublic h)) e)
      { Event.queue = queue h
      , Event.time = ATime.consAbs $ Time.toStamp t
      }

makeEcho :: Handle -> Time.Abs -> Event.T
makeEcho h t =
   let addr = Addr.Cons (client h) (portPrivate h)
   in  (Event.simple addr (Event.CustomEv Event.Echo (Event.Custom 0 0 0)))
          { Event.queue = queue h
          , Event.time = ATime.consAbs $ Time.toStamp t
          , Event.dest = addr
          }


outputEvent :: Time.Abs -> Event.Data -> ReaderT Handle IO ()
outputEvent t ev = Reader.ReaderT $ \h ->
   Event.output (sequ h) (makeEvent h t ev) >>
   Event.drainOutput (sequ h) >>
   return ()


simpleNote :: Channel -> Pitch -> Velocity -> Event.Note
simpleNote c p v =
   Event.simpleNote
      (MALSA.fromChannel c)
      (MALSA.fromPitch p)
      (MALSA.fromVelocity v)


{- |
The times are relative to the start time of the bundle
and do not need to be ordered.
-}
data Future a = Future {futureTime :: Time.T, futureData :: a}
type Bundle a = [Future a]
type EventBundle = Bundle Event.T
type EventDataBundle = Bundle Event.Data

singletonBundle :: a -> Bundle a
singletonBundle ev = [now ev]

immediateBundle :: [a] -> Bundle a
immediateBundle = map now

now :: a -> Future a
now = Future Mn.mempty

instance Functor Future where
   fmap f (Future dt a) = Future dt $ f a


-- * effects

{- |
Transpose a note event by the given number of semitones.
Non-note events are returned without modification.
If by transposition a note leaves the range of representable MIDI notes,
then we return Nothing.
-}
transpose ::
   Int -> Event.Data -> Maybe Event.Data
transpose d e =
   case e of
      Event.NoteEv notePart note ->
         fmap (\p ->
            Event.NoteEv notePart $
            (MALSA.notePitch ^= p) note) $
         increasePitch d $
         note ^. MALSA.notePitch
      _ -> Just e

{- |
Swap order of keys.
Non-note events are returned without modification.
If by reversing a note leaves the range of representable MIDI notes,
then we return Nothing.
-}
reverse ::
   Event.Data -> Maybe Event.Data
reverse e =
   case e of
      Event.NoteEv notePart note ->
         fmap (\p ->
            Event.NoteEv notePart $
            (MALSA.notePitch ^= p) note) $
         maybePitch $ (60+64 -) $ VoiceMsg.fromPitch $
         note ^. MALSA.notePitch
      _ -> Just e

setChannel ::
   Channel -> Event.Data -> Event.Data
setChannel chan e =
   case e of
      Event.NoteEv notePart note ->
         Event.NoteEv notePart $
         (MALSA.noteChannel ^= chan) note
      Event.CtrlEv ctrlPart ctrl ->
         Event.CtrlEv ctrlPart $
         (MALSA.ctrlChannel ^= chan) ctrl
      _ -> e

{- |
> > replaceProgram [1,2,3,4] 5 [10,11,12,13]
> (True,[10,11,2,13])
-}
replaceProgram :: Real i => [i] -> i -> [i] -> (Bool, [i])
replaceProgram (n:ns) pgm pt =
   let (p,ps) =
          case pt of
             [] -> (0,[])
             (x:xs) -> (x,xs)
   in  if pgm<n
         then (True, pgm:ps)
         else mapSnd (p:) $
              replaceProgram ns (pgm-n) ps
replaceProgram [] _ ps = (False, ps)

programFromBanks :: Real i => [i] -> [i] -> i
programFromBanks ns ps =
   foldr (\(n,p) s -> p+n*s) 0 $
   zip ns ps

{- |
Interpret program changes as a kind of bank switches
in order to increase the range of instruments
that can be selected via a block of patch select buttons.

@programAsBanks ns@ divides the first @sum ns@ instruments
into sections of sizes @ns!!0, ns!!1, ...@.
Each program in those sections is interpreted as a bank in a hierarchy,
where the lower program numbers are the least significant banks.
Programs from @sum ns@ on are passed through as they are.
@product ns@ is the number of instruments
that you can address using this trick.
In order to avoid overflow it should be less than 128.

E.g. @programAsBanks [n,m]@ interprets subsequent program changes to
@a@ (@0<=a<n@) and @n+b@ (@0<=b<m@)
as a program change to @b*n+a@.
@programAsBanks [8,8]@ allows to select 64 instruments
by 16 program change buttons,
whereas @programAsBanks [8,4,4]@
allows to address the full range of MIDI 128 instruments
with the same number of buttons.
-}
programsAsBanks ::
   [Int] ->
   Event.Data -> State.State [Int] Event.Data
programsAsBanks ns e =
   case e of
      Event.CtrlEv Event.PgmChange ctrl -> State.state $ \ps0 ->
         let pgm = Event.ctrlValue ctrl
             (valid, ps1) =
                replaceProgram ns (fromIntegral $ Event.unValue pgm) ps0
         in  (Event.CtrlEv Event.PgmChange $
              ctrl{Event.ctrlValue =
                 if valid
                   then Event.Value $ fromIntegral $ programFromBanks ns ps1
                   else pgm},
              ps1)
      _ -> return e


nextProgram :: Event.Note -> State.State [Program] (Maybe Event.Data)
nextProgram note =
   State.state $ \pgms ->
   case pgms of
      pgm:rest ->
        (Just $
         Event.CtrlEv Event.PgmChange $
         Event.Ctrl {
            Event.ctrlChannel = Event.noteChannel note,
            Event.ctrlParam = Event.Parameter 0,
            Event.ctrlValue = MALSA.fromProgram pgm},
         rest)
      [] -> (Nothing, [])

seekProgram :: Int -> Program -> State.State [Program] (Maybe Event.Data)
seekProgram maxSeek pgm =
   fmap (const Nothing) $
   State.modify $
      uncurry (++) .
      mapFst (dropWhile (pgm/=)) .
      splitAt maxSeek


{- |
Before every note switch to another instrument
according to a list of programs given as state of the State monad.
I do not know how to handle multiple channels in a reasonable way.
Currently I just switch the instrument independent from the channel,
and send the program switch to the same channel as the beginning note.
-}
traversePrograms ::
   Event.Data -> State.State [Program] (Maybe Event.Data)
traversePrograms e =
   case e of
      Event.NoteEv notePart note ->
         (case fst $ normalNoteFromEvent notePart note of
             Event.NoteOn -> nextProgram note
             _ -> return Nothing)
      _ -> return Nothing

{- |
This function extends 'traversePrograms'.
It reacts on external program changes
by seeking an according program in the list.
This way we can reset the pointer into the instrument list.
However the search must be limited in order to prevent an infinite loop
if we receive a program that is not contained in the list.
-}
traverseProgramsSeek ::
   Int ->
   Event.Data -> State.State [Program] (Maybe Event.Data)
traverseProgramsSeek maxSeek e =
   case e of
      Event.NoteEv notePart note ->
         case fst $ normalNoteFromEvent notePart note of
            Event.NoteOn -> nextProgram note
            _ -> return Nothing
      Event.CtrlEv Event.PgmChange ctrl ->
         seekProgram maxSeek (ctrl ^. MALSA.ctrlProgram)
      _ -> return Nothing

reduceNoteVelocity ::
   Event.Velocity -> Event.Note -> Event.Note
reduceNoteVelocity (Event.Velocity decay) note =
   note{Event.noteVelocity =
      let Event.Velocity vel = Event.noteVelocity note
      in  if vel==0
            then Event.offVelocity
            else Event.Velocity $ vel - min decay (vel-1)}

delayAdd ::
   Event.Velocity -> Time.T -> Event.Data -> EventDataBundle
delayAdd decay d e =
   singletonBundle e ++
   case e of
      Event.NoteEv notePart note ->
         [Future d $
          Event.NoteEv notePart $
          reduceNoteVelocity decay note]
      _ -> []



{- |
Map NoteOn events to a controller value.
This way you may play notes via the resonance frequency of a filter.
-}
controllerFromNote ::
   (Int -> Int) ->
   VoiceMsg.Controller ->
   Event.Data -> Maybe Event.Data
controllerFromNote f ctrl e =
   case e of
      Event.NoteEv notePart note ->
         case fst $ normalNoteFromEvent notePart note of
            Event.NoteOn ->
               Just $
               Event.CtrlEv Event.Controller $
               MALSA.controllerEvent
                  (note ^. MALSA.noteChannel)
                  ctrl
                  (fromIntegral $ f $
                   fromIntegral $ VoiceMsg.fromPitch $
                   note ^. MALSA.notePitch)
            Event.NoteOff -> Nothing
            _ -> Just e
      _ -> Just e


type KeySet   = Map.Map (Pitch, Channel) Velocity
type KeyQueue = [((Pitch, Channel), Velocity)]

eventsFromKey ::
   Time.T -> Time.T -> ((Pitch, Channel), Velocity) ->
   EventDataBundle
eventsFromKey start dur ((pit,chan), vel) =
   Future start (Event.NoteEv Event.NoteOn  $ simpleNote chan pit vel) :
   Future (Mn.mappend start dur)
                (Event.NoteEv Event.NoteOff $ simpleNote chan pit vel) :
   []


maybePitch :: Int -> Maybe Pitch
maybePitch p =
   toMaybe
      (VoiceMsg.fromPitch minBound <= p  &&
       p <= VoiceMsg.fromPitch maxBound)
      (VoiceMsg.toPitch p)

increasePitch :: Int -> Pitch -> Maybe Pitch
increasePitch d p =
   maybePitch $ d + VoiceMsg.fromPitch p

subtractPitch :: Pitch -> Pitch -> Int
subtractPitch p0 p1 =
   VoiceMsg.fromPitch p1 - VoiceMsg.fromPitch p0


-- | properFraction is useless for negative numbers
splitFraction :: (RealFrac a) => a -> (Int, a)
splitFraction x =
   case floor x of
      n -> (n, x - fromIntegral n)


fraction :: RealFrac a => a -> a
fraction x =
   let n = floor x
   in  x - fromIntegral (n::Integer)


ctrlDur ::
   (Time.T, Time.T) -> Int -> Time.T
ctrlDur = ctrlDurExponential

ctrlDurLinear ::
   (Time.T, Time.T) -> Int -> Time.T
ctrlDurLinear (minDur, maxDur) val =
   let k = fromIntegral val / 127
   in  Time.scale (1-k) minDur `Mn.mappend` Time.scale k maxDur
--   minDur + Time.scale (fromIntegral val / 127) (maxDur-minDur)

ctrlDurExponential ::
   (Time.T, Time.T) -> Int -> Time.T
ctrlDurExponential (minDur, maxDur) val =
   Time.scale (Time.div maxDur minDur ** (fromIntegral val / 127)) minDur


{-
ctrlRange ::
   (RealFrac b) =>
   (b,b) -> (a -> b) -> (a -> Int)
ctrlRange (l,u) f x =
   round $
   limit (0,127) $
   127*(f x - l)/(u-l)
-}


-- * predicates - may be moved to midi-alsa package

controllerMatch ::
   Channel -> Controller -> Event.Ctrl -> Bool
controllerMatch chan ctrl param =
   Event.ctrlChannel param == MALSA.fromChannel chan &&
   Event.ctrlParam   param == MALSA.fromController ctrl

checkChannel ::
   (Channel -> Bool) ->
   (Event.Data -> Bool)
checkChannel p e =
   case e of
      Event.NoteEv _notePart note ->
         p (note ^. MALSA.noteChannel)
      Event.CtrlEv Event.Controller ctrl ->
         p (ctrl ^. MALSA.ctrlChannel)
      _ -> False

checkPitch ::
   (Pitch -> Bool) ->
   (Event.Data -> Bool)
checkPitch p e =
   case e of
      Event.NoteEv _notePart note ->
         p (note ^. MALSA.notePitch)
      _ -> False

checkController ::
   (Controller -> Bool) ->
   (Event.Data -> Bool)
checkController p e =
   case e of
      Event.CtrlEv Event.Controller ctrlMode ->
         case ctrlMode ^. MALSA.ctrlControllerMode of
            MALSA.Controller ctrl _ -> p ctrl
            _ -> False
      _ -> False

checkMode ::
   (Mode.T -> Bool) ->
   (Event.Data -> Bool)
checkMode p e =
   case e of
      Event.CtrlEv Event.Controller ctrlMode ->
         case ctrlMode ^. MALSA.ctrlControllerMode of
            MALSA.Mode mode -> p mode
            _ -> False
      _ -> False

checkProgram ::
   (Program -> Bool) ->
   (Event.Data -> Bool)
checkProgram p e =
   case e of
      Event.CtrlEv Event.PgmChange ctrl ->
         p (ctrl ^. MALSA.ctrlProgram)
      _ -> False


isAllNotesOff :: Event.Data -> Bool
isAllNotesOff =
   checkMode $ \mode ->
      mode == Mode.AllSoundOff ||
      mode == Mode.AllNotesOff



data NoteBoundary =
     NoteBoundary (Pitch, Channel) Velocity Bool
   deriving (Eq, Show)

data NoteBoundaryExt =
     NoteBoundaryExt NoteBoundary
   | AllNotesOff
   deriving (Eq, Show)

maybeNote :: Event.Data -> Maybe NoteBoundary
maybeNote ev =
   case ev of
      Event.NoteEv notePart note ->
         let key =
                (note ^. MALSA.notePitch,
                 note ^. MALSA.noteChannel)
         in  case normalNoteFromEvent notePart note of
                (Event.NoteOn,  vel) -> Just $ NoteBoundary key vel True
                (Event.NoteOff, vel) -> Just $ NoteBoundary key vel False
                _ -> Nothing
      _ -> Nothing

maybeNoteExt :: Event.Data -> Maybe NoteBoundaryExt
maybeNoteExt ev =
   mplus
      (fmap NoteBoundaryExt $ maybeNote ev)
      (toMaybe (isAllNotesOff ev) AllNotesOff)

noteFromBnd :: NoteBoundary -> Event.Data
noteFromBnd (NoteBoundary (pit,chan) vel on) =
   Event.NoteEv
      (if' on Event.NoteOn Event.NoteOff)
      (simpleNote chan pit vel)


-- * event list support

mergeStable ::
   (NonNeg.C time) =>
   EventList.T time body ->
   EventList.T time body ->
   EventList.T time body
mergeStable =
   EventList.mergeBy (\_ _ -> True)

mergeEither ::
   (NonNeg.C time) =>
   EventList.T time a ->
   EventList.T time b ->
   EventList.T time (Either a b)
mergeEither xs ys =
   mergeStable (fmap Left xs) (fmap Right ys)