From cd9e7854db78041b7453a3d1bcfa45a95fe53604 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Thu, 10 Dec 2015 13:39:25 -0500 Subject: Clean up triad detection somewhat The triad detection now returns the correct type (detecting all triads on all channels, and saving the channel). This information is still not used; the future is to call filters for each channel separately, so there is no point making an individual filter operate on multiple channels simultaneously. --- midi-dump.hs | 76 +++++++++++++++++++++++++----------------------------------- 1 file changed, 31 insertions(+), 45 deletions(-) diff --git a/midi-dump.hs b/midi-dump.hs index 9407fae..d2b6c15 100644 --- a/midi-dump.hs +++ b/midi-dump.hs @@ -30,6 +30,7 @@ import qualified Sound.ALSA.Sequencer.RealTime as RealTime import Midi import RealTimeQueue as Q hiding (null) +import qualified Codec.Midi verbose :: Bool verbose = False @@ -39,7 +40,8 @@ main = main' `AlsaExc.catch` handler where handler e = when verbose $ putStrLn $ "alsa_exception: " ++ AlsaExc.show e -data Triad = Major Event.Pitch | Minor Event.Pitch deriving (Show, Eq) +data TriadType = Major | Minor deriving (Show, Eq) +data Triad = Triad TriadType Event.Pitch Event.Velocity deriving (Show, Eq) data LoopState = LoopState { _wantExit :: Bool, @@ -216,10 +218,10 @@ type MidiController = MidiControllerT IO playRecording :: Playable p => p -> MidiController () playRecording = playEvents . playableEvents --- fixedOutputChannel :: Maybe _ +fixedOutputChannel :: Maybe Codec.Midi.Channel fixedOutputChannel = Just 0 --- setOutputChannel :: Codec.Midi.Message -> Codec.Midi.Message +setOutputChannel :: Codec.Midi.Message -> Codec.Midi.Message setOutputChannel = case fixedOutputChannel of Just n -> setChannel n Nothing -> id @@ -278,62 +280,46 @@ processMidi = do filterTriads :: MidiPitchMap -> MidiController () filterTriads newKeys = do - let newTriad = detectTriad newKeys - (Just (vel, _)) = detectTriad' newKeys - -- vel = Event.Velocity 127 + let newTriad = fmap snd $ listToMaybe $ detectTriads newKeys -- TODO: handle each channel oldTriad <- gets _triad when (newTriad /= oldTriad) $ do - forM_ oldTriad (sendTriadEvents Nothing) - forM_ newTriad (sendTriadEvents $ Just vel) + forM_ oldTriad $ triadOff >>> sendTriadEvents + forM_ newTriad sendTriadEvents modify $ \s -> s { _triad = newTriad } -triadBase :: Triad -> Event.Pitch -triadBase (Major n) = n -triadBase (Minor n) = n +triadOff :: Triad -> Triad +triadOff (Triad t p _) = Triad t p (Event.Velocity 0) --- TODO: set velocity based on average from triad (this requires storing that --- information, changing the MidiPitchMap type for one more complex than a mere --- Set) -sendTriadEvents :: Maybe Event.Velocity -> Triad -> MidiController () -sendTriadEvents vel triad = do - liftIO $ print vel +sendTriadEvents :: Triad -> MidiController () +sendTriadEvents (Triad _ (Event.Pitch base) vel) = do forM_ notes (delayNoteEv (TimeSpec 0 0)) return () where - base = Event.unPitch $ triadBase triad 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) + fromVel (Event.Velocity 0) pitch = Event.NoteEv Event.NoteOff $ Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 0) + fromVel v pitch = Event.NoteEv Event.NoteOn $ Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) v -detectTriad' :: MidiPitchMap -> Maybe (Event.Velocity, Triad) -detectTriad' pitches = listToMaybe $ concatMap f (Map.keys pitches) +detectTriads :: MidiPitchMap -> [(Event.Channel, Triad)] +detectTriads pitches = concatMap f (Map.keys pitches) where f pitch = do - let first_ = Map.lookup pitch pitches - major3 = Map.lookup (addPitch 4 pitch) pitches - minor3 = Map.lookup (addPitch 3 pitch) pitches - fifth_ = Map.lookup (addPitch 7 pitch) pitches - let major = foldM (fmap . (+)) (0::Int) $ (fmap . fmap) (fromIntegral . Event.unVelocity) [first_, major3, fifth_] - let minor = foldM (fmap . (+)) (0::Int) $ (fmap . fmap) (fromIntegral . Event.unVelocity) [first_, minor3, fifth_] - case major of - Just n -> [(Event.Velocity $ fromIntegral $ n `div` 3, Major $ snd pitch)] - Nothing -> - case minor of - Just n -> [(Event.Velocity $ fromIntegral $ n `div` 3, Minor $ snd pitch)] - Nothing -> [] - addPitch n (c, Event.Pitch p) = (c, Event.Pitch $ p + n) - -detectTriad :: MidiPitchMap -> Maybe Triad -detectTriad pitches = listToMaybe $ concatMap f (Map.keys pitches) - where - f 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) + let [first_, minor3, major3, fifth_] = map (getVelocity . getNote) [0, 3, 4, 7] + major = sumM [first_, major3, fifth_] + minor = sumM [first_, minor3, fifth_] + getNote n = Map.lookup (addPitch n pitch) pitches + case (major, minor) of + (Just n, _) -> [(fst pitch, Triad Major (snd pitch) (Event.Velocity $ fromIntegral $ n `div` 3))] + (_, Just n) -> [(fst pitch, Triad Minor (snd pitch) (Event.Velocity $ fromIntegral $ n `div` 3))] + _ -> [] + addPitch :: Word8 -> (t, Event.Pitch) -> (t, Event.Pitch) + addPitch n = fmap (Event.Pitch . (+ n) . Event.unPitch) + getVelocity :: Maybe Event.Velocity -> Maybe Int + getVelocity = fmap (fromIntegral . Event.unVelocity) + +sumM :: (Monad m, Num a, Foldable t) => t (m a) -> m a +sumM = foldM (fmap . (+)) 0 latestEvent :: Recording -> TimeSpec latestEvent (StartRecording x) = x -- cgit v1.2.3