{-# LANGUAGE ExistentialQuantification #-}
module Sound.MIDI.ALSA.Causal (
   T,
   lift,
   liftPoint,
   map,
   parallel,
   eitherIn,
   traverse,
   flatten,
   process,
   transpose,
   reverse,
   delayAdd,

   Pattern,
   patternMono,

   TempoControl,
   patternTempo,
   patternMonoTempo,
   patternPolyTempo,
   patternSerialTempo,

   sweep,
   partition,
   guide,
   guideWithMode,
   cyclePrograms,
   cycleProgramsDefer,
   latch,
   groupLatch,
   serialLatch,
   guitar,
   trainer,
   ) where

import Sound.MIDI.ALSA.Common (Time, TimeAbs, normalVelocity, )
import qualified Sound.MIDI.ALSA.Common as Common
import qualified Sound.MIDI.ALSA.Guitar as Guitar

import qualified Sound.ALSA.Sequencer.Address as Addr
import qualified Sound.ALSA.Sequencer.Event as Event

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

import Sound.MIDI.ALSA (normalNoteFromEvent, )
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 qualified Data.Accessor.Monad.Trans.RWS as AccRWS
import qualified Data.Accessor.Monad.Trans.State as AccState
import qualified Data.Accessor.Tuple as AccTuple
import Data.Accessor.Basic ((^.), (^=), )

import Data.Tuple.HT (fst3, )
import Data.Ord.HT (limit, comparing, )
import Data.Maybe (maybeToList, )
import qualified Data.List.Match as Match
import qualified Data.List as List

import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Control.Category as Cat
import qualified Control.Applicative as App
import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.Trans.Reader as Reader
import qualified Control.Monad.Trans.RWS as RWS
import qualified Control.Monad.Trans.Class as Trans
import qualified Data.Traversable as Trav
import Control.Category ((.), id, )
import Control.Monad.Trans.Reader (ReaderT, )
import Control.Monad (guard, when, )

import qualified Data.Monoid as Mn
import Data.Word (Word8, )

import Prelude hiding (init, map, filter, reverse, (.), id, )


{- |
The list of scheduled triggers must be finite.

This process cannot drop an incoming event.
In order to do so, you must write something of type @T a (Maybe b)@.
For convenience you could wrap this in something like @Ext a b@.
-}
data T a b =
   forall s c.
   Cons
      (Either c a -> RWS.RWS TimeAbs (Triggers c) s b)
      s (Triggers c)


newtype Triggers c = Triggers (EventList.T Time c)

instance Functor Triggers where
   fmap f (Triggers evs) = Triggers $ fmap f evs

instance Mn.Monoid (Triggers c) where
   mempty = Triggers $ EventList.empty
   mappend (Triggers x) (Triggers y) =
      Triggers (Common.mergeStable x y)

{-
data T a b =
   forall s c.
   Cons (Time -> Either c a ->
         State.State s (Maybe b, Maybe (Time,c)))
-}
{-
This design allows to modify a trigger event until it fires.
However, when can we ship it?
We only know, if a later event comes in,
that the trigger would have been shipped already.
Alternatively we can always ship them via ALSA
and filter them out on arrival, when they were canceled in the meantime.
To this end we could attach a unique id to every Echo message
and on ALSA input we accept only the message with the most recent id.

data T a b =
   forall s c.
   Cons (Time -> Either c a ->
         State.State (s, Maybe (Time,c)) (Maybe b))
-}
{-
data T a b =
   forall s trigger.
   Trigger trigger =>
   Cons (Time -> Maybe a ->
         State.State (s, trigger) (Maybe b))

'trigger' is a nested structure of time-stamped objects,
where each leaf object corresponds to a process in the chain.
E.g. (Maybe (Time, x), Maybe (Time, y))
In order to reduce recomputation,
there might be a special type for pairs that stores the minimum time stamp.
-}
{-
data T a b =
   forall s c.
   Cons (Time -> Maybe a ->
         State.State (s, EventList.T Time c) (Maybe b))
-}


-- * combinators

{- |
Here we abuse the 'Applicative' constraint.
Actually we only need 'pure'.
-}
lift ::
   (App.Applicative t, Trav.Traversable t) =>
   T a b -> T (t a) (t b)
lift = liftPoint App.pure

{- |
Typical instance for the traversable type 't' are '[]' and 'Maybe'.
-}
liftPoint ::
   (Trav.Traversable t) =>
   (b -> t b) {- should be replaced by Pointed constraint -} ->
   T a b -> T (t a) (t b)
liftPoint pure (Cons f s cs0) =
   Cons
      (\ ea ->
         case ea of
            Left c ->
               fmap pure $ f $ Left c
            Right ta ->
               Trav.mapM (f . Right) ta)
      s cs0


map :: (a -> b) -> T a b
map f =
   Cons
      {-
      In case of a trigger, we use the trigger data for output.
      Since there won't ever be a trigger,
      we never have to create an output object.
      -}
      (return . either id f)
      () Mn.mempty


mergeEither :: Triggers a -> Triggers b -> Triggers (Either a b)
mergeEither (Triggers eva) (Triggers evb) =
   Triggers $ Common.mergeEither eva evb

compose :: T b c -> T a b -> T a c
compose (Cons g sg tg) (Cons f sf tf) =
   Cons
      (\ma -> do
         b <-
            routeLeft $
            case ma of
               Right a ->
                  fmap Right $ f (Right a)
               Left (Left et) ->
                  fmap Right $ f (Left et)
               Left (Right et) ->
                  return $ Left et
         routeRight $ g b)
      (sf,sg)
      (mergeEither tf tg)

{- |
Run two stream processor in parallel.
We cannot use the @Arrow@ method @&&&@
since we cannot define the @first@ method of the @Arrow@ class.
Consider @first :: arrow a b -> arrow (c,a) (c,b)@
and a trigger where @arrow a b@ generates an event of type @b@.
How could we generate additionally an event of type @c@
without having an input event?
-}
parallel ::
   (Mn.Monoid b) =>
   T a b -> T a b -> T a b
parallel (Cons f sf tf) (Cons g sg tg) =
   Cons (\ea ->
      case ea of
         Right a ->
            App.liftA2
               Mn.mappend
               (routeLeft  $ f $ Right a)
               (routeRight $ g $ Right a)
         Left (Left et) ->
            routeLeft  $ f $ Left et
         Left (Right et) ->
            routeRight $ g $ Left et)
      (sf,sg)
      (mergeEither tf tg)

eitherIn ::
   T a c -> T b c -> T (Either a b) c
eitherIn (Cons f sf tf) (Cons g sg tg) =
   Cons (\ea ->
      case ea of
         Right (Left a) ->
            routeLeft  $ f $ Right a
         Right (Right b) ->
            routeRight $ g $ Right b
         Left (Left et) ->
            routeLeft  $ f $ Left et
         Left (Right et) ->
            routeRight $ g $ Left et)
      (sf,sg)
      (mergeEither tf tg)

routeLeft ::
   RWS.RWS r (Triggers w0) s0 a ->
   RWS.RWS r (Triggers (Either w0 w1)) (s0, s1) a
routeLeft =
   mapWriter (fmap Left) .
   AccRWS.lift AccTuple.first

routeRight ::
   RWS.RWS r (Triggers w1) s1 a ->
   RWS.RWS r (Triggers (Either w0 w1)) (s0, s1) a
routeRight =
   mapWriter (fmap Right) .
   AccRWS.lift AccTuple.second

scheduleSingleTrigger :: Time -> c -> RWS.RWS r (Triggers c) s ()
scheduleSingleTrigger t c =
   RWS.tell $ singleTrigger t c

singleTrigger :: Time -> c -> Triggers c
singleTrigger t c =
   Triggers $ EventList.singleton t c


instance Cat.Category T where
   id = map id
   (.) = compose


traverse :: s -> (a -> State.State s b) -> T a b
traverse s f =
   Cons
      (rwsFromState . either id f)
      s Mn.mempty

-- | input is most oftenly of type 'Common.EventDataBundle'
flatten :: T (Common.Bundle a) (Maybe a)
flatten = Cons
   (\e ->
      case e of
         Left ev -> return $ Just ev
         Right evs -> do
            RWS.tell $ Triggers $
               EventList.fromAbsoluteEventList $
               EventListAbs.fromPairList $
               List.sortBy (comparing fst) evs
            return Nothing)
   () Mn.mempty


partition :: (a -> Bool) -> T a (Maybe a, Maybe a)
partition p =
   map (\a -> if p a then (Just a, Nothing) else (Nothing, Just a))


_guideMonoid ::
   (Mn.Monoid b) =>
   (a -> Bool) -> T a b -> T a b -> T a b
_guideMonoid p f g =
   map (maybe Mn.mempty id)
   .
   parallel
      (lift f . map fst)
      (lift g . map snd)
   .
   partition p

guide ::
   (a -> Bool) -> T a b -> T a b -> T a b
guide p f g =
   eitherIn f g
   .
   map (\x -> if p x then Left x else Right x)

{-
In some cases where we would like to use 'guide',
channel mode messages like 'ModeMsg.AllNotesOff'
must be directed to both branches,
because they may end up in different MIDI channels.
-}
guideWithMode ::
   (Mn.Monoid b) =>
   (Event.Data -> Bool) ->
   T Event.Data b -> T Event.Data b -> T Event.Data b
guideWithMode p f g =
   map Mn.mconcat
   .
   parallel
      (map maybeToList . lift f . map fst)
      (map maybeToList . lift g . map snd)
   .
   map (\e ->
      if Common.checkMode (const True) e
        then (Just e, Just e)
        else if p e then (Just e, Nothing) else (Nothing, Just e))


-- * driver

{- |
TODO:
We should allow the process to access and modify the ALSA port number.
-}
process ::
   T Event.Data Common.EventDataBundle ->
   ReaderT Common.Handle IO ()
process (Cons f s (Triggers initTriggers)) = do
   Common.startQueue
   Reader.ReaderT $ \h ->
      {-
      Triggers maintains a priority queue parallelly to the queue of ALSA.
      We need this in order to associate Haskell values
      with the incoming trigger events.
      -}
      let outputTriggers triggers =
             EventListAbs.mapM_
                (\t ->
                   Event.output (Common.sequ h)
                      (Common.makeEcho h (Common.deconsTime t) (Event.Custom 0 0 0))
                    >> return ())
                (const $ return ())
                (EventList.toAbsoluteEventList 0 triggers)
          go s0 (lastTime,triggers0) = do
{-
             print (realToFrac lastTime :: Double,
                    List.map
                       ((realToFrac :: TimeAbs -> Double) . Common.deconsTime) $
                    EventList.getTimes triggers0)
-}
             ev <- Event.input (Common.sequ h)
             let time =
                    Common.deconsTime $
                    Common.timeFromStamp (Event.timestamp ev)
                 triggers1 =
                    EventList.decreaseStart
                       (Common.consTime "Causal.process.decreaseStart" (time-lastTime))
                       triggers0
                 (restTriggers1, (dats, s1, Triggers newTriggers)) =
                    case Event.body ev of
                       Event.CustomEv Event.Echo _ ->
                          case (Event.source ev ==
                                   Addr.Cons (Common.client h) (Common.portPrivate h),
                                EventList.viewL triggers1) of
                             (True, Just ((_,c),restTriggers0)) ->
                                (restTriggers0,
                                 RWS.runRWS (f (Left c)) time s0)
                             _ ->
                                (EventList.empty, ([], s0, Mn.mempty))
                       dat ->
                          (triggers1,
                           RWS.runRWS (f (Right dat)) time s0)

             flip mapM_ dats $ \(dt,dat) ->
                Event.output (Common.sequ h)
                   (Common.makeEvent h (Common.incTime dt time) dat)
             outputTriggers
                (EventList.delay (Common.consTime "Causal.process.delay" time) $
                 newTriggers)
             _ <- Event.drainOutput (Common.sequ h)
             go s1 (time,
                    Common.mergeStable restTriggers1 newTriggers)
      in  outputTriggers initTriggers >>
          Event.drainOutput (Common.sequ h) >>
          go s (0,initTriggers)


-- * musical examples

transpose :: Int -> T Event.Data (Maybe Event.Data)
transpose d =
   map (Common.transpose d)

{- |
Swap order of keys.
This is a funny effect and a new challenge to playing a keyboard.
-}
reverse :: T Event.Data (Maybe Event.Data)
reverse =
   map Common.reverse

delayAdd ::
   Word8 -> Time -> T Event.Data Common.EventDataBundle
delayAdd decay d =
   map (Common.delayAdd decay d)


patternMono ::
   Common.PatternMono i ->
   Time ->
   T Event.Data Common.EventDataBundle
patternMono (Common.PatternMono select ixs) dur =
   Cons
      (\ ee ->
         case ee of
            Left (n:ns) -> do
               keys <- RWS.get
               scheduleSingleTrigger dur ns
               return $ select n dur $ Map.toAscList keys
            Left [] ->
               return []
            Right e ->
               case e of
                  Event.NoteEv notePart note -> do
                     RWS.modify (Common.updateChord notePart note)
                     return []
                  _ -> return $ Common.singletonBundle e)
      Map.empty (singleTrigger 0 ixs)

updateChordDur ::
   (Channel, Controller) ->
   (Time, Time) ->
   Event.Data ->
   State.State
      (Time, Common.KeySet)
      (Common.EventDataBundle)
updateChordDur chanCtrl minMaxDur e =
   case e of
      Event.NoteEv notePart note -> do
         AccState.modify AccTuple.second (Common.updateChord notePart note)
         return []
      Event.CtrlEv Event.Controller param |
            uncurry Common.controllerMatch chanCtrl param -> do
         AccState.set AccTuple.first (Common.updateDur param minMaxDur)
         return []
      _ -> return $ Common.singletonBundle e


type TempoControl = ((Channel,Controller), (Time,Time,Time))

patternMonoTempo ::
   Common.PatternMono i ->
   TempoControl ->
   T Event.Data Common.EventDataBundle
patternMonoTempo
      (Common.PatternMono select ixs)
      ((chan,ctrl), (minDur, defltDur, maxDur)) =
   Cons
      (\ ee ->
         case ee of
            Left (n:ns) -> do
               (dur,keys) <- RWS.get
               scheduleSingleTrigger dur ns
               return $ select n dur $ Map.toAscList keys
            Left [] ->
               return []
            Right e ->
               rwsFromState $
               updateChordDur (chan,ctrl) (minDur,maxDur) e)
      (defltDur, Map.empty)
      (singleTrigger 0 ixs)

patternPolyTempo ::
   Common.PatternPoly i ->
   TempoControl ->
   T Event.Data Common.EventDataBundle
patternPolyTempo
      (Common.PatternPoly select ixs)
      ((chan,ctrl), (minDur, defltDur, maxDur)) =
   let next dur rest =
          EventList.switchL
             EventList.empty
             (\(t,_) _ ->
                EventList.singleton (fromIntegral t * dur) rest)
             rest
   in  Cons
          (\ ee ->
             case ee of
                Left nt ->
                   EventList.switchL
                      (return [])
                      (\(_,is) rest -> do
                         (dur,keys) <- RWS.get
                         RWS.tell $ Triggers $ next dur rest
                         return $ do
                            Common.IndexNote d i <- is
                            select i (fromIntegral d * dur) $
                               Map.toAscList keys)
                      nt
                Right e ->
                   rwsFromState $
                   updateChordDur (chan,ctrl) (minDur,maxDur) e)
          (defltDur, Map.empty)
          (Triggers $ next defltDur ixs)


class Pattern pat where
   patternTempo ::
      pat ->
      TempoControl ->
      T Event.Data Common.EventDataBundle

instance Pattern (Common.PatternMono i) where
   patternTempo = patternMonoTempo

instance Pattern (Common.PatternPoly i) where
   patternTempo = patternPolyTempo



{-
TODO:
This should not prepend a new key to the queue,
but we should maintain an array of maxNum elements,
where the n-th key is put into the @mod n maxNum@ array element.
-}
updateSerialChord ::
   Int ->
   Event.NoteEv -> Event.Note ->
   Common.KeyQueue -> Common.KeyQueue
updateSerialChord maxNum notePart note chord =
   let key =
          (note ^. MALSA.notePitch,
           note ^. MALSA.noteChannel)
   in  case normalNoteFromEvent notePart note of
          (Event.NoteOn, vel) -> take maxNum $ (key, vel) : chord
          _ -> chord

updateSerialChordDur ::
   Int ->
   (Channel, Controller) ->
   (Time, Time) ->
   Event.Data ->
   State.State
      (Time, Common.KeyQueue)
      (Common.EventDataBundle)
updateSerialChordDur maxNum chanCtrl minMaxDur e =
   case e of
      Event.NoteEv notePart note -> do
         AccState.modify AccTuple.second (updateSerialChord maxNum notePart note)
         return []
      Event.CtrlEv Event.Controller param |
            uncurry Common.controllerMatch chanCtrl param -> do
         AccState.set AccTuple.first (Common.updateDur param minMaxDur)
         return []
      _ -> return $
         Common.singletonBundle e

{-
TODO:
It should react on 'ModeMsg.AllNotesOff' and 'ModeMsg.AllSoundOff'.
Is there a way to merge it with 'serialLatch'?
-}
patternSerialTempo ::
   Int ->
   Common.PatternMono i ->
   TempoControl ->
   T Event.Data Common.EventDataBundle
patternSerialTempo
      maxNum (Common.PatternMono select ixs)
      ((chan,ctrl), (minDur, defltDur, maxDur)) =
   Cons
      (\ ee ->
         case ee of
            Left (n:ns) -> do
               (dur,keys) <- RWS.get
               scheduleSingleTrigger dur ns
               return $ select n dur keys
            Left [] ->
               return []
            Right e ->
               rwsFromState $
               updateSerialChordDur maxNum (chan,ctrl) (minDur,maxDur) e)
      (defltDur, [])
      (singleTrigger 0 ixs)


sweep ::
   Channel ->
   Time ->
   (Controller, (Time,Time)) ->
   Controller ->
   Controller ->
   (Double -> Double) ->
   T Event.Data [Event.Data]
sweep chan dur (speedCtrl, (minSpeed, maxSpeed)) depthCtrl centerCtrl
      wave =
   Cons
      (\ ee ->
         case ee of
            Left () -> do
               ev <-
                  RWS.gets $ \s ->
                     Event.CtrlEv Event.Controller $
                     MALSA.controllerEvent chan centerCtrl $
                     round $ limit (0,127) $
                     Common.sweepCenter s +
                        Common.sweepDepth s * wave (Common.sweepPhase s)
               RWS.modify $ \s ->
                  s{Common.sweepPhase =
                      Common.fraction (Common.sweepPhase s + Common.sweepSpeed s)}
               scheduleSingleTrigger dur ()
               return [ev]
            Right e ->
               maybe (return [e])
                     (\f -> RWS.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{Common.sweepSpeed =
                         realToFrac $ Common.deconsTime $ (dur *) $
                         minSpeed + (maxSpeed-minSpeed) * x/127}) :
                     (depthCtrl,  \s -> s{Common.sweepDepth = x}) :
                     (centerCtrl, \s -> s{Common.sweepCenter = x}) :
                     [])
      (Common.SweepState {
         Common.sweepSpeed =
            realToFrac $ Common.deconsTime $
            dur*(minSpeed+maxSpeed)/2,
         Common.sweepDepth = 64,
         Common.sweepCenter = 64,
         Common.sweepPhase = 0
       })
      (singleTrigger 0 ())

cyclePrograms :: [Program] -> T Event.Data [Event.Data]
cyclePrograms pgms =
   traverse (cycle pgms)
      (Common.traverseProgramsSeek (length pgms))


{- |
> cycleProgramsDefer t

After a note that triggers a program change,
we won't change the program in the next 't' seconds.
This is in order to allow chords being played
and in order to skip accidentally played notes.
-}
{-
In the future we might also add a time-out:
After a certain time, where no key is pressed,
the program would be reset to the initial program.
-}
cycleProgramsDefer :: Time -> [Program] -> T Event.Data [Event.Data]
cycleProgramsDefer defer pgms =
   Cons
      (either
         (\() -> do
            AccRWS.set AccTuple.second False
            return [])
         (\e -> do
            -- FIXME: traverseProgramsSeek is not called, if a program change is received
            block <- RWS.gets snd
            case (block, e) of
               (False, Event.NoteEv notePart note) ->
                  case fst $ normalNoteFromEvent notePart note of
                     Event.NoteOn -> do
                        AccRWS.set AccTuple.second True
                        scheduleSingleTrigger defer ()
                        AccRWS.lift AccTuple.first $ rwsFromState $
                           Common.traverseProgramsSeek (length pgms) e
                     _ -> return [e]
               _ -> return [e]))
      (cycle pgms, False) Mn.mempty


latch :: T Event.Data (Maybe Event.Data)
latch =
   traverse Set.empty
      (\e ->
         case e of
            Event.NoteEv notePart note ->
               case normalNoteFromEvent notePart note of
                  (Event.NoteOn, vel) -> do
                     let key =
                            (note ^. MALSA.notePitch,
                             note ^. MALSA.noteChannel)
                         newNote =
                            (MALSA.noteVelocity ^= vel) note
                     pressed <- State.gets (Set.member key)
                     if pressed
                       then
                          State.modify (Set.delete key) >>
                          return (Just (Event.NoteEv Event.NoteOff newNote))
                       else
                          State.modify (Set.insert key) >>
                          return (Just (Event.NoteEv Event.NoteOn newNote))
                  (Event.NoteOff, _vel) ->
                     return Nothing
                  _ -> return (Just e)
            _ -> return (Just e))

releaseKey ::
   VoiceMsg.Velocity ->
   (VoiceMsg.Pitch, Channel) ->
   Event.Data
releaseKey vel (p,c) =
   Event.NoteEv Event.NoteOff $
   Common.simpleNote c p vel

releasePlayedKeys ::
   VoiceMsg.Velocity ->
   State.State
      (a, Set.Set (VoiceMsg.Pitch, Channel))
      [Event.Data]
releasePlayedKeys vel =
   fmap (fmap (releaseKey vel) . Set.toList) $
   AccState.getAndModify AccTuple.second (const Set.empty)


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

{- |
All pressed keys are latched until a key is pressed after a pause
(i.e. all keys released).
For aborting the pattern you have to send
a 'ModeMsg.AllNotesOff' or 'ModeMsg.AllSoundOff' message.
-}
groupLatch :: T Event.Data [Event.Data]
groupLatch =
   traverse
      (Set.empty {- pressed keys (input) -},
       Set.empty {- played keys (output) -})
      (\e ->
         case e of
            Event.NoteEv notePart note ->
               let key =
                      (note ^. MALSA.notePitch,
                       note ^. MALSA.noteChannel)
               in  case normalNoteFromEvent notePart note of
                      (Event.NoteOn, vel) -> do
                         pressed <- AccState.get AccTuple.first
                         noteOffs <-
                            if Set.null pressed
                              then releasePlayedKeys vel
                              else return []
                         AccState.modify AccTuple.first (Set.insert key)
                         played <- AccState.get AccTuple.second
                         noteOn <-
                            if Set.member key played
                              then
                                 return []
                              else do
                                 AccState.modify AccTuple.second (Set.insert key)
                                 return [Event.NoteEv Event.NoteOn note]
                         return $
                            noteOffs ++ noteOn
                      (Event.NoteOff, _vel) ->
                         AccState.modify AccTuple.first (Set.delete key) >>
                         return []
                      _ -> return [e]
            _ ->
               if isAllNotesOff e
                 then releasePlayedKeys normalVelocity
                 else return [e])

{- |
A key is hold until @n@ times further keys are pressed.
The @n@-th pressed key replaces the current one.
-}
serialLatch :: Int -> T Event.Data [Event.Data]
serialLatch n =
   traverse
      (0, Map.empty)
      (\e ->
         case e of
            Event.NoteEv notePart note ->
               let key =
                      (note ^. MALSA.notePitch,
                       note ^. MALSA.noteChannel)
               in  case normalNoteFromEvent notePart note of
                      (Event.NoteOn, vel) -> do
                         k <- AccState.getAndModify AccTuple.first (flip mod n . (1+))
                         oldKey <- fmap (Map.lookup k) $ AccState.get AccTuple.second
                         AccState.modify AccTuple.second (Map.insert k key)
                         return $
                            maybeToList (fmap (releaseKey vel) oldKey) ++ [e]
                      (Event.NoteOff, _vel) -> return []
                      _ -> return [e]
            _ ->
               if isAllNotesOff e
                 then
                    fmap (fmap (releaseKey normalVelocity) . Map.elems) $
                    AccState.getAndModify AccTuple.second (const Map.empty)
                 else return [e])



newtype PitchChannel =
   PitchChannel ((VoiceMsg.Pitch, Channel), VoiceMsg.Velocity)
   deriving (Show)

instance Eq PitchChannel where
   (PitchChannel ((p0,_), _)) == (PitchChannel ((p1,_), _)) =
      p0 == p1

instance Ord PitchChannel where
   compare (PitchChannel ((p0,_), _)) (PitchChannel ((p1,_), _)) =
      compare p0 p1

instance Guitar.Transpose PitchChannel where
   getPitch (PitchChannel ((p,_), _)) =
      VoiceMsg.fromPitch p
   transpose d (PitchChannel ((p,c),v)) = do
      p' <- Common.increasePitch d p
      return $ PitchChannel ((p',c), v)


noteSequence ::
   (Num a) =>
   a -> Event.NoteEv -> [Event.Note] -> [(a, Event.Data)]
noteSequence stepTime onOff notes =
   zip (iterate (stepTime+) 0) $
   fmap (Event.NoteEv onOff) notes

{- |
Try for instance @guitar 0.05 0.03@.

This process simulates playing chords on a guitar.
If you press some keys like C, E, G on the keyboard,
then this process figures out what tones would be played on a guitar
and plays them one after another with short delays.
If you release the keys then the chord is played in reverse order.
This simulates the hand going up and down on the guitar strings.
Unfortunatley it is not possible to go up twice or go down twice this way.
The octaves of the pressed keys are ignored.

In detail calling @guitar collectTime stepTime@ means:
If a key is pressed,
then collect all key-press events for the next @collectTime@ seconds.
After this period, send out a guitar-like chord pattern for the pressed keys
with a delay of @stepTime@ between the notes.
Now wait until all keys are released.
Note that in the meantime keys could have been pressed or released.
They are registered, but not played.
If all keys are released then send out the reverse chord.

On an AllSoundOff message, release all played tones.

I don't know whether emitted key-events are always consistent.
-}
guitar :: Time -> Time -> T Event.Data Common.EventDataBundle
guitar collectTime stepTime = Cons
   (\ee ->
      case ee of
         Left () -> do
            pressed <- AccRWS.get AccTuple.first3
            played <- AccRWS.get AccTuple.second3
            let chord =
                   fmap (\(PitchChannel ((p,c),v)) ->
                      MALSA.noteEvent c p v v 0) $
                   Guitar.mapChordToString Guitar.stringPitches $
                   fmap PitchChannel $
                   Map.toAscList pressed
            AccRWS.set AccTuple.second3 chord
            return $
               (noteSequence stepTime Event.NoteOff $
                List.reverse played)
               ++
               noteSequence stepTime Event.NoteOn chord
         Right e ->
            case e of
               Event.NoteEv notePart note -> do
                  let key =
                         (note ^. MALSA.notePitch,
                          note ^. MALSA.noteChannel)
                      normalNote =
                         normalNoteFromEvent notePart note
                  case normalNote of
                     (Event.NoteOn, vel) ->
                        AccRWS.modify AccTuple.first3 (Map.insert key vel)
                     (Event.NoteOff, _vel) ->
                        AccRWS.modify AccTuple.first3 (Map.delete key)
                     _ -> return ()

                  down <- AccRWS.get AccTuple.third3
                  if down
                    then do
                      allKeysReleased <-
                         RWS.gets (Map.null . fst3)
                      if allKeysReleased
                        then do
                          AccRWS.set AccTuple.third3 False
                          played <- AccRWS.get AccTuple.second3
                          return $
                             noteSequence stepTime Event.NoteOff played
                             ++
                             (noteSequence stepTime Event.NoteOn $
                              List.reverse played)
                        else return []
                    else
                      fmap (const []) $
                      case fst normalNote of
                         Event.NoteOn -> do
                            scheduleSingleTrigger collectTime ()
                            AccRWS.set AccTuple.third3 True
                         _ -> return ()
               _ ->
                  if isAllNotesOff e
                    then do
                       player <- AccRWS.getAndModify AccTuple.second3 (const [])
                       return $ Common.immediateBundle $
                          fmap (Event.NoteEv Event.NoteOff) player
                    else return $ Common.singletonBundle e)
   (Map.empty {- pressed keys (input) -},
    []        {- played tones (output) -},
    False)
   Mn.mempty


{- |
Audio perception trainer

Play sets of notes and
let the human player answer to them according to a given scheme.
Repeat playing the notes sets until the trainee answers correctly.
Then continue with other sequences, maybe more complicated ones.

possible tasks:

 - replay a sequence of pitches on the keyboard:
      single notes for training abolute pitches,
      intervals all with the same base notes,
      intervals with different base notes

 - transpose a set of pitches:
      tranpose to a certain base note,
      transpose by a certain interval

 - play a set of pitches in a different order:
      reversed order,
      in increasing pitch

 - replay a set of simultaneously pressed keys

The difficulty can be increased by not connecting
the keyboard directly with the sound generator.
This way, the trainee cannot verify,
how the pressed keys differ from the target keys.

Sometimes it seems that you are catched in an infinite loop.
This happens if there were too many keys pressed.
The trainer collects all key press events,
not only the ones that occur after the target set is played.
This way you can correct yourself immediately,
before the target is repeatedly played.
The downside is, that there may be key press events hanging around.
You can get rid of them by pressing a key again and again,
but slowly, until the target is played, again.
Then the queue of registered keys should be empty
and you can proceed training.
-}
trainer ::
   Channel ->
   Time -> Time -> [([VoiceMsg.Pitch], [VoiceMsg.Pitch])] ->
   T Event.Data Common.EventDataBundle
trainer chan pause duration sets0 = Cons
   (\ee ->
      case ee of
         Left () -> do
            sets <- AccRWS.get AccTuple.first
            return $
               case sets of
                  (target, _) : _ ->
                     concat $
                     zipWith
                        (\t p ->
                           [(t, Event.NoteEv Event.NoteOn $
                                Common.simpleNote chan p normalVelocity),
                            (t+duration,
                                Event.NoteEv Event.NoteOff $
                                Common.simpleNote chan p normalVelocity)])
                        (iterate (duration+) 0) target
                  [] -> []
         Right (Event.NoteEv notePart note) ->
            case fst $ normalNoteFromEvent notePart note of
               Event.NoteOn -> do
                  pressed <- AccRWS.get AccTuple.second
                  let newPressed = (note ^. MALSA.notePitch) : pressed
                  AccRWS.set AccTuple.second newPressed
                  sets <- AccRWS.get AccTuple.first
                  case sets of
                     (_, target) : rest ->
                        when (Match.lessOrEqualLength target newPressed) $ do
                           AccRWS.set AccTuple.second []
                           when (newPressed == List.reverse target) $
                              AccRWS.set AccTuple.first rest
                           scheduleSingleTrigger pause ()
                     _ -> return ()
                  return []
               _ -> return []
         _ -> return [])
   (sets0, [])
   (singleTrigger 0 ())



-- * auxiliary functions for monad transformers

rwsFromState ::
   (Mn.Monoid w, Monad m) =>
   State.StateT s m a -> RWS.RWST r w s m a
rwsFromState act = do
   s0 <- RWS.get
   (a,s1) <- Trans.lift $ State.runStateT act s0
   RWS.put s1
   return a


mapWriter ::
   (Mn.Monoid w0, Mn.Monoid w1, Monad m) =>
   (w0 -> w1) -> RWS.RWST r w0 s m a -> RWS.RWST r w1 s m a
mapWriter f act =
   RWS.RWST $ \r s0 -> do
      (a, s1, w) <- RWS.runRWST act r s0
      return (a, s1, f w)