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
|
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
main = main' `AlsaExc.catch` handler
where
handler e = putStrLn $ "alsa_exception: " ++ AlsaExc.show e
data EVENT = EVENT TimeSpec Event.T
deriving Show
data LoopState = LoopState {
keysDown :: MidiPitchSet,
inputHistory :: [Maybe 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 (Just . (EVENT now)) events
liftIO $ printChordLn newKeys
modify $ \s -> s { keysDown = newKeys, inputHistory = newEvents ++ inputHistory s }
when (Set.null newKeys) $ do
hist <- gets (takeWhile isJust . inputHistory)
liftIO $ print hist
modify $ \s -> s { inputHistory = Nothing:inputHistory s }
modify $ \s -> s { lastTick = now }
loop
|