module Sound.MIDI.ALSA.EventList where
{-
ToDo:
fix laziness issues in splitting and merging
Maybe this cannot be fixed at all.
In the Causal module this problem is solved.
-}

import Sound.MIDI.ALSA.Common
          (Bundle, EventDataBundle, Time, TimeAbs,
           Handle, PatternMono, PatternPoly,
           sequ, with, incTime,
           singletonBundle, checkController, checkChannel,
           checkProgram, checkPitch,
           SweepState, sweepSpeed, sweepPhase, sweepDepth, sweepCenter,
           updateDur, updateChord, )
import qualified Sound.MIDI.ALSA.Common as Common

import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.ALSA.Exception as Exc

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 Sound.MIDI.Message.Channel (Channel, )
import Sound.MIDI.Message.Channel.Voice (Controller, Program, )

import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Data.EventList.Absolute.TimeBody as EventListAbs

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

import qualified Data.List.HT as ListHT
import qualified Data.List.Match as Match
import Data.Tuple.HT (mapFst, mapSnd, mapPair, )
import Data.Ord.HT (limit, )
import qualified Data.List as List
import Data.Maybe (mapMaybe, )

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 Control.Monad.IO.Class (liftIO, )
import qualified Control.Applicative as App
import Control.Monad (liftM2, guard, )
import qualified Data.Foldable as Fold
import qualified Data.Traversable as Trav

import qualified Numeric.NonNegative.Class as NonNeg

import Data.Int (Int32, )

import System.IO.Unsafe (unsafeInterleaveIO, )

import Prelude hiding (init, filter, )


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


inputEventsCore :: ReaderT Handle IO [Event.T]
inputEventsCore =
   Reader.ReaderT $ \h ->
   ioToLazyList (Event.input (sequ h))

inputEvents :: ReaderT Handle IO (EventList.T Time Event.Data)
inputEvents =
   fmap (EventList.fromAbsoluteEventList .
         EventListAbs.fromPairList .
         map (\ev -> (Common.timeFromStamp (Event.timestamp ev),
                      Event.body ev))) $
   inputEventsCore


pairListFromRelativeEvents :: EventList.T Time a -> [(TimeAbs,a)]
pairListFromRelativeEvents =
   EventListAbs.toPairList .
   EventListAbs.mapTime Common.deconsTime .
   EventList.toAbsoluteEventList 0

outputEvents :: EventList.T Time Event.Data -> ReaderT Handle IO ()
outputEvents =
   mapM_ (uncurry Common.outputEvent) .
   pairListFromRelativeEvents


{- |
Sends (drain) each event individually
since the events in the bundle might be created in a lazy manner.
-}
outputEventBundles :: EventList.T Time EventDataBundle -> ReaderT Handle IO ()
outputEventBundles =
   mapM_
      (\(t,evs) ->
         flip mapM_ evs (\(dt,ev) ->
            Common.outputEvent (incTime dt t) ev)) .
   pairListFromRelativeEvents

outputEventBundled :: EventList.T Time EventDataBundle -> ReaderT Handle IO ()
outputEventBundled =
   mapM_
      (\(t,evs) -> Reader.ReaderT $ \h ->
         flip mapM_ evs (\(dt,ev) ->
            Event.output (sequ h) (Common.makeEvent h (incTime dt t) ev)) >>
         Event.drainOutput (sequ h) >>
         return ()) .
   pairListFromRelativeEvents


data Trigger a =
     Regular a
   | Trigger

instance Functor Trigger where
   fmap f (Regular a) = Regular (f a)
   fmap _ Trigger     = Trigger

instance Fold.Foldable Trigger where
   foldMap = Trav.foldMapDefault

instance Trav.Traversable Trigger where
   sequenceA (Regular a) = fmap Regular a
   sequenceA Trigger     = App.pure Trigger


type EventDataTrigger = Bundle (Trigger Event.Data)

makeTriggerEvent :: Handle -> TimeAbs -> Trigger Event.Data -> Event.T
makeTriggerEvent h t x =
   case x of
      Regular ev -> Common.makeEvent h t ev
      Trigger -> Common.makeEcho h t (Event.Custom 0 0 0)

makeTriggerEvents :: Handle -> TimeAbs -> EventDataTrigger -> [Event.T]
makeTriggerEvents h t =
   map (\(dt,ev) -> makeTriggerEvent h (incTime dt t) ev)

{- |
This function distinguishes between events from portIn
and events that are generated by us.
Our generated events must also send an echo to the input port
in order to break 'event_input' and thus trigger their delivery.
-}
outputTriggerEvents ::
   EventList.T Time EventDataTrigger ->
   ReaderT Handle IO ()
outputTriggerEvents =
   mapM_
      (\(t,ee) -> Reader.ReaderT $ \h ->
         mapM_
            (\e ->
                Event.output (sequ h) e >>
                Event.drainOutput (sequ h))
            (makeTriggerEvents h t ee)
          >> return ()) .
   pairListFromRelativeEvents

mergeGenerated ::
   EventList.T Time (Bundle a) ->
   EventList.T Time (Bundle a) ->
   EventList.T Time (Bundle (Trigger a))
mergeGenerated gens ins =
   merge
      (fmap (\t -> [(t, Trigger)]) $ EventList.fromPairList $
       ListHT.mapAdjacent (,) (0 : EventList.getTimes gens))
      (fmap (map (mapSnd Regular)) $
       merge gens ins)


{- ToDo: move to eventlist package -}
equidistantEvents :: Time -> [a] -> EventList.T Time a
equidistantEvents dur as =
   case as of
      [] -> EventList.empty
      x:xs ->
         EventList.cons 0 x $
         EventList.fromPairList (map ((,) dur) xs)

whirl :: EventList.T Time EventDataBundle
whirl =
   let dur = 0.125
       notes =
          cycle $ concat $ concatMap (replicate 4) $
             [57, 59, 60, 64] :
             [57, 59, 60, 65] :
             [57, 62, 64, 65] :
             [57, 59, 60, 64] :
             []
       ctrls =
          map (\t -> round (80 + 47 * sin t)) (iterate (0.1+) (0::Double))
       events =
          zipWith (:)
             (map
                (\k -> (0, Event.CtrlEv Event.Controller (Event.Ctrl
                   {Event.ctrlChannel = 0,
                    Event.ctrlParam = 23,
                    Event.ctrlValue = k})))
                ctrls)
             (map
                (\k ->
                   (0,   Event.NoteEv Event.NoteOn  $ Event.simpleNote 0 k 64) :
                   (dur, Event.NoteEv Event.NoteOff $ Event.simpleNote 0 k 64) :
                   [])
                notes)

   in  EventList.cons 0
          [(0, Event.CtrlEv Event.PgmChange (Event.Ctrl
                  {Event.ctrlChannel = 0,
                   Event.ctrlParam = 0,
                   Event.ctrlValue = 5}))] $
       equidistantEvents dur events


mergeGeneratedAtoms ::
   (Time -> a) ->
   EventList.T Time a ->
   EventList.T Time a ->
   EventList.T Time a
mergeGeneratedAtoms trigger gens ins =
   Common.mergeStable
      (fmap trigger $ EventList.fromPairList $
       ListHT.mapAdjacent (,) (0 : EventList.getTimes gens))
      (Common.mergeStable gens ins)

patternMono ::
   PatternMono i ->
   Time ->
   EventList.T Time Event.Data ->
   EventList.T Time EventDataTrigger
patternMono (Common.PatternMono select ixs) dur ins =
   flip State.evalState Map.empty $ Trav.sequenceA $
   mergeGeneratedAtoms
      (\dt -> return [(dt, Trigger)])
      (fmap
          (\n -> State.gets (map (mapSnd Regular) . select n dur . Map.toAscList))
          (equidistantEvents dur ixs))
      (fmap
          (\e ->
             case e of
                Event.NoteEv notePart note -> do
                   State.modify (updateChord notePart note)
                   return []
                _ -> return $ singletonBundle (Regular e))
          ins)


patternMonoTempo ::
   PatternMono i ->
   ((Channel,Controller), (Time,Time,Time)) ->
   EventList.T Time Event.Data ->
   EventList.T Time EventDataTrigger
patternMonoTempo
      (Common.PatternMono select ixs0)
      ((chan,ctrl), (minDur, defltDur, maxDur)) =
   let recourse dur chord ixs =
          EventList.switchL EventList.empty $ \(time,me) rest ->
          uncurry (EventList.cons time) $
          case me of
             Nothing ->
                case ixs of
                   [] -> ([], recourse dur chord ixs rest)
                   i:ir ->
                      ((dur, Trigger) :
                       map (mapSnd Regular) (select i dur $ Map.toAscList chord),
                       recourse dur chord ir $
                       EventList.insertBy (\_ _ -> True) dur Nothing rest)
             Just e ->
                case e of
                   Event.NoteEv notePart note ->
                      ([],
                       recourse dur (updateChord notePart note chord) ixs rest)
                   Event.CtrlEv Event.Controller param |
                          Common.controllerMatch chan ctrl param ->
                      ([],
                       recourse
                          (updateDur param (minDur,maxDur))
                          chord ixs rest)
                   _ -> (singletonBundle (Regular e),
                         recourse dur chord ixs rest)
   in  recourse defltDur Map.empty ixs0 .
       EventList.insertBy (\_ _ -> True) defltDur Nothing .
       fmap Just


{- |
This allows more complex patterns including pauses,
notes of different lengths and simultaneous notes.
-}
patternPolyTempo ::
   PatternPoly i ->
   ((Channel,Controller), (Time,Time,Time)) ->
   EventList.T Time Event.Data ->
   EventList.T Time EventDataTrigger
patternPolyTempo
      (Common.PatternPoly select ixs0)
      ((chan,ctrl), (minDur, defltDur, maxDur)) =
   let recourse dur chord ixs =
          EventList.switchL EventList.empty $ \(time,me) rest ->
          uncurry (EventList.cons time) $
          case me of
             Nothing ->
                EventList.switchL
                   ([], recourse dur chord ixs rest)
                   (\(t,is) ir0 ->
                      let (notes,ir1) =
                             if t>0
                               then ([], EventList.cons (t-1) is ir0)
                               else
                                 (do Common.IndexNote d i <- is
                                     evs <-
                                        select i (fromIntegral d * dur) $
                                        Map.toAscList chord
                                     return (mapSnd Regular evs),
                                  ir0)
                      in  ((dur, Trigger) : notes,
                           recourse dur chord ir1 $
                           EventList.insertBy (\_ _ -> True) dur Nothing rest))
                   ixs
             Just e ->
                case e of
                   Event.NoteEv notePart note ->
                      ([],
                       recourse dur (updateChord notePart note chord) ixs rest)
                   Event.CtrlEv Event.Controller param |
                          Common.controllerMatch chan ctrl param ->
                      ([],
                       recourse
                          (updateDur param (minDur,maxDur))
                          chord ixs rest)
                   _ -> (singletonBundle (Regular e),
                         recourse dur chord ixs rest)
   in  recourse defltDur Map.empty ixs0 .
       EventList.insertBy (\_ _ -> True) defltDur Nothing .
       fmap Just


class Pattern pat where
   patternTempo ::
      pat ->
      ((Channel,Controller), (Time,Time,Time)) ->
      EventList.T Time Event.Data ->
      EventList.T Time EventDataTrigger

instance Pattern (PatternMono i) where
   patternTempo = patternMonoTempo

instance Pattern (PatternPoly i) where
   patternTempo = patternPolyTempo


{- |
Automatically changes the value of a MIDI controller
every @period@ seconds according to a periodic wave.
The wave function is a mapping
from the phase in @[0,1)@
to a controller value in the range @(-1,1)@.
The generation of the wave is controlled by a speed controller
(@minSpeed@ and @maxSpeed@ are in waves per second),
the modulation depth and the center value.
The center controller is also the one where we emit our wave.
That is, when modulation depth is zero
then this effect is almost the same
as forwarding the controller without modification.
The small difference is, that we emit a controller value at a regular patternMono,
whereas direct control would mean
that only controller value changes are transfered.

> sweep channel
>    period (speedCtrl, (minSpeed, maxSpeed)) depthCtrl centerCtrl
>    (ctrlRange (-1,1) (sin . (2*pi*)))

We could use the nice Wave abstraction from the synthesizer package,
but that's a heavy dependency because of multi-parameter type classes.
-}
sweep ::
   Channel ->
   Time ->
   (Controller, (Time,Time)) ->
   Controller ->
   Controller ->
   (Double -> Double) ->
   EventList.T Time Event.Data ->
   EventList.T Time EventDataTrigger
sweep chan dur (speedCtrl, (minSpeed, maxSpeed)) depthCtrl centerCtrl
      wave ins =
   flip State.evalState
       (Common.SweepState {
          sweepSpeed =
             realToFrac $ Common.deconsTime $
             dur*(minSpeed+maxSpeed)/2,
          sweepDepth = 64,
          sweepCenter = 64,
          sweepPhase = 0
        }) $
   Trav.sequenceA $
   mergeGeneratedAtoms
      (\dt -> return [(dt, Trigger)])
      (fmap
          (\() -> do
              ev <-
                 State.gets (\s ->
                    Event.CtrlEv Event.Controller $
                    Event.Ctrl {
                       Event.ctrlChannel = MALSA.fromChannel chan,
                       Event.ctrlParam = MALSA.fromController centerCtrl,
                       Event.ctrlValue =
                          round $ limit (0,127) $
                          sweepCenter s + sweepDepth s * wave (sweepPhase s)
                    })
              State.modify (\s ->
                 s{sweepPhase = Common.fraction (sweepPhase s + sweepSpeed s)})
              return $ singletonBundle (Regular ev))
          (equidistantEvents dur $ repeat ()))
      (fmap
          (\e ->
             maybe (return $ singletonBundle (Regular e))
                   (\f -> State.modify f >> return []) $ do
                Event.CtrlEv Event.Controller param <- Just e
                let c = param ^. MALSA.ctrlChannel
                    ctrl = param ^. MALSA.ctrlController
                    x :: Num a => a
                    x = fromIntegral (Event.ctrlValue param)
                guard (c==chan)
                lookup ctrl $
                   (speedCtrl,
                    \s -> s{sweepSpeed =
                       realToFrac $ Common.deconsTime $ (dur *) $
                       minSpeed + (maxSpeed-minSpeed) * x/127}) :
                   (depthCtrl,  \s -> s{sweepDepth = x}) :
                   (centerCtrl, \s -> s{sweepCenter = x}) :
                   [])
          ins)


-- * combinators

{- |
The function maintains empty bundles
in order to maintain laziness breaks.
These breaks are import for later merging of the streams.
-}
filter ::
   (a -> Bool) ->
   State.State
      (EventList.T Time (Bundle a))
      (EventList.T Time (Bundle a))
filter p = State.state $
   EventList.foldrPair
      (\t evs ->
         let (evsT,evsF) =
                List.partition (p . snd) evs
         in  mapPair
                (EventList.cons t evsT,
                 EventList.cons t evsF))
      (EventList.empty, EventList.empty)

filterSimple ::
   (a -> Bool) ->
   EventList.T Time (Bundle a) ->
   EventList.T Time (Bundle a)
filterSimple p =
   EventList.foldrPair
      (\t evs ->
         EventList.cons t (List.filter (p . snd) evs))
      EventList.empty

{-
merge ::
   EventList.T Time (Bundle a) ->
   EventList.T Time (Bundle a) ->
   EventList.T Time (Bundle a)
merge x y =
{-
   fmap concat $
   EventList.collectCoincident $
-}
   Common.mergeStable x y
-}

merge ::
   EventList.T Time (Bundle a) ->
   EventList.T Time (Bundle a) ->
   EventList.T Time (Bundle a)
merge x0 y0 =
   flip (EventList.switchL y0) x0 $ \(tx,bx) rx ->
   flip (EventList.switchL x0) y0 $ \(ty,by) ry ->
      let (tz, ~(bz, rz)) =
             mapSnd
                (\ ~(b,d) ->
                   if b
                     then
                       mapFst (bx++) $
                       if d == NonNeg.zero
                         then (by, merge rx ry)
                         else ([], merge rx (EventList.cons d by ry))
                     else
                       (by, merge (EventList.cons d bx rx) ry)) $
             NonNeg.split tx ty
      in  EventList.cons tz bz rz


-- * run filters

process ::
   (EventList.T Time Event.Data ->
    EventList.T Time EventDataTrigger) ->
   ReaderT Handle IO ()
process f = do
   Common.startQueue
   outputTriggerEvents . f =<< inputEvents

processSimple ::
   (EventList.T Time Event.Data ->
    EventList.T Time EventDataBundle) ->
   ReaderT Handle IO ()
processSimple f = do
   Common.startQueue
   outputEventBundles . f =<< inputEvents


runWhirl :: ReaderT Handle IO ()
runWhirl =
   process
      ({-
       we must prepend the trigger event,
       otherwise 'mergeGenerated' makes us wait for the first user event
       -}
       EventList.cons 0 [(0,Trigger)] .
       mergeGenerated whirl .
       fmap singletonBundle)

runDelay :: ReaderT Handle IO ()
runDelay =
   processSimple (fmap (Common.delayAdd 50 0.3))

runKeyboardSplit :: ReaderT Handle IO ()
runKeyboardSplit =
   processSimple $
   uncurry merge .
   State.runState (do
      low <-
         filter (\e ->
            (checkChannel (ChannelMsg.toChannel 0 ==) e &&
             checkPitch   (VoiceMsg.toPitch 60 >) e) ||
            checkController (VoiceMsg.toController 91 ==) e ||
            checkController (VoiceMsg.toController 93 ==) e)
      return $
         fmap (mapMaybe (\(t,p) -> fmap ((,) t) $ Common.transpose 12 p) .
               map (mapSnd (Common.setChannel (ChannelMsg.toChannel 1)))) low) .
   fmap singletonBundle

runKeyboardSplitLow :: ReaderT Handle IO ()
runKeyboardSplitLow =
   processSimple $
   fmap (mapMaybe (\(t,p) -> fmap ((,) t) $ Common.transpose 12 p) .
         map (mapSnd (Common.setChannel (ChannelMsg.toChannel 1)))) .
   filterSimple (\e ->
      (checkChannel (ChannelMsg.toChannel 0 ==) e &&
       checkPitch   (VoiceMsg.toPitch 60 >) e) ||
      checkController (VoiceMsg.toController 91 ==) e ||
      checkController (VoiceMsg.toController 93 ==) e) .
   fmap singletonBundle

runKeyboardSplitHigh :: ReaderT Handle IO ()
runKeyboardSplitHigh =
   processSimple $
--   fmap (map (mapSnd (setChannel (ChannelMsg.toChannel 0)))) .
   filterSimple (\e ->
      (checkChannel (ChannelMsg.toChannel 0 ==) e &&
       checkPitch   (VoiceMsg.toPitch 60 <=) e) ||
      checkController (const True) e ||
      checkProgram (const True) e) .
   fmap singletonBundle

{- this defers events occasionally
   EventList.collectCoincident .
   fmap ((,) 0)
-}


{- |
> runCyclePrograms (map VoiceMsg.toProgram [8..12])
-}
runCyclePrograms :: [Program] -> ReaderT Handle IO ()
runCyclePrograms pgms =
   processSimple
      (fmap Common.immediateBundle .
       flip State.evalState (cycle pgms) .
       Trav.traverse (Common.traverseProgramsSeek (length pgms)))

{- |
> runProgramsAsBanks [8,4,4]
-}
runProgramsAsBanks :: [Int32] -> ReaderT Handle IO ()
runProgramsAsBanks ns =
   processSimple
      (fmap singletonBundle .
       flip State.evalState (Match.replicate ns 0) .
       Trav.traverse (Common.programsAsBanks ns))

{- |
> runPattern 0.12 (cycleUp 4)
-}
runPattern ::
   Time ->
   PatternMono i ->
   ReaderT Handle IO ()
runPattern dur pat =
   process (patternMono pat dur)

{- |
> runPatternTempo 0.12 (cycleUp 4)

> runPatternTempo 0.2 (PatternMono selectFromOctaveChord (cycle [0,1,2,0,1,2,0,1]))

> runPatternTempo 0.1 (PatternPoly selectFromLimittedChord (let pat = [item 0 1] ./ 1 /. [item 1 1] ./ 2 /. [item 1 1] ./ 1 /. [item 0 1] ./ 2 /. pat in 0 /. pat))
-}
runPatternTempo ::
   Pattern pat =>
   Time ->
   pat ->
   ReaderT Handle IO ()
runPatternTempo dur pat =
   process
      (patternTempo pat
         (Common.defaultTempoCtrl, (1.5*dur, dur, 0.5*dur)))


runFilterSweep ::
   ReaderT Handle IO ()
runFilterSweep =
   process
      (sweep (ChannelMsg.toChannel 1)
         0.01 (VoiceMsg.toController 72, (0.1, 1))
         (VoiceMsg.toController 73) (VoiceMsg.toController 91)
         (sin . (2*pi*)))




main :: IO ()
main = (with $ do
   liftIO $ putStrLn "Please connect me to a synth"
   _ <- liftIO $ getLine
   Common.startQueue
   liftIO . mapM_ print =<< inputEventsCore
   outputEvents =<< inputEvents
   outputEventBundles whirl
   outputEvents . EventList.mapMaybe (Common.transpose 1) =<< inputEvents)

  `Exc.catch` \e ->
      putStrLn $ "alsa_exception: " ++ Exc.show e