diff options
author | Andrew Cady <d@jerkface.net> | 2015-12-05 02:45:26 -0500 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2015-12-05 02:55:46 -0500 |
commit | 4d77cfcfa36a628f5a583c846fe7ee2955afa923 (patch) | |
tree | 4dd73ccb62c1851166dda5eb6442721dbb3c2c29 | |
parent | 8f46e826f188ce7716a87cf98ace41829725f10c (diff) |
change representation of recordings
-rw-r--r-- | midi-dump.hs | 67 |
1 files changed, 42 insertions, 25 deletions
diff --git a/midi-dump.hs b/midi-dump.hs index 90a1bae..8484272 100644 --- a/midi-dump.hs +++ b/midi-dump.hs | |||
@@ -39,31 +39,43 @@ 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 | type RecordedEvents = [(TimeSpec, Event.T)] | 42 | type RecordedEvent = (TimeSpec, Event.T) |
43 | 43 | ||
44 | data Recording = Recording { | 44 | data Recording = StartRecording TimeSpec | |
45 | _recordingStart :: TimeSpec, -- from initial silence | 45 | RecordingInProgress TimeSpec TimeSpec [RecordedEvent] |
46 | _recordingEvents :: RecordedEvents | 46 | |
47 | data CompleteRecording = CompleteRecording { | ||
48 | _recStart :: TimeSpec, | ||
49 | _recFirst :: TimeSpec, | ||
50 | _recLast :: TimeSpec, | ||
51 | _recEvents :: [RecordedEvent] | ||
47 | } | 52 | } |
48 | 53 | ||
49 | data FinishedRecording = FinishedRecording Recording TimeSpec | 54 | recordEvents :: Recording -> [RecordedEvent]-> Recording |
55 | recordEvents (RecordingInProgress x y orig) new = RecordingInProgress x y $ new ++ orig | ||
56 | recordEvents i@(StartRecording _) [] = i | ||
57 | recordEvents (StartRecording x) new@(_:_) = RecordingInProgress x y new | ||
58 | where y = fst $ last new | ||
59 | |||
60 | stopRecording :: Recording -> Maybe CompleteRecording | ||
61 | stopRecording (RecordingInProgress x y ls@((z,_):_)) = Just $ CompleteRecording x y z ls | ||
62 | stopRecording _ = Nothing | ||
50 | 63 | ||
51 | recordEvents :: Recording -> RecordedEvents -> Recording | ||
52 | recordEvents (Recording s orig) new = Recording s (new ++ orig) | ||
53 | 64 | ||
54 | data LoopState = LoopState { | 65 | data LoopState = LoopState { |
55 | _wantExit :: Bool, | 66 | _wantExit :: Bool, |
56 | keysDown :: MidiPitchSet, | 67 | keysDown :: MidiPitchSet, |
57 | _playNOW :: [Event.Data], | 68 | _playNOW :: [Event.Data], |
58 | _recording :: Recording, | 69 | _recording :: Recording, |
70 | _replay :: Recording, | ||
59 | lastTick :: TimeSpec | 71 | lastTick :: TimeSpec |
60 | } | 72 | } |
61 | 73 | ||
62 | initializeState :: TimeSpec -> LoopState | 74 | initializeState :: TimeSpec -> LoopState |
63 | initializeState now = LoopState False Set.empty [] (emptyRecording now) now | 75 | initializeState now = LoopState False Set.empty [] (StartRecording now) (StartRecording now) now |
64 | 76 | ||
65 | data LoopEnv = LoopEnv { | 77 | data LoopEnv = LoopEnv { |
66 | _saver :: Chan FinishedRecording, | 78 | _saver :: Chan CompleteRecording, |
67 | _sqlite :: Connection, | 79 | _sqlite :: Connection, |
68 | _startTime :: TimeSpec, | 80 | _startTime :: TimeSpec, |
69 | _startTimeReal :: TimeSpec, | 81 | _startTimeReal :: TimeSpec, |
@@ -123,7 +135,7 @@ mainLoop = do | |||
123 | scheduled <- gets _playNOW | 135 | scheduled <- gets _playNOW |
124 | unless (null scheduled) $ do | 136 | unless (null scheduled) $ do |
125 | forM_ scheduled playNoteEv | 137 | forM_ scheduled playNoteEv |
126 | -- TODO: flush ALSA output here | 138 | -- TODO: flush ALSA output here (and remove flush from playNoteEv) |
127 | modify $ \s -> s { _playNOW = [] } | 139 | modify $ \s -> s { _playNOW = [] } |
128 | 140 | ||
129 | unless wantExit mainLoop | 141 | unless wantExit mainLoop |
@@ -178,14 +190,21 @@ processMidi = do | |||
178 | liftIO $ printChordLn newKeys | 190 | liftIO $ printChordLn newKeys |
179 | modify $ \s -> s { keysDown = newKeys, _recording = recordEvents (_recording s) newEvents, lastTick = now } | 191 | modify $ \s -> s { keysDown = newKeys, _recording = recordEvents (_recording s) newEvents, lastTick = now } |
180 | 192 | ||
193 | {- | ||
194 | |||
195 | when (Set.null oldKeys) $ do | ||
196 | |||
197 | replay <- gets _replay | ||
198 | |||
199 | when (lastEventTime replay < now - 10*10^9) $ do | ||
200 | modify $ \s -> s { _replay = StartRecording now } | ||
201 | -} | ||
202 | |||
181 | when (Set.null newKeys) $ do | 203 | when (Set.null newKeys) $ do |
182 | 204 | ||
183 | doSave <- asks _doSave | 205 | doSave <- asks _doSave |
184 | when doSave $ gets _recording >>= saveMidi >> return () | 206 | when doSave $ gets _recording >>= saveMidi >> return () |
185 | modify $ \s -> s { _recording = emptyRecording now } | 207 | modify $ \s -> s { _recording = StartRecording now } |
186 | |||
187 | emptyRecording :: TimeSpec -> Recording | ||
188 | emptyRecording now = Recording now [] | ||
189 | 208 | ||
190 | maybeReadLine :: RWST LoopEnv () LoopState IO (Maybe String) | 209 | maybeReadLine :: RWST LoopEnv () LoopState IO (Maybe String) |
191 | maybeReadLine = asks _lineReader >>= liftIO . tryTakeMVar | 210 | maybeReadLine = asks _lineReader >>= liftIO . tryTakeMVar |
@@ -202,30 +221,28 @@ instance FromRow Chunk where | |||
202 | instance ToRow Chunk where | 221 | instance ToRow Chunk where |
203 | toRow (Chunk s ns s' ns' d m) = toRow (s, ns, s', ns', d, m) | 222 | toRow (Chunk s ns s' ns' d m) = toRow (s, ns, s', ns', d, m) |
204 | 223 | ||
205 | data Chunkable = MkChunk FinishedRecording TimeSpec | 224 | instance ToRow CompleteRecording where |
206 | instance ToRow Chunkable where | 225 | toRow reco = toRow (s, ns, s', ns', leadingSilence :: Int64, pack $ show midi) |
207 | toRow (MkChunk reco ts) = toRow (s, ns, s', ns', leadingSilence :: Int64, pack $ show midi) | ||
208 | where | 226 | where |
209 | (FinishedRecording (Recording start@(TimeSpec s ns) midi) (TimeSpec s' ns')) = reco | 227 | (CompleteRecording start ts@(TimeSpec s ns) (TimeSpec s' ns') midi) = reco |
210 | leadingSilence = fromIntegral $ timeSpecAsNanoSecs $ ts - start | 228 | leadingSilence = fromIntegral $ timeSpecAsNanoSecs $ ts - start |
211 | 229 | ||
212 | saveMidi :: forall (m :: * -> *). (MonadIO m, MonadState LoopState m, MonadReader LoopEnv m) => Recording -> m () | 230 | saveMidi :: forall (m :: * -> *). (MonadIO m, MonadState LoopState m, MonadReader LoopEnv m) => Recording -> m () |
213 | saveMidi recording = do | 231 | saveMidi recording = do |
214 | saver <- asks _saver | 232 | saver <- asks _saver |
215 | end <- gets lastTick | 233 | end <- gets lastTick -- TODO: record last tick (?) |
216 | liftIO $ writeChan saver $ FinishedRecording recording end | 234 | mapM_ (liftIO . writeChan saver) $ stopRecording recording |
217 | 235 | ||
218 | startSaver :: forall (m :: * -> *). MonadIO m => Connection -> m (Chan FinishedRecording) | 236 | startSaver :: forall (m :: * -> *). MonadIO m => Connection -> m (Chan CompleteRecording) |
219 | startSaver sqlite = do | 237 | startSaver sqlite = do |
220 | chan <- liftIO newChan | 238 | chan <- liftIO newChan |
221 | _thread <- liftIO $ forkIO (saver chan) | 239 | _thread <- liftIO $ forkIO (saver chan) |
222 | return chan | 240 | return chan |
223 | where | 241 | where |
224 | saver chan = forever $ do | 242 | saver chan = forever $ do |
225 | reco@(FinishedRecording (Recording _ events) _) <- readChan chan | 243 | reco <- readChan chan |
226 | let start = fst $ head events | 244 | let sqlInsert = "INSERT INTO axis_input (start_sec, start_nsec, end_sec, end_nsec, leading_silence, midi) VALUES (?,?,?,?,?,?)" |
227 | sqlInsert = "INSERT INTO axis_input (start_sec, start_nsec, end_sec, end_nsec, leading_silence, midi) VALUES (?,?,?,?,?,?)" | 245 | liftIO $ execute sqlite sqlInsert reco |
228 | liftIO $ execute sqlite sqlInsert (MkChunk reco start) | ||
229 | return () | 246 | return () |
230 | 247 | ||
231 | 248 | ||