From 1bed0c53f8bdd6c3c5fb1346524ab133a45763dd Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Mon, 7 Dec 2015 16:18:08 -0500 Subject: Store note velocities in pitch sets (actually pitch maps, now) --- AlsaSeq.hs | 30 ++++++++++++++++++++++++++---- midi-dump.hs | 42 ++++++++++++++++++++++-------------------- 2 files changed, 48 insertions(+), 24 deletions(-) diff --git a/AlsaSeq.hs b/AlsaSeq.hs index 5b65967..0512c80 100644 --- a/AlsaSeq.hs +++ b/AlsaSeq.hs @@ -1,7 +1,7 @@ {-# LANGUAGE NondecreasingIndentation #-} -module AlsaSeq (withAlsaInit, parseAlsaEvents, parseAlsaEvents', forwardNoteEvent, -cmdlineAlsaConnect, printChordLn, showChord, pitchList, showPitch, -unPitch, unChannel, MidiHook, MidiPitchSet) where +module AlsaSeq (withAlsaInit, parseAlsaEvents, parseAlsaEvents', parseAlsaEvents'', forwardNoteEvent, +cmdlineAlsaConnect, printChordLn, printChordLn', showChord, pitchList, showPitch, +unPitch, unChannel, MidiHook, MidiPitchSet, MidiPitchMap) where import qualified Sound.ALSA.Exception as AlsaExc import qualified Sound.ALSA.Sequencer.Address as Addr import qualified Sound.ALSA.Sequencer as SndSeq @@ -23,6 +23,7 @@ import Text.Printf import Control.Monad (when, forM_, forM) import qualified Data.Set as Set +import qualified Data.Map.Strict as Map import Data.List (group, sort) import Haskore.Basic.Pitch import Foreign.C.Error (Errno(Errno)) @@ -32,6 +33,7 @@ unPitch = Event.unPitch unChannel = Event.unChannel printChordLn set = printWords $ pitchWords set +printChordLn' = printWords . map (showPitch . Event.unPitch . snd) . Map.keys joinWords [] = "" joinWords ls = foldr1 (\a b -> a ++ " " ++ b) ls @@ -41,7 +43,7 @@ printWords ls = putStrLn $ joinWords ls showChord ls = joinWords $ pitchWords ls -showPitch x = +showPitch x = let (octave, pitch) = Haskore.Basic.Pitch.fromInt $ fromIntegral x in Haskore.Basic.Pitch.classFormat pitch (show octave) @@ -145,6 +147,7 @@ inputPendingLoop h b = do (Right result) -> return result type MidiPitchSet = Set.Set (Event.Channel, Event.Pitch) +type MidiPitchMap = Map.Map (Event.Channel, Event.Pitch) Event.Velocity parseAlsaEvents :: SndSeq.AllowInput mode => SndSeq.T mode -> Set.Set (Event.Channel, Event.Pitch) -> (Event.T -> IO a) -> IO MidiPitchSet parseAlsaEvents h keysDown immediate = loop keysDown @@ -185,6 +188,25 @@ parseAlsaEvents' h keysDown immediate = loop [] keysDown loop (ev:events) (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown) _ -> loop (ev:events) keysDown +parseAlsaEvents'' h keysDown immediate = loop [] keysDown + where + loop events keysDown = do + pending <- inputPendingLoop h True + if (pending == 0) then + return (events, keysDown) + else do + ev <- Event.input h + immediate ev + case Event.body ev of + Event.NoteEv Event.NoteOn n -> + if (Event.unVelocity (Event.noteVelocity n) == 0) then + loop (ev:events) (Map.delete (Event.noteChannel n, Event.noteNote n) keysDown) + else + loop (ev:events) (Map.insert (Event.noteChannel n, Event.noteNote n) (Event.noteVelocity n) keysDown) + Event.NoteEv Event.NoteOff n -> + loop (ev:events) (Map.delete (Event.noteChannel n, Event.noteNote n) keysDown) + _ -> loop (ev:events) keysDown + type MidiHook = Event.T -> IO () forwardNoteEvent :: SndSeq.AllowOutput mode => SndSeq.T mode -> Queue.T -> Addr.T -> MidiHook diff --git a/midi-dump.hs b/midi-dump.hs index 52fe6b2..6c2c8b8 100644 --- a/midi-dump.hs +++ b/midi-dump.hs @@ -8,7 +8,7 @@ import AlsaSeq import Control.Monad.RWS.Strict import Data.List import Data.Maybe -import qualified Data.Set as Set +import qualified Data.Map.Strict as Map import qualified Sound.ALSA.Exception as AlsaExc import qualified Sound.ALSA.Sequencer.Event as Event import System.Clock @@ -43,7 +43,7 @@ data Triad = Major Event.Pitch | Minor Event.Pitch deriving (Show, Eq) data LoopState = LoopState { _wantExit :: Bool, - _keysDown :: MidiPitchSet, + _keysDown :: MidiPitchMap, _triad :: Maybe Triad, _scheduled :: Q.Queue Event.Data, _recording :: Recording, @@ -52,7 +52,7 @@ data LoopState = LoopState { } initializeState :: TimeSpec -> LoopState -initializeState now = LoopState False Set.empty Nothing createQueue (StartRecording now) (StartRecording now) now +initializeState now = LoopState False Map.empty Nothing createQueue (StartRecording now) (StartRecording now) now data LoopEnv = LoopEnv { _saver :: Chan CompleteRecording, @@ -233,7 +233,7 @@ processMidi = do h <- asks _h oldKeys <- gets _keysDown forwardNOW <- getMidiSender - (events, newKeys) <- liftIO $ parseAlsaEvents' h oldKeys forwardNOW + (events, newKeys) <- liftIO $ parseAlsaEvents'' h oldKeys forwardNOW if oldKeys == newKeys @@ -249,18 +249,18 @@ processMidi = do , _lastTick = now } - whenFlag _printChordKeys $ liftIO $ printChordLn newKeys + whenFlag _printChordKeys $ liftIO $ printChordLn' newKeys filterTriads newKeys -- Whenever no keys are pressed, flush any buffered events to the database - when (Set.null newKeys) $ do + when (Map.null newKeys) $ do doSave <- asks _doSave when doSave $ gets _recording >>= saveMidi >> return () modify $ \s -> s { _recording = StartRecording now } -- When a key is pressed after 3+ seconds of silence, overwrite the replay buffer with the new keys - when (Set.null oldKeys) $ do + when (Map.null oldKeys) $ do replay <- gets _replay when (latestEvent replay < (now - TimeSpec 3 0)) $ do modify $ \s -> s { _replay = StartRecording now } @@ -268,13 +268,14 @@ processMidi = do modify $ \s -> s { _replay = recordEvents (_replay s) newEvents } -filterTriads :: MidiPitchSet -> MidiController () +filterTriads :: MidiPitchMap -> MidiController () filterTriads newKeys = do let newTriad = detectTriad newKeys + vel = Event.Velocity 128 oldTriad <- gets _triad when (newTriad /= oldTriad) $ do - forM_ oldTriad (sendTriadEvents False) - forM_ newTriad (sendTriadEvents True) + forM_ oldTriad (sendTriadEvents Nothing) + forM_ newTriad (sendTriadEvents $ Just vel) modify $ \s -> s { _triad = newTriad } triadBase :: Triad -> Event.Pitch @@ -282,26 +283,27 @@ triadBase (Major n) = n triadBase (Minor n) = n -- TODO: set velocity based on average from triad (this requires storing that --- information, changing the MidiPitchSet type for one more complex than a mere +-- information, changing the MidiPitchMap type for one more complex than a mere -- Set) -sendTriadEvents :: Bool -> Triad -> MidiController () -sendTriadEvents sendOn triad = do +sendTriadEvents :: Maybe Event.Velocity -> Triad -> MidiController () +sendTriadEvents vel triad = do forM_ notes (delayNoteEv (TimeSpec 0 0)) return () where - onoff = bool Event.NoteOff Event.NoteOn sendOn base = Event.unPitch $ triadBase triad - notes = (Event.NoteEv onoff . mkNote) <$> fill base + notes = fromVel vel <$> fill base fill n = [ x + y | x <- [n, n + 7], y <- [12, -12]] + fromVel (Just v) pitch = Event.NoteEv Event.NoteOn $ Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) v + fromVel Nothing pitch = Event.NoteEv Event.NoteOff $ Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 0) -detectTriad :: MidiPitchSet -> Maybe Triad -detectTriad pitches = listToMaybe $ concatMap f pitches +detectTriad :: MidiPitchMap -> Maybe Triad +detectTriad pitches = listToMaybe $ concatMap f (Map.keys pitches) where f pitch - | not $ Set.member (addPitch 7 pitch) pitches = [] - | Set.member (addPitch 4 pitch) pitches = [Major $ snd pitch] -- TODO: do not just drop the channel!! - | Set.member (addPitch 3 pitch) pitches = [Minor $ snd pitch] + | not $ Map.member (addPitch 7 pitch) pitches = [] + | Map.member (addPitch 4 pitch) pitches = [Major $ snd pitch] -- TODO: do not just drop the channel!! + | Map.member (addPitch 3 pitch) pitches = [Minor $ snd pitch] | otherwise = [] addPitch n (c, Event.Pitch p) = (c, Event.Pitch $ p+n) -- cgit v1.2.3