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
|
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
import AlsaSeq
import Control.Concurrent (threadDelay)
import qualified Sound.ALSA.Exception as AlsaExc
import qualified Data.Set as Set
import qualified Haskore.Basic.Pitch as Pitch
import qualified Sound.ALSA.Sequencer.Event as Event
import Control.Monad.RWS.Strict
import Data.Maybe
import Data.List
import System.Clock
import Control.Applicative
import qualified Data.ByteString as BS
import Database.SQLite.Simple
import Database.SQLite.Simple.FromRow
import Data.Int
import Data.ByteString.Char8 (pack)
import Control.Concurrent.Chan
import Prelude hiding ((.))
import BasePrelude hiding (loop)
verbose = False
main = main' `AlsaExc.catch` handler
where
handler e = when (verbose) $ putStrLn $ "alsa_exception: " ++ AlsaExc.show e
data EVENT = MidiEvent TimeSpec Event.T | Silence TimeSpec
deriving Show
isSilence (Silence _) = True
isSilence _ = False
getTS (MidiEvent ts _) = ts
getTS (Silence ts) = ts
data LoopState = LoopState {
keysDown :: MidiPitchSet,
inputHistory :: [EVENT],
lastTick :: TimeSpec
}
data LoopEnv = LoopEnv {
saver :: _,
sqlite :: _,
startTime :: TimeSpec,
startTimeReal :: TimeSpec,
h :: _,
public :: _,
private :: _,
q :: _,
publicAddr :: _,
privateAddr :: _
}
getAbsTime = do
sqlite <- asks sqlite
startTime <- asks startTime
startTimeReal <- asks startTimeReal
now <- liftIO $ getTime Monotonic
return $ now - startTime + startTimeReal
emptyLoopState = LoopState Set.empty []
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 "CREATE TABLE IF NOT EXISTS chunks (id INTEGER PRIMARY KEY, sec INTEGER, nsec INTEGER, midi BLOB)"
saver <- startSaver sqlite
let env = LoopEnv saver sqlite startTime startTimeReal h public private q publicAddr privateAddr
(_, ()) <- execRWST loop env (emptyLoopState startTime)
return ()
loop = do
startTime <- asks startTime
startTimeReal <- asks startTimeReal
h <- asks h
q <- asks q
publicAddr <- asks publicAddr
oldKeys <- gets keysDown
let forwardNOW = forwardNoteEvent h q publicAddr
(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 (MidiEvent now) events
liftIO $ printChordLn newKeys
modify $ \s -> s { keysDown = newKeys, inputHistory = newEvents ++ inputHistory s, lastTick = now }
when (Set.null newKeys) $ do
{-
chunk <- gets $ takeWhile (not . isSilence) . inputHistory
saveMidi chunk
hist <- gets $ filter (not . isSilence) . inputHistory
liftIO $ print $ map (`div` 1000000) $ tsDeltas $ map getTS $ reverse hist
liftIO $ print $ mapMaybe getMidiDesc $ reverse hist
modify $ \s -> s { inputHistory = Silence now:inputHistory s }
-}
gets inputHistory >>= saveMidi >> return ()
modify $ \s -> s { inputHistory = [] }
loop
data Chunk = Chunk Int64 Int64 BS.ByteString
instance FromRow Chunk where
fromRow = Chunk <$> field <*> field <*> field
instance ToRow Chunk where
toRow (Chunk s ns b) = toRow (s, ns, b)
saveMidi chunk = do
saver <- asks saver
(TimeSpec s ns) <- gets lastTick
liftIO $ writeChan saver (s, ns, chunk)
startSaver sqlite = do
chan <- liftIO $ newChan
thread <- liftIO $ forkIO (saver sqlite chan)
return chan
where
saver sqlite chan = forever $ do
(s, ns, chunk) <- readChan chan
let bytes = pack $ show chunk
liftIO $ execute sqlite "INSERT INTO chunks (sec, nsec, midi) VALUES (?,?,?)" (Chunk s ns bytes)
return ()
getMidiDesc :: EVENT -> Maybe String
getMidiDesc (MidiEvent _ (Event.Cons _ _ _ _ _ _ (Event.NoteEv Event.NoteOn ev))) = return $ ("on:" ++) $ showPitch $ unPitch $ Event.noteNote ev
getMidiDesc (MidiEvent _ (Event.Cons _ _ _ _ _ _ (Event.NoteEv Event.NoteOff ev))) = return $ ("off:" ++) $ showPitch $ unPitch $ Event.noteNote ev
getMidiDesc _ = Nothing
tsDeltas :: [TimeSpec] -> [Integer]
tsDeltas [] = []
tsDeltas ls@(x:xs) = map (\(a,b) -> a - b) $ zip nsecs (0:nsecs)
where
nsecs = map timeSpecAsNanoSecs rel
rel = map (\y -> y - x) ls
|
