1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
|
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE KindSignatures #-}
import AlsaSeq
import Control.Monad.RWS.Strict
import Data.List
import Data.Maybe
import qualified Data.Set as Set
import qualified Sound.ALSA.Exception as AlsaExc
import qualified Sound.ALSA.Sequencer.Event as Event
import System.Clock
import Control.Applicative
import qualified Data.ByteString as BS
import Data.ByteString.Char8 (pack)
import Data.Int
import Database.SQLite.Simple
import Database.SQLite.Simple.FromRow ()
import BasePrelude hiding (loop)
import Control.Concurrent.Chan ()
import Prelude hiding (id, (.))
import qualified Sound.ALSA.Sequencer
import qualified Sound.ALSA.Sequencer.Address
import qualified Sound.ALSA.Sequencer.Port
import qualified Sound.ALSA.Sequencer.Queue
verbose :: Bool
verbose = False
main :: IO ()
main = main' `AlsaExc.catch` handler
where
handler e = when verbose $ putStrLn $ "alsa_exception: " ++ AlsaExc.show e
type RecordedEvents = [(TimeSpec, Event.T)]
data Recording = Recording {
_recordingStart :: TimeSpec, -- from initial silence
_recordingEvents :: RecordedEvents
}
data FinishedRecording = FinishedRecording Recording TimeSpec
recordEvents :: Recording -> RecordedEvents -> Recording
recordEvents (Recording s orig) new = Recording s (new ++ orig)
data LoopState = LoopState {
_wantExit :: Bool,
keysDown :: MidiPitchSet,
_playNOW :: [Event.Data],
_recording :: Recording,
lastTick :: TimeSpec
}
initializeState :: TimeSpec -> LoopState
initializeState now = LoopState False Set.empty [] (emptyRecording now) now
data LoopEnv = LoopEnv {
_saver :: Chan FinishedRecording,
_sqlite :: Connection,
_startTime :: TimeSpec,
_startTimeReal :: TimeSpec,
_h :: Sound.ALSA.Sequencer.T Sound.ALSA.Sequencer.DuplexMode,
_public :: Sound.ALSA.Sequencer.Port.T,
_private :: Sound.ALSA.Sequencer.Port.T,
_q :: Sound.ALSA.Sequencer.Queue.T,
_publicAddr :: Sound.ALSA.Sequencer.Address.T,
_privateAddr :: Sound.ALSA.Sequencer.Address.T,
_doSave :: Bool,
_lineReader :: MVar String
}
getAbsTime :: RWST LoopEnv () LoopState IO TimeSpec
getAbsTime = do
startTime <- asks _startTime
startTimeReal <- asks _startTimeReal
now <- liftIO $ getTime Monotonic
return $ now - startTime + startTimeReal
createTable :: Query
createTable = fromString $ concat
["CREATE TABLE IF NOT EXISTS axis_input",
" (id INTEGER PRIMARY KEY,",
" start_sec INTEGER,",
" start_nsec INTEGER,",
" end_sec INTEGER,",
" end_nsec INTEGER,",
" leading_silence INTEGER,",
" midi BLOB)"]
main' :: IO ()
main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do
cmdlineAlsaConnect h public
putStrLn "Rock on!"
startTime <- getTime Monotonic
startTimeReal <- getTime Realtime
sqlite <- open "test.db"
execute_ sqlite createTable
saver <- startSaver sqlite
lineReader <- startLineReader
doSave <- isNothing <$> lookupEnv "NO_SAVE_MIDI"
let env = LoopEnv saver sqlite startTime startTimeReal h public private q publicAddr privateAddr doSave lineReader
(_, ()) <- execRWST mainLoop env $ initializeState startTimeReal
return ()
mainLoop :: RWST LoopEnv () LoopState IO ()
mainLoop = do
maybeReadLine >>= maybe processMidi processCommand
wantExit <- gets _wantExit
scheduled <- gets _playNOW
unless (null scheduled) $ do
forM_ scheduled playNoteEv
-- TODO: flush ALSA output here
modify $ \s -> s { _playNOW = [] }
unless wantExit mainLoop
_playNote :: Bool -> Event.Note -> RWST LoopEnv () LoopState IO ()
_playNote noteOn note =
playNoteEv $ Event.NoteEv onoff note
where onoff = if noteOn then Event.NoteOn else Event.NoteOff
playNoteEv :: Event.Data -> RWST LoopEnv () LoopState IO ()
playNoteEv nevdata = do
ms <- getMidiSender
publicAddr <- asks _publicAddr
liftIO $ ms $ Event.simple publicAddr nevdata
_whenFlag :: forall (m :: * -> *) s. MonadState s m => (s -> Bool) -> m () -> m ()
_whenFlag flag f = gets flag >>= flip when f
processCommand :: forall (m :: * -> *). (MonadIO m, MonadState LoopState m) => String -> m ()
processCommand "exit" = modify $ \s -> s { _wantExit = True }
processCommand "" = return ()
processCommand "C" = do
let mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128)
let notes = (Event.NoteEv Event.NoteOn . mkNote) <$> [60, 64, 67]
modify $ \s -> s { _playNOW = notes }
processCommand str = liftIO $ putStrLn $ "Unknown command: " ++ str
getMidiSender :: RWST LoopEnv () LoopState IO MidiHook
getMidiSender = do
h <- asks _h
q <- asks _q
publicAddr <- asks _publicAddr
return $ forwardNoteEvent h q publicAddr
processMidi :: RWST LoopEnv () LoopState IO ()
processMidi = do
h <- asks _h
oldKeys <- gets keysDown
forwardNOW <- getMidiSender
(events, newKeys) <- liftIO $ parseAlsaEvents' h oldKeys forwardNOW
if oldKeys == newKeys then
liftIO $ threadDelay 15000 -- 15ms. Seems like a lot, but it sounds OK. Cuts CPU down to 2%.
else do
now <- getAbsTime
let newEvents = map ((,) now) events
liftIO $ printChordLn newKeys
modify $ \s -> s { keysDown = newKeys, _recording = recordEvents (_recording s) newEvents, lastTick = now }
when (Set.null newKeys) $ do
doSave <- asks _doSave
when doSave $ gets _recording >>= saveMidi >> return ()
modify $ \s -> s { _recording = emptyRecording now }
emptyRecording :: TimeSpec -> Recording
emptyRecording now = Recording now []
maybeReadLine :: RWST LoopEnv () LoopState IO (Maybe String)
maybeReadLine = asks _lineReader >>= liftIO . tryTakeMVar
startLineReader :: IO (MVar String)
startLineReader = do
mv <- liftIO newEmptyMVar
_thread <- liftIO $ forkIO (forever $ tryIOError getLine >>= either (const $ putMVar mv "exit") (putMVar mv))
return mv
data Chunk = Chunk Int64 Int64 Int64 Int64 Int64 BS.ByteString
instance FromRow Chunk where
fromRow = Chunk <$> field <*> field <*> field <*> field <*> field <*> field
instance ToRow Chunk where
toRow (Chunk s ns s' ns' d m) = toRow (s, ns, s', ns', d, m)
data Chunkable = MkChunk FinishedRecording TimeSpec
instance ToRow Chunkable where
toRow (MkChunk reco ts) = toRow (s, ns, s', ns', leadingSilence :: Int64, pack $ show midi)
where
(FinishedRecording (Recording start@(TimeSpec s ns) midi) (TimeSpec s' ns')) = reco
leadingSilence = fromIntegral $ timeSpecAsNanoSecs $ ts - start
saveMidi :: forall (m :: * -> *). (MonadIO m, MonadState LoopState m, MonadReader LoopEnv m) => Recording -> m ()
saveMidi recording = do
saver <- asks _saver
end <- gets lastTick
liftIO $ writeChan saver $ FinishedRecording recording end
startSaver :: forall (m :: * -> *). MonadIO m => Connection -> m (Chan FinishedRecording)
startSaver sqlite = do
chan <- liftIO newChan
_thread <- liftIO $ forkIO (saver chan)
return chan
where
saver chan = forever $ do
reco@(FinishedRecording (Recording _ events) _) <- readChan chan
let start = fst $ head events
sqlInsert = "INSERT INTO axis_input (start_sec, start_nsec, end_sec, end_nsec, leading_silence, midi) VALUES (?,?,?,?,?,?)"
liftIO $ execute sqlite sqlInsert (MkChunk reco start)
return ()
_getMidiDesc :: Event.T -> Maybe String
_getMidiDesc (Event.Cons _ _ _ _ _ _ (Event.NoteEv Event.NoteOn ev)) = return $ ("on:" ++) $ showPitch $ unPitch $ Event.noteNote ev
_getMidiDesc (Event.Cons _ _ _ _ _ _ (Event.NoteEv Event.NoteOff ev)) = return $ ("off:" ++) $ showPitch $ unPitch $ Event.noteNote ev
_getMidiDesc _ = Nothing
_tsDeltas :: [TimeSpec] -> [Integer]
_tsDeltas [] = []
_tsDeltas ls@(x:_) = zipWith (-) nsecs (0:nsecs)
where
nsecs = map timeSpecAsNanoSecs rel
rel = map (\y -> y - x) ls
|