Store note velocities in pitch sets

(actually pitch maps, now)

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)