initial support for reprogammable triads

1 files changed, 55 insertions, 8 deletions

diff --git a/midi-dump.hs b/midi-dump.hs
index 369ee9c..7b7bf8b 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -3,12 +3,14 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
 
 import           AlsaSeq
 import           Control.Monad.RWS.Strict
 import           Data.List
 import           Data.Maybe
 import qualified Data.Map.Strict                as Map
+import           Data.Map.Strict                (Map)
 import qualified Sound.ALSA.Exception           as AlsaExc
 import qualified Sound.ALSA.Sequencer.Event     as Event
 import           System.Clock
@@ -53,13 +55,30 @@ main = main' `AlsaExc.catch` handler
   handler e = when verbose $ putStrLn $ "alsa_exception: " ++ AlsaExc.show e
 
 data TriadType = Major | Minor deriving (Show, Eq, Ord)
-data Triad = Triad TriadType Event.Pitch Event.Velocity deriving (Show, Eq, Ord)
+data Triad =
+       Triad
+         { _triadType :: TriadType
+         , triadPitch :: Event.Pitch
+         , _triadVelocity :: Event.Velocity
+         }
+  deriving (Show, Eq, Ord)
+toPitchClass :: Event.Pitch -> PitchClass
+toPitchClass = Event.unPitch >>> (`mod` 12) >>> fromIntegral
+tonic :: Triad -> PitchClass
+tonic (Triad _ p _) = toPitchClass p
+
+data TriadRecorder = TriadNotRecording | AwaitingTriad | AwaitingRelease Event.Pitch TriadType | Recording Event.Pitch TriadType
+
+type PitchClass = Int
+type ScaleDegree = Int
 
 data LoopState = LoopState {
   _wantExit    :: Bool,
   _waitThreads :: [IO (Thread.Result ())],
   _keysDown    :: MidiPitchMap,
   _triad       :: Set Triad,
+  _triadMap    :: Map (PitchClass, TriadType) (Set ScaleDegree),
+  _triadRecording :: TriadRecorder,
   _scheduled   :: Q.Queue Event.Data,
   _metronome   :: Maybe Metronome,
   _recording   :: Recording,
@@ -74,7 +93,7 @@ data Metronome = Metronome {
 }
 
 initializeState :: TimeSpec -> LoopState
-initializeState now = LoopState False [] Map.empty Set.empty createQueue Nothing (StartRecording now) (StartRecording now) now
+initializeState now = LoopState False [] Map.empty Set.empty Map.empty TriadNotRecording createQueue Nothing (StartRecording now) (StartRecording now) now
 
 data LoopEnv = LoopEnv {
   _saver         :: Chan CompleteRecording,
@@ -292,6 +311,13 @@ processCommand "dump" = sqlSelectEVERYTHING >>= saveRecording "dumped.mid" . mco
 processCommand "C" = do
   let notes = (Event.NoteEv Event.NoteOn . mkNote) <$> [60, 64, 67]
   forM_ notes (delayNoteEv (TimeSpec 0 0))
+processCommand "M-t" = gets _triadRecording >>= \case
+  TriadNotRecording -> do
+    liftIO $ putStrLn "Recording triad"
+    modify $ \s -> s { _triadRecording = AwaitingTriad }
+  _ -> do
+    liftIO $ putStrLn "Cancelled ecording triad"
+    modify $ \s -> s { _triadRecording = TriadNotRecording }
 processCommand "M-m" = do
   now <- getAbsTime
   m <- gets _metronome
@@ -402,7 +428,27 @@ processMidi = do
 
     whenFlag _printChordKeys $ liftIO $ printChordLn' newKeys
 
-    filterTriads newKeys
+    triadRecording <- gets _triadRecording
+    case triadRecording of
+      TriadNotRecording -> filterTriads newKeys
+      AwaitingTriad -> do
+        let detected = snd <$> listToMaybe (detectTriads newKeys)
+        forM_ detected $ \t@(Triad _ p _) ->
+              (modify $ \s -> s { _triadRecording = AwaitingRelease p (_triadType t) })
+      AwaitingRelease pitch ttype -> do
+        let pc = toPitchClass pitch
+        when (Map.null newKeys) $
+             modify $ \s -> s { _triadRecording = Recording pitch ttype, _triadMap = Map.delete (pc, ttype) (_triadMap s) }
+      Recording pitch ttype -> do
+        let f :: Map (Event.Channel, Event.Pitch) Event.Velocity -> Set ScaleDegree
+            f = Set.fromList . map (subtract (fromIntegral $ Event.unPitch pitch) . fromIntegral . Event.unPitch . snd) . Map.keys
+            pc = toPitchClass pitch
+        let detected = triadPitch . snd <$> detectTriads newKeys
+            detected :: [Event.Pitch]
+        if pitch `elem` detected then
+          modify $ \s -> s { _triadRecording = TriadNotRecording }
+        else
+          modify $ \s -> s { _triadMap = Map.insertWith Set.union (pc, ttype) (f newKeys) (_triadMap s) }
 
     -- Whenever no keys are pressed, flush any buffered events to the database
     when (Map.null newKeys) $ do
@@ -432,13 +478,14 @@ triadOff :: Triad -> Triad
 triadOff (Triad t p _) = Triad t p (Event.Velocity 0)
 
 sendTriadEvents :: Triad -> MidiController ()
-sendTriadEvents (Triad _ (Event.Pitch base) vel) = do
-  forM_ notes (delayNoteEv (TimeSpec 0 0))
-  return ()
+sendTriadEvents t@(Triad ttype (Event.Pitch base) vel) = do
+  mappedNotes <- Map.lookup (tonic t, ttype) <$> gets _triadMap
+  when (isJust mappedNotes) $ notesOn $ notes (map fromIntegral . Set.toList <$> mappedNotes)
 
   where
-    notes = fromVel vel <$> fill base
-    fill n = [ x + y | x <- [n, n + 7], y <- [12, -12]]
+    notesOn n = forM_ n (delayNoteEv (TimeSpec 0 0))
+    notes :: Maybe [Word8] -> [Event.Data]
+    notes mappedNotes = fromVel vel <$> map (base +) (fromMaybe [12, -12, 7+12, 7-12] mappedNotes)
     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