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
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_ :: Set.Set (Pitch, Channel),
groupLatchPlayed_ :: 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_
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_
instance C SerialLatch where
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