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.

1 files 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