diff options
Diffstat (limited to 'midi-dump.hs')
-rw-r--r-- | midi-dump.hs | 51 |
1 files changed, 9 insertions, 42 deletions
diff --git a/midi-dump.hs b/midi-dump.hs index f053e28..07281f5 100644 --- a/midi-dump.hs +++ b/midi-dump.hs | |||
@@ -14,8 +14,6 @@ import qualified Sound.ALSA.Sequencer.Event as Event | |||
14 | import System.Clock | 14 | import System.Clock |
15 | 15 | ||
16 | import Control.Applicative | 16 | import Control.Applicative |
17 | import qualified Data.ByteString as BS | ||
18 | import Data.ByteString.Char8 (pack) | ||
19 | import Data.Int | 17 | import Data.Int |
20 | import Database.SQLite.Simple | 18 | import Database.SQLite.Simple |
21 | import Database.SQLite.Simple.FromRow () | 19 | import Database.SQLite.Simple.FromRow () |
@@ -31,6 +29,8 @@ import qualified Sound.ALSA.Sequencer.Queue | |||
31 | import qualified Sound.ALSA.Sequencer.Time as Time | 29 | import qualified Sound.ALSA.Sequencer.Time as Time |
32 | import qualified Sound.ALSA.Sequencer.RealTime as RealTime | 30 | import qualified Sound.ALSA.Sequencer.RealTime as RealTime |
33 | 31 | ||
32 | import Midi | ||
33 | |||
34 | verbose :: Bool | 34 | verbose :: Bool |
35 | verbose = False | 35 | verbose = False |
36 | 36 | ||
@@ -39,30 +39,6 @@ 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 RecordedEvent = (TimeSpec, Event.T) | ||
43 | |||
44 | data Recording = StartRecording TimeSpec | | ||
45 | RecordingInProgress TimeSpec TimeSpec [RecordedEvent] | ||
46 | |||
47 | data CompleteRecording = CompleteRecording { | ||
48 | _recStart :: TimeSpec, | ||
49 | _recEnd :: TimeSpec, | ||
50 | _recFirst :: TimeSpec, | ||
51 | _recLast :: TimeSpec, | ||
52 | _recEvents :: [RecordedEvent] | ||
53 | } | ||
54 | |||
55 | recordEvents :: Recording -> [RecordedEvent]-> Recording | ||
56 | recordEvents (RecordingInProgress x y orig) new = RecordingInProgress x y $ new ++ orig | ||
57 | recordEvents i@(StartRecording _) [] = i | ||
58 | recordEvents (StartRecording x) new@(_:_) = RecordingInProgress x y new | ||
59 | where y = fst $ last new | ||
60 | |||
61 | stopRecording :: Recording -> TimeSpec -> Maybe CompleteRecording | ||
62 | stopRecording (RecordingInProgress x y ls@((z,_):_)) end = Just $ CompleteRecording x end y z ls | ||
63 | stopRecording _ _ = Nothing | ||
64 | |||
65 | |||
66 | data LoopState = LoopState { | 42 | data LoopState = LoopState { |
67 | _wantExit :: Bool, | 43 | _wantExit :: Bool, |
68 | keysDown :: MidiPitchSet, | 44 | keysDown :: MidiPitchSet, |
@@ -176,7 +152,7 @@ playNoteEv :: Event.Data -> RWST LoopEnv () LoopState IO () | |||
176 | playNoteEv nevdata = do | 152 | playNoteEv nevdata = do |
177 | ms <- getMidiSender | 153 | ms <- getMidiSender |
178 | publicAddr <- asks _publicAddr | 154 | publicAddr <- asks _publicAddr |
179 | liftIO $ ms $ Event.simple publicAddr nevdata `delayEvent` (10 * 10^(9::Int)) | 155 | liftIO $ ms $ Event.simple publicAddr nevdata `delayEvent` (2 * 10^(9::Int)) |
180 | 156 | ||
181 | _whenFlag :: forall (m :: * -> *) s. MonadState s m => (s -> Bool) -> m () -> m () | 157 | _whenFlag :: forall (m :: * -> *) s. MonadState s m => (s -> Bool) -> m () -> m () |
182 | _whenFlag flag f = gets flag >>= flip when f | 158 | _whenFlag flag f = gets flag >>= flip when f |
@@ -188,6 +164,12 @@ processCommand "C" = do | |||
188 | let mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128) | 164 | let mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128) |
189 | let notes = (Event.NoteEv Event.NoteOn . mkNote) <$> [60, 64, 67] | 165 | let notes = (Event.NoteEv Event.NoteOn . mkNote) <$> [60, 64, 67] |
190 | modify $ \s -> s { _playNOW = notes } | 166 | modify $ \s -> s { _playNOW = notes } |
167 | processCommand "C'" = do | ||
168 | -- changing the duration seems to do nothing | ||
169 | let mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128) | ||
170 | setDuration d note = note { Event.noteDuration = Event.Duration d } | ||
171 | let notes = (Event.NoteEv Event.NoteOn . setDuration 4290000000 . mkNote) <$> [60, 64, 67] | ||
172 | modify $ \s -> s { _playNOW = notes } | ||
191 | processCommand str = liftIO $ putStrLn $ "Unknown command: " ++ str | 173 | processCommand str = liftIO $ putStrLn $ "Unknown command: " ++ str |
192 | 174 | ||
193 | getMidiSender :: RWST LoopEnv () LoopState IO MidiHook | 175 | getMidiSender :: RWST LoopEnv () LoopState IO MidiHook |
@@ -239,21 +221,6 @@ startLineReader = do | |||
239 | _thread <- liftIO $ forkIO (forever $ tryIOError getLine >>= either (const $ putMVar mv "exit") (putMVar mv)) | 221 | _thread <- liftIO $ forkIO (forever $ tryIOError getLine >>= either (const $ putMVar mv "exit") (putMVar mv)) |
240 | return mv | 222 | return mv |
241 | 223 | ||
242 | midiToBytes :: [RecordedEvent] -> BS.ByteString | ||
243 | midiToBytes = pack . show | ||
244 | bytesToMidi :: BS.ByteString -> [RecordedEvent] | ||
245 | bytesToMidi = undefined | ||
246 | |||
247 | instance FromRow CompleteRecording where | ||
248 | fromRow = cons <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field | ||
249 | where | ||
250 | cons a a' b b' c c' d d' z = CompleteRecording (TimeSpec a a') (TimeSpec b b') (TimeSpec c c') (TimeSpec d d') (bytesToMidi z) | ||
251 | |||
252 | instance ToRow CompleteRecording where | ||
253 | toRow reco = toRow (s, ns, s', ns', s'', ns'', s''', ns''', midiToBytes midi) | ||
254 | where | ||
255 | (CompleteRecording (TimeSpec s ns) (TimeSpec s' ns') (TimeSpec s'' ns'') (TimeSpec s''' ns''') midi) = reco | ||
256 | |||
257 | saveMidi :: forall (m :: * -> *). (MonadIO m, MonadState LoopState m, MonadReader LoopEnv m) => Recording -> m () | 224 | saveMidi :: forall (m :: * -> *). (MonadIO m, MonadState LoopState m, MonadReader LoopEnv m) => Recording -> m () |
258 | saveMidi recording = do | 225 | saveMidi recording = do |
259 | saver <- asks _saver | 226 | saver <- asks _saver |