Add basic support for "filling" triads.

I.e., any triads played will have additional notes played at the root &
fifth of the octave above and below the triad.

Eventually I want to program the triads using the keyboard itself, so
that the chords can be "filled" arbitrarily.

This also shows the need to represent the pressed key set differently
than as a Set of (channel, pitch) pairs: the velocity needs to be saved,
so that the "fill" notes can use it (probably use the average of the
triad).

Furthermore the whole infrastructure needs to be designed around the
concept of input channels mapping to output channels.  Filters (such as
the triad filter) should be applied to channels -- right now, the
assumption of a single channel has been baked in in several places, but
this will eventually interfere with things like looping.

(Playing back the input needs to be able to play back the filters that
were in place on the input. Although, note: we also want to record
output and primarily play that back.)

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