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)