1 files changed, 48 insertions, 6 deletions

diff --git a/midi-dump.hs b/midi-dump.hs
index 534671f..52fe6b2 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -39,17 +39,20 @@ 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 LoopState = LoopState {
   _wantExit  :: Bool,
-  keysDown   :: MidiPitchSet,
+  _keysDown  :: MidiPitchSet,
+  _triad     :: Maybe Triad,
   _scheduled :: Q.Queue Event.Data,
   _recording :: Recording,
   _replay    :: Recording,
-  _lastTick   :: TimeSpec
+  _lastTick  :: TimeSpec
 }
 
 initializeState :: TimeSpec -> LoopState
-initializeState now = LoopState False Set.empty createQueue (StartRecording now) (StartRecording now) now
+initializeState now = LoopState False Set.empty Nothing createQueue (StartRecording now) (StartRecording now) now
 
 data LoopEnv = LoopEnv {
   _saver         :: Chan CompleteRecording,
@@ -125,7 +128,6 @@ main' :: IO ()
 main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do
   cmdlineAlsaConnect h public
 
-  putStrLn "Rock on!"
   startTime <- getTime Monotonic
   startTimeReal <- getTime Realtime
 
@@ -138,6 +140,7 @@ main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do
 
   let env = LoopEnv saver sqlite startTime startTimeReal h public private q publicAddr privateAddr doSave False lineReader
 
+  putStrLn "Rock on!"
   (_, ()) <- execRWST mainLoop env $ initializeState startTimeReal
   return ()
 
@@ -228,7 +231,7 @@ getMidiSender = do
 processMidi :: MidiController ()
 processMidi = do
   h <- asks _h
-  oldKeys <- gets keysDown
+  oldKeys <- gets _keysDown
   forwardNOW <- getMidiSender
   (events, newKeys) <- liftIO $ parseAlsaEvents' h oldKeys forwardNOW
 
@@ -241,13 +244,15 @@ processMidi = do
 
       modify $ \s ->
         s
-          { keysDown = newKeys
+          { _keysDown = newKeys
           , _recording = recordEvents (_recording s) newEvents
           , _lastTick = now
           }
 
       whenFlag _printChordKeys $ liftIO $ printChordLn newKeys
 
+      filterTriads newKeys
+
       -- Whenever no keys are pressed, flush any buffered events to the database
       when (Set.null newKeys) $ do
         doSave <- asks _doSave
@@ -263,6 +268,43 @@ processMidi = do
 
       modify $ \s -> s { _replay = recordEvents (_replay s) newEvents }
 
+filterTriads :: MidiPitchSet -> MidiController ()
+filterTriads newKeys = do
+  let newTriad = detectTriad newKeys
+  oldTriad <- gets _triad
+  when (newTriad /= oldTriad) $ do
+    forM_ oldTriad (sendTriadEvents False)
+    forM_ newTriad (sendTriadEvents True)
+    modify $ \s -> s { _triad = newTriad }
+
+triadBase :: Triad -> Event.Pitch
+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
+-- Set)
+sendTriadEvents :: Bool -> Triad -> MidiController ()
+sendTriadEvents sendOn 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
+    fill n = [ x + y | x <- [n, n + 7], y <- [12, -12]]
+
+detectTriad :: MidiPitchSet -> Maybe Triad
+detectTriad pitches = listToMaybe $ concatMap f 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]
+      | otherwise = []
+    addPitch n (c, Event.Pitch p) = (c, Event.Pitch $ p+n)
+
 latestEvent :: Recording -> TimeSpec
 latestEvent (StartRecording x) = x
 latestEvent (RecordingInProgress _ x []) = x