diff options
author | Andrew Cady <d@jerkface.net> | 2015-12-07 00:15:02 -0500 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2015-12-07 00:15:02 -0500 |
commit | 9adf1aff92e1921203feeedf361deee1984fe2c6 (patch) | |
tree | 40aa916782ef7f46b77f6856af6e77cc6f28cc51 | |
parent | c1a28c4f18dbcf7dda4251a1f0dd98d7d7377d2b (diff) |
Disable printing the names of keys.
Also whitespace, comments, & other non-functional changes.
-rw-r--r-- | Midi.hs | 8 | ||||
-rw-r--r-- | midi-dump.hs | 71 |
2 files changed, 42 insertions, 37 deletions
@@ -41,6 +41,14 @@ data CompleteRecording = CompleteRecording { | |||
41 | _recEvents :: [RecordedEvent] | 41 | _recEvents :: [RecordedEvent] |
42 | } | 42 | } |
43 | 43 | ||
44 | class Playable p where | ||
45 | playableEvents :: p -> [RecordedEvent] | ||
46 | instance Playable Recording where | ||
47 | playableEvents (StartRecording _) = [] | ||
48 | playableEvents (RecordingInProgress _ _ ls) = ls | ||
49 | instance Playable CompleteRecording where | ||
50 | playableEvents = _recEvents | ||
51 | |||
44 | instance FromRow CompleteRecording where | 52 | instance FromRow CompleteRecording where |
45 | fromRow = cons <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field | 53 | fromRow = cons <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field |
46 | where | 54 | where |
diff --git a/midi-dump.hs b/midi-dump.hs index b531b97..064ce88 100644 --- a/midi-dump.hs +++ b/midi-dump.hs | |||
@@ -63,6 +63,7 @@ data LoopEnv = LoopEnv { | |||
63 | _publicAddr :: Sound.ALSA.Sequencer.Address.T, | 63 | _publicAddr :: Sound.ALSA.Sequencer.Address.T, |
64 | _privateAddr :: Sound.ALSA.Sequencer.Address.T, | 64 | _privateAddr :: Sound.ALSA.Sequencer.Address.T, |
65 | _doSave :: Bool, | 65 | _doSave :: Bool, |
66 | _printChordKeys :: Bool, | ||
66 | _lineReader :: MVar String | 67 | _lineReader :: MVar String |
67 | } | 68 | } |
68 | 69 | ||
@@ -122,7 +123,7 @@ main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do | |||
122 | 123 | ||
123 | doSave <- isNothing <$> lookupEnv "NO_SAVE_MIDI" | 124 | doSave <- isNothing <$> lookupEnv "NO_SAVE_MIDI" |
124 | 125 | ||
125 | let env = LoopEnv saver sqlite startTime startTimeReal h public private q publicAddr privateAddr doSave lineReader | 126 | let env = LoopEnv saver sqlite startTime startTimeReal h public private q publicAddr privateAddr doSave False lineReader |
126 | 127 | ||
127 | (_, ()) <- execRWST mainLoop env $ initializeState startTimeReal | 128 | (_, ()) <- execRWST mainLoop env $ initializeState startTimeReal |
128 | return () | 129 | return () |
@@ -165,8 +166,8 @@ queueAction act = do | |||
165 | delayNoteEv :: TimeSpec -> Event.Data -> MidiController () | 166 | delayNoteEv :: TimeSpec -> Event.Data -> MidiController () |
166 | delayNoteEv delay nevdata = queueAction $ scheduleEventIO (delay, nevdata) | 167 | delayNoteEv delay nevdata = queueAction $ scheduleEventIO (delay, nevdata) |
167 | 168 | ||
168 | _whenFlag :: forall (m :: * -> *) s. MonadState s m => (s -> Bool) -> m () -> m () | 169 | whenFlag :: MonadReader r m => (r -> Bool) -> m () -> m () |
169 | _whenFlag flag f = gets flag >>= flip when f | 170 | whenFlag flag f = asks flag >>= flip when f |
170 | 171 | ||
171 | mkNote :: Word8 -> Event.Note | 172 | mkNote :: Word8 -> Event.Note |
172 | mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128) | 173 | mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128) |
@@ -194,11 +195,14 @@ processCommand str = liftIO $ putStrLn $ "Unknown command: " ++ str | |||
194 | type MidiControllerT m = RWST LoopEnv () LoopState m | 195 | type MidiControllerT m = RWST LoopEnv () LoopState m |
195 | type MidiController = MidiControllerT IO | 196 | type MidiController = MidiControllerT IO |
196 | 197 | ||
197 | playRecording :: Recording -> MidiController () | 198 | playRecording :: Playable p => p -> MidiController () |
198 | playRecording (RecordingInProgress _ _ evts@(_:_)) = | 199 | playRecording = playEvents . playableEvents |
200 | |||
201 | playEvents :: [RecordedEvent] -> RWST LoopEnv () LoopState IO () | ||
202 | playEvents evts@(_:_) = | ||
199 | mapM_ (uncurry delayNoteEv) (zip (subtract (head delays) <$> delays) events) | 203 | mapM_ (uncurry delayNoteEv) (zip (subtract (head delays) <$> delays) events) |
200 | where (delays, events) = unzip $ reverse $ unConvertEvents evts | 204 | where (delays, events) = unzip $ reverse $ unConvertEvents evts |
201 | playRecording _ = return () | 205 | playEvents _ = return () |
202 | 206 | ||
203 | getMidiSender :: MidiController MidiHook | 207 | getMidiSender :: MidiController MidiHook |
204 | getMidiSender = do | 208 | getMidiSender = do |
@@ -215,29 +219,35 @@ processMidi = do | |||
215 | (events, newKeys) <- liftIO $ parseAlsaEvents' h oldKeys forwardNOW | 219 | (events, newKeys) <- liftIO $ parseAlsaEvents' h oldKeys forwardNOW |
216 | 220 | ||
217 | 221 | ||
218 | if oldKeys == newKeys then | 222 | if oldKeys == newKeys |
219 | liftIO $ threadDelay 15000 -- 15ms. Seems like a lot, but it sounds OK. Cuts CPU down to 2%. | 223 | then liftIO $ threadDelay 15000 -- 15ms. Seems like a lot, but it sounds OK. Cuts CPU down to 2%. |
220 | else do | 224 | else do |
221 | now <- getAbsTime | 225 | now <- getAbsTime |
222 | let newEvents = map ((,) now . Event.body) events | 226 | let newEvents = map ((,) now . Event.body) events |
223 | |||
224 | liftIO $ printChordLn newKeys | ||
225 | modify $ \s -> s { keysDown = newKeys, _recording = recordEvents (_recording s) newEvents, _lastTick = now } | ||
226 | 227 | ||
227 | when (Set.null newKeys) $ do | 228 | modify $ \s -> |
229 | s | ||
230 | { keysDown = newKeys | ||
231 | , _recording = recordEvents (_recording s) newEvents | ||
232 | , _lastTick = now | ||
233 | } | ||
228 | 234 | ||
229 | doSave <- asks _doSave | 235 | whenFlag _printChordKeys $ liftIO $ printChordLn newKeys |
230 | when doSave $ gets _recording >>= saveMidi >> return () | ||
231 | modify $ \s -> s { _recording = StartRecording now } | ||
232 | 236 | ||
233 | when (Set.null oldKeys) $ do | 237 | -- Whenever no keys are pressed, flush any buffered events to the database |
238 | when (Set.null newKeys) $ do | ||
239 | doSave <- asks _doSave | ||
240 | when doSave $ gets _recording >>= saveMidi >> return () | ||
241 | modify $ \s -> s { _recording = StartRecording now } | ||
234 | 242 | ||
235 | replay <- gets _replay | 243 | -- When a key is pressed after 3+ seconds of silence, overwrite the replay buffer with the new keys |
236 | when (latestEvent replay < (now - TimeSpec 3 0)) $ do | 244 | when (Set.null oldKeys) $ do |
237 | modify $ \s -> s { _replay = StartRecording now } | 245 | replay <- gets _replay |
238 | return () | 246 | when (latestEvent replay < (now - TimeSpec 3 0)) $ do |
247 | modify $ \s -> s { _replay = StartRecording now } | ||
248 | return () | ||
239 | 249 | ||
240 | modify $ \s -> s { _replay = recordEvents (_replay s) newEvents } | 250 | modify $ \s -> s { _replay = recordEvents (_replay s) newEvents } |
241 | 251 | ||
242 | latestEvent :: Recording -> TimeSpec | 252 | latestEvent :: Recording -> TimeSpec |
243 | latestEvent (StartRecording x) = x | 253 | latestEvent (StartRecording x) = x |
@@ -269,16 +279,3 @@ startSaver sqlite = do | |||
269 | reco <- readChan chan | 279 | reco <- readChan chan |
270 | liftIO $ execute sqlite sqlInsert reco | 280 | liftIO $ execute sqlite sqlInsert reco |
271 | return () | 281 | return () |
272 | |||
273 | |||
274 | _getMidiDesc :: Event.T -> Maybe String | ||
275 | _getMidiDesc (Event.Cons _ _ _ _ _ _ (Event.NoteEv Event.NoteOn ev)) = return $ ("on:" ++) $ showPitch $ unPitch $ Event.noteNote ev | ||
276 | _getMidiDesc (Event.Cons _ _ _ _ _ _ (Event.NoteEv Event.NoteOff ev)) = return $ ("off:" ++) $ showPitch $ unPitch $ Event.noteNote ev | ||
277 | _getMidiDesc _ = Nothing | ||
278 | |||
279 | _tsDeltas :: [TimeSpec] -> [Integer] | ||
280 | _tsDeltas [] = [] | ||
281 | _tsDeltas ls@(x:_) = zipWith (-) nsecs (0:nsecs) | ||
282 | where | ||
283 | nsecs = map timeSpecAsNanoSecs rel | ||
284 | rel = map (\y -> y - x) ls | ||