KeySet.hs

module Reactive.Banana.ALSA.KeySet where

import Reactive.Banana.ALSA.Common (NoteBoundary(NoteBoundary), )

import Sound.MIDI.Message.Channel (Channel, )
import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, )

import qualified Data.Traversable as Trav

import qualified Data.Accessor.Monad.Trans.State as AccState
import qualified Data.Accessor.Basic as Acc

import qualified Control.Monad.Trans.State as MS

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

import Data.Maybe.HT (toMaybe, )
import Data.Maybe (maybeToList, )


{-
class C set where
   press :: Channel -> (Velocity, Pitch) -> set -> set
   release :: Channel -> (Velocity, Pitch) -> set -> set
   reset :: set -> set

change :: C set => Channel -> (Velocity, Pitch, Bool) -> set -> set
change chan (vel, pitch, True)  = press   chan (vel, pitch)
change chan (vel, pitch, False) = release chan (vel, pitch)
-}

class C set where
   reset :: MS.State set [NoteBoundary]
   size :: set -> Int
   toList :: set -> [((Pitch, Channel), Velocity)]
   index :: Int -> set  -> Maybe ((Pitch, Channel), Velocity)
   change :: NoteBoundary -> MS.State set [NoteBoundary]



newtype Pressed = Pressed {deconsPressed :: Map.Map (Pitch, Channel) Velocity}
   deriving (Show)

pressed :: Pressed
pressed = Pressed Map.empty

pressedAcc :: Acc.T Pressed (Map.Map (Pitch, Channel) Velocity)
pressedAcc = Acc.fromWrapper Pressed deconsPressed

instance C Pressed where
   reset = AccState.lift pressedAcc releasePlayedKeys
   size = Map.size . deconsPressed
   toList = Map.toAscList . deconsPressed
   index k (Pressed set) =
      case drop k $ Map.toAscList set of
         x:_ -> Just x
         _ -> Nothing
   change bnd@(NoteBoundary key vel on) = do
      AccState.modify pressedAcc $
         if on
           then Map.insert key vel
           else Map.delete key
      return [bnd]



newtype Latch = Latch {deconsLatch :: Map.Map (Pitch, Channel) Velocity}
   deriving (Show)

latch :: Latch
latch = Latch Map.empty

latchAcc :: Acc.T Latch (Map.Map (Pitch, Channel) Velocity)
latchAcc = Acc.fromWrapper Latch deconsLatch

latchChange ::
   NoteBoundary ->
   MS.State Latch (Maybe NoteBoundary)
latchChange (NoteBoundary key vel on) =
   Trav.sequence $ toMaybe on $ do
      isPressed <- MS.gets (Map.member key . deconsLatch)
      if isPressed
        then
           AccState.modify latchAcc (Map.delete key) >>
           return (NoteBoundary key vel False)
        else
           AccState.modify latchAcc (Map.insert key vel) >>
           return (NoteBoundary key vel True)

instance C Latch where
   reset = AccState.lift latchAcc releasePlayedKeys
   size = Map.size . deconsLatch
   toList = Map.toAscList . deconsLatch
   index k (Latch set) =
      case drop k $ Map.toAscList set of
         x:_ -> Just x
         _ -> Nothing
   change = fmap maybeToList . latchChange



data GroupLatch =
   GroupLatch {
      groupLatchPressed_ {- input -} :: Set.Set (Pitch, Channel),
      groupLatchPlayed_ {- output -} :: Map.Map (Pitch, Channel) Velocity
   } deriving (Show)

groupLatch :: GroupLatch
groupLatch = GroupLatch Set.empty Map.empty

groupLatchPressed :: Acc.T GroupLatch (Set.Set (Pitch, Channel))
groupLatchPressed =
   Acc.fromSetGet
      (\mp grp -> grp{groupLatchPressed_ = mp})
      groupLatchPressed_

groupLatchPlayed :: Acc.T GroupLatch (Map.Map (Pitch, Channel) Velocity)
groupLatchPlayed =
   Acc.fromSetGet
      (\mp grp -> grp{groupLatchPlayed_ = mp})
      groupLatchPlayed_

{- |
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.
-}
instance C GroupLatch where
   reset = AccState.lift groupLatchPlayed releasePlayedKeys
   size = Map.size . groupLatchPlayed_
   toList = Map.toAscList . groupLatchPlayed_
   index k set =
      case drop k $ Map.toAscList $ groupLatchPlayed_ set of
         x:_ -> Just x
         _ -> Nothing
   change (NoteBoundary key vel on) =
      if on
        then do
           pressd <- AccState.get groupLatchPressed
           noteOffs <-
              if Set.null pressd
                then AccState.lift groupLatchPlayed releasePlayedKeys
                else return []
           AccState.modify groupLatchPressed (Set.insert key)
           played <- AccState.get groupLatchPlayed
           noteOn <-
              if Map.member key played
                then
                   return []
                else do
                   AccState.modify groupLatchPlayed (Map.insert key vel)
                   return [NoteBoundary key vel True]
           return $
              noteOffs ++ noteOn
        else
           AccState.modify groupLatchPressed (Set.delete key) >>
           return []



data SerialLatch =
   SerialLatch {
      serialLatchSize_ :: Int,
      serialLatchCursor_ :: Int,
      serialLatchPlayed_ :: Map.Map Int ((Pitch, Channel), Velocity)
   } deriving (Show)

serialLatch :: Int -> SerialLatch
serialLatch num = SerialLatch num 0 Map.empty

serialLatchCursor :: Acc.T SerialLatch Int
serialLatchCursor =
   Acc.fromSetGet
      (\mp grp -> grp{serialLatchCursor_ = mp})
      serialLatchCursor_

serialLatchPlayed :: Acc.T SerialLatch (Map.Map Int ((Pitch, Channel), Velocity))
serialLatchPlayed =
   Acc.fromSetGet
      (\mp grp -> grp{serialLatchPlayed_ = mp})
      serialLatchPlayed_



{- |
A key is hold until @n@ times further keys are pressed.
The @n@-th pressed key replaces the current one.
-}
instance C SerialLatch where
--   reset = AccState.lift serialLatchPlayed releasePlayedKeys
--      (0, Map.empty)
   reset =
      fmap (map (uncurry releaseKey) . Map.elems) $
      AccState.getAndModify serialLatchPlayed (const Map.empty)
   size = serialLatchSize_
   toList = Map.elems . serialLatchPlayed_
   index k = Map.lookup k . serialLatchPlayed_
   change bnd@(NoteBoundary key vel on) =
      if on
        then do
           n <- MS.gets serialLatchSize_
           k <- AccState.getAndModify serialLatchCursor (flip mod n . (1+))
           oldKey <- fmap (Map.lookup k) $ AccState.get serialLatchPlayed
           AccState.modify serialLatchPlayed (Map.insert k (key, vel))
           return $ maybeToList (fmap (uncurry releaseKey) oldKey)
                     ++ [bnd]
        else return []

releasePlayedKeys ::
   MS.State
      (Map.Map (Pitch, Channel) Velocity)
      [NoteBoundary]
releasePlayedKeys =
   fmap (map (uncurry releaseKey) . Map.toList) $
   AccState.getAndModify Acc.self (const Map.empty)

releaseKey ::
   (Pitch, Channel) ->
   Velocity -> NoteBoundary
releaseKey key vel =
   NoteBoundary key vel False