reactive-balsa-0.0: src/Reactive/Banana/ALSA/KeySet.hs
module Reactive.Banana.ALSA.KeySet where
import qualified Reactive.Banana.ALSA.Common as Common
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.MIDI.ALSA as MALSA
import Sound.MIDI.ALSA (normalNoteFromEvent, )
-- import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import Sound.MIDI.Message.Channel (Channel, )
import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, )
import qualified Data.Accessor.Monad.Trans.State as AccState
-- import qualified Data.Accessor.Tuple as AccTuple
import qualified Data.Accessor.Basic as Acc
import Data.Accessor.Basic ((^.), (^=), )
import qualified Control.Monad.Trans.State as MS
import qualified Data.Map as Map
import qualified Data.Set as Set
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 [(Event.NoteEv, Event.Note)]
size :: set -> Int
toList :: set -> [((Pitch, Channel), Velocity)]
index :: Int -> set -> Maybe ((Pitch, Channel), Velocity)
change ::
Event.NoteEv -> Event.Note ->
MS.State set [(Event.NoteEv, Event.Note)]
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 notePart note =
let key =
(note ^. MALSA.notePitch,
note ^. MALSA.noteChannel)
in do
case normalNoteFromEvent notePart note of
(Event.NoteOn, vel) ->
MS.modify $ Pressed . Map.insert key vel . deconsPressed
(Event.NoteOff, _) ->
MS.modify $ Pressed . Map.delete key . deconsPressed
_ -> return ()
return [(notePart, note)]
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 ::
Event.NoteEv ->
Event.Note ->
MS.State Latch (Maybe (Event.NoteEv, Event.Note))
latchChange notePart note =
case normalNoteFromEvent notePart note of
(Event.NoteOn, vel) -> do
let key =
(note ^. MALSA.notePitch,
note ^. MALSA.noteChannel)
newNote =
(MALSA.noteVelocity ^= vel) note
isPressed <- MS.gets (Map.member key . deconsLatch)
if isPressed
then
MS.modify (Latch . Map.delete key . deconsLatch) >>
return (Just (Event.NoteOff, newNote))
else
MS.modify (Latch . Map.insert key vel . deconsLatch) >>
return (Just (Event.NoteOn, newNote))
(Event.NoteOff, _vel) ->
return Nothing
_ -> return Nothing
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 notePart note =
fmap maybeToList $ latchChange notePart note
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 notePart note =
let key =
(note ^. MALSA.notePitch,
note ^. MALSA.noteChannel)
in case normalNoteFromEvent notePart note of
(Event.NoteOn, vel) -> 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 [(Event.NoteOn, note)]
return $
noteOffs ++ noteOn
(Event.NoteOff, _vel) ->
AccState.modify groupLatchPressed (Set.delete key) >>
return []
_ -> 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 notePart note =
let key =
(note ^. MALSA.notePitch,
note ^. MALSA.noteChannel)
in case normalNoteFromEvent notePart note of
(Event.NoteOn, vel) -> 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)
++ [(notePart, note)]
(Event.NoteOff, _vel) -> return []
_ -> return [(notePart, note)]
releasePlayedKeys ::
MS.State
(Map.Map (Pitch, Channel) Velocity)
[(Event.NoteEv, Event.Note)]
releasePlayedKeys =
fmap (map (uncurry releaseKey) . Map.toList) $
AccState.getAndModify Acc.self (const Map.empty)
releaseKey ::
(Pitch, Channel) ->
Velocity ->
(Event.NoteEv, Event.Note)
releaseKey (p,c) vel =
(Event.NoteOff, Common.simpleNote c p vel)