diff options
-rw-r--r-- | midi-dump.hs | 54 |
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 | |||
39 | where | 39 | where |
40 | handler e = when verbose $ putStrLn $ "alsa_exception: " ++ AlsaExc.show e | 40 | handler e = when verbose $ putStrLn $ "alsa_exception: " ++ AlsaExc.show e |
41 | 41 | ||
42 | data Triad = Major Event.Pitch | Minor Event.Pitch deriving (Show, Eq) | ||
43 | |||
42 | data LoopState = LoopState { | 44 | data LoopState = LoopState { |
43 | _wantExit :: Bool, | 45 | _wantExit :: Bool, |
44 | keysDown :: MidiPitchSet, | 46 | _keysDown :: MidiPitchSet, |
47 | _triad :: Maybe Triad, | ||
45 | _scheduled :: Q.Queue Event.Data, | 48 | _scheduled :: Q.Queue Event.Data, |
46 | _recording :: Recording, | 49 | _recording :: Recording, |
47 | _replay :: Recording, | 50 | _replay :: Recording, |
48 | _lastTick :: TimeSpec | 51 | _lastTick :: TimeSpec |
49 | } | 52 | } |
50 | 53 | ||
51 | initializeState :: TimeSpec -> LoopState | 54 | initializeState :: TimeSpec -> LoopState |
52 | initializeState now = LoopState False Set.empty createQueue (StartRecording now) (StartRecording now) now | 55 | initializeState now = LoopState False Set.empty Nothing createQueue (StartRecording now) (StartRecording now) now |
53 | 56 | ||
54 | data LoopEnv = LoopEnv { | 57 | data LoopEnv = LoopEnv { |
55 | _saver :: Chan CompleteRecording, | 58 | _saver :: Chan CompleteRecording, |
@@ -125,7 +128,6 @@ main' :: IO () | |||
125 | main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do | 128 | main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do |
126 | cmdlineAlsaConnect h public | 129 | cmdlineAlsaConnect h public |
127 | 130 | ||
128 | putStrLn "Rock on!" | ||
129 | startTime <- getTime Monotonic | 131 | startTime <- getTime Monotonic |
130 | startTimeReal <- getTime Realtime | 132 | startTimeReal <- getTime Realtime |
131 | 133 | ||
@@ -138,6 +140,7 @@ main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do | |||
138 | 140 | ||
139 | let env = LoopEnv saver sqlite startTime startTimeReal h public private q publicAddr privateAddr doSave False lineReader | 141 | let env = LoopEnv saver sqlite startTime startTimeReal h public private q publicAddr privateAddr doSave False lineReader |
140 | 142 | ||
143 | putStrLn "Rock on!" | ||
141 | (_, ()) <- execRWST mainLoop env $ initializeState startTimeReal | 144 | (_, ()) <- execRWST mainLoop env $ initializeState startTimeReal |
142 | return () | 145 | return () |
143 | 146 | ||
@@ -228,7 +231,7 @@ getMidiSender = do | |||
228 | processMidi :: MidiController () | 231 | processMidi :: MidiController () |
229 | processMidi = do | 232 | processMidi = do |
230 | h <- asks _h | 233 | h <- asks _h |
231 | oldKeys <- gets keysDown | 234 | oldKeys <- gets _keysDown |
232 | forwardNOW <- getMidiSender | 235 | forwardNOW <- getMidiSender |
233 | (events, newKeys) <- liftIO $ parseAlsaEvents' h oldKeys forwardNOW | 236 | (events, newKeys) <- liftIO $ parseAlsaEvents' h oldKeys forwardNOW |
234 | 237 | ||
@@ -241,13 +244,15 @@ processMidi = do | |||
241 | 244 | ||
242 | modify $ \s -> | 245 | modify $ \s -> |
243 | s | 246 | s |
244 | { keysDown = newKeys | 247 | { _keysDown = newKeys |
245 | , _recording = recordEvents (_recording s) newEvents | 248 | , _recording = recordEvents (_recording s) newEvents |
246 | , _lastTick = now | 249 | , _lastTick = now |
247 | } | 250 | } |
248 | 251 | ||
249 | whenFlag _printChordKeys $ liftIO $ printChordLn newKeys | 252 | whenFlag _printChordKeys $ liftIO $ printChordLn newKeys |
250 | 253 | ||
254 | filterTriads newKeys | ||
255 | |||
251 | -- Whenever no keys are pressed, flush any buffered events to the database | 256 | -- Whenever no keys are pressed, flush any buffered events to the database |
252 | when (Set.null newKeys) $ do | 257 | when (Set.null newKeys) $ do |
253 | doSave <- asks _doSave | 258 | doSave <- asks _doSave |
@@ -263,6 +268,43 @@ processMidi = do | |||
263 | 268 | ||
264 | modify $ \s -> s { _replay = recordEvents (_replay s) newEvents } | 269 | modify $ \s -> s { _replay = recordEvents (_replay s) newEvents } |
265 | 270 | ||
271 | filterTriads :: MidiPitchSet -> MidiController () | ||
272 | filterTriads newKeys = do | ||
273 | let newTriad = detectTriad newKeys | ||
274 | oldTriad <- gets _triad | ||
275 | when (newTriad /= oldTriad) $ do | ||
276 | forM_ oldTriad (sendTriadEvents False) | ||
277 | forM_ newTriad (sendTriadEvents True) | ||
278 | modify $ \s -> s { _triad = newTriad } | ||
279 | |||
280 | triadBase :: Triad -> Event.Pitch | ||
281 | triadBase (Major n) = n | ||
282 | triadBase (Minor n) = n | ||
283 | |||
284 | -- TODO: set velocity based on average from triad (this requires storing that | ||
285 | -- information, changing the MidiPitchSet type for one more complex than a mere | ||
286 | -- Set) | ||
287 | sendTriadEvents :: Bool -> Triad -> MidiController () | ||
288 | sendTriadEvents sendOn triad = do | ||
289 | forM_ notes (delayNoteEv (TimeSpec 0 0)) | ||
290 | return () | ||
291 | |||
292 | where | ||
293 | onoff = bool Event.NoteOff Event.NoteOn sendOn | ||
294 | base = Event.unPitch $ triadBase triad | ||
295 | notes = (Event.NoteEv onoff . mkNote) <$> fill base | ||
296 | fill n = [ x + y | x <- [n, n + 7], y <- [12, -12]] | ||
297 | |||
298 | detectTriad :: MidiPitchSet -> Maybe Triad | ||
299 | detectTriad pitches = listToMaybe $ concatMap f pitches | ||
300 | where | ||
301 | f pitch | ||
302 | | not $ Set.member (addPitch 7 pitch) pitches = [] | ||
303 | | Set.member (addPitch 4 pitch) pitches = [Major $ snd pitch] -- TODO: do not just drop the channel!! | ||
304 | | Set.member (addPitch 3 pitch) pitches = [Minor $ snd pitch] | ||
305 | | otherwise = [] | ||
306 | addPitch n (c, Event.Pitch p) = (c, Event.Pitch $ p+n) | ||
307 | |||
266 | latestEvent :: Recording -> TimeSpec | 308 | latestEvent :: Recording -> TimeSpec |
267 | latestEvent (StartRecording x) = x | 309 | latestEvent (StartRecording x) = x |
268 | latestEvent (RecordingInProgress _ x []) = x | 310 | latestEvent (RecordingInProgress _ x []) = x |