Fix triad "fill" note velocity; output to channel 0

That is, set the velocity to the average of the velocity of the
individual triad keys.

Also, output the triads to channel 0 instead of channel 1.  Previously,
all output had been changed to channel 1 to facilitate playing live on
channel 0 on top of playback on channel 1.  However, it was discovered
that the external MIDI synthesizer built into my MIDI keyboard does not
listen on channel 1.

1 files changed, 33 insertions, 5 deletions

diff --git a/midi-dump.hs b/midi-dump.hs
index 6c2c8b8..9407fae 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -171,7 +171,8 @@ alsaDelayNoteEv :: TimeSpec -> Event.Data -> MidiController ()
 alsaDelayNoteEv delay nevdata = do
   ms <- getMidiSender
   publicAddr <- asks _publicAddr
-  liftIO $ ms $ Event.simple publicAddr nevdata `delayEvent` delay
+  liftIO $ ms $ Event.simple publicAddr nevdata `delayEvent` delay'
+  where delay' = max 0 delay
 
 
 queueAction :: (Queue Event.Data -> MidiController (Queue Event.Data)) -> MidiController ()
@@ -186,7 +187,7 @@ whenFlag :: MonadReader r m => (r -> Bool) -> m () -> m ()
 whenFlag flag f = asks flag >>= flip when f
 
 mkNote :: Word8 -> Event.Note
-mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128)
+mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 127)
 
 processCommand :: String -> MidiController ()
 processCommand "exit" = modify $ \s -> s { _wantExit = True }
@@ -202,7 +203,7 @@ processCommand "C'" = do
 {-
 processCommand "C'" = do
   -- changing the duration seems to do nothing
-  let mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128)
+  let mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 127)
       setDuration d note = note { Event.noteDuration = Event.Duration d }
   let notes = (Event.NoteEv Event.NoteOn . setDuration 4290000000 . mkNote) <$> [60, 64, 67]
   forM_ notes (delayNoteEv (TimeSpec 0 0))
@@ -215,10 +216,17 @@ type MidiController = MidiControllerT IO
 playRecording :: Playable p => p -> MidiController ()
 playRecording = playEvents . playableEvents
 
+-- fixedOutputChannel :: Maybe _
+fixedOutputChannel = Just 0
+
+-- setOutputChannel :: Codec.Midi.Message -> Codec.Midi.Message
+setOutputChannel = case fixedOutputChannel of Just n -> setChannel n
+                                              Nothing -> id
+
 playEvents :: [RecordedEvent] -> RWST LoopEnv () LoopState IO ()
 playEvents evts@(_:_) =
   mapM_ (uncurry delayNoteEv) (zip (subtract (head delays) <$> delays) events)
-  where (delays, events) = unzip $ reverse $ unConvertEvents $ (fmap.fmap) (setChannel 1) evts
+  where (delays, events) = unzip $ reverse $ unConvertEvents $ (fmap.fmap) setOutputChannel evts -- TODO: do not use fixed channel
 playEvents  _ = return ()
 
 getMidiSender :: MidiController MidiHook
@@ -271,7 +279,8 @@ processMidi = do
 filterTriads :: MidiPitchMap -> MidiController ()
 filterTriads newKeys = do
   let newTriad = detectTriad newKeys
-      vel = Event.Velocity 128
+      (Just (vel, _)) = detectTriad' newKeys
+      -- vel = Event.Velocity 127
   oldTriad <- gets _triad
   when (newTriad /= oldTriad) $ do
     forM_ oldTriad (sendTriadEvents Nothing)
@@ -287,6 +296,7 @@ triadBase (Minor n) = n
 -- Set)
 sendTriadEvents :: Maybe Event.Velocity -> Triad -> MidiController ()
 sendTriadEvents vel triad = do
+  liftIO $ print vel
   forM_ notes (delayNoteEv (TimeSpec 0 0))
   return ()
 
@@ -297,6 +307,24 @@ sendTriadEvents vel triad = do
     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' :: MidiPitchMap -> Maybe (Event.Velocity, Triad)
+detectTriad' pitches = listToMaybe $ 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