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
|
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
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
}
emptyLoopState = LoopState Set.empty []
main' = withAlsaInit $ \h public private q publicAddr privateAddr -> do
cmdlineAlsaConnect h public
putStrLn "Rock on!"
startTime <- getTime Monotonic
(_, ()) <- execRWST loop (startTime, h, public, private, q, publicAddr, privateAddr) (emptyLoopState startTime)
return ()
loop = do
(startTime, h, _, _, q, publicAddr, _) <- ask
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 <- liftIO $ getTime Monotonic
let delta = now - startTime
let newEvents = map (MidiEvent now) events
liftIO $ printChordLn newKeys
modify $ \s -> s { keysDown = newKeys, inputHistory = newEvents ++ inputHistory s }
when (Set.null newKeys) $ do
hist <- gets $ takeWhile (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 }
modify $ \s -> s { lastTick = now }
loop
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
|
