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
|
import qualified Sound.ALSA.Exception as AlsaExc
import qualified Sound.ALSA.Sequencer.Address as Addr
import qualified Sound.ALSA.Sequencer as SndSeq
import qualified Sound.ALSA.Sequencer.Client as Client
import qualified Sound.ALSA.Sequencer.Client.Info as ClientInfo
import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo
import qualified Sound.ALSA.Sequencer.Connect as Connect
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.ALSA.Sequencer.Event.RemoveMonad as Remove
import qualified Sound.ALSA.Sequencer.Port as Port
import qualified Sound.ALSA.Sequencer.Port.InfoMonad as PortInfoM
import qualified Sound.ALSA.Sequencer.Queue as Queue
import qualified Sound.ALSA.Sequencer.RealTime as RealTime
import qualified Sound.ALSA.Sequencer.Time as Time
import qualified System.Exit as Exit
import qualified System.IO as IO
import System.Environment (getArgs, )
import Text.Printf
import Control.Monad (when, forM_, forM)
import qualified Data.Set as Set
import Data.List (group, sort)
import Haskore.Basic.Pitch
import Control.Concurrent (threadDelay)
joinWords [] = ""
joinWords ls = foldr1 (\a b -> a ++ " " ++ b) ls
printWords [] = return () -- print nothing if no words (not an empty line)
printWords ls = putStrLn $ joinWords ls
showPitch x =
let (octave, pitch) = Haskore.Basic.Pitch.fromInt $ fromIntegral x
in Haskore.Basic.Pitch.classFormat pitch (show octave)
pitchWords set = map (showPitch . Event.unPitch) $ Set.toList set
prettyNote :: Event.Note -> String
prettyNote (Event.Note noteChannel noteNote noteVelocity noteOffVelocity noteDuration) =
let pitch = Event.unPitch noteNote
vlcty = Event.unVelocity noteVelocity
in
printf "%d(%d)" pitch vlcty
showPorts ls = joinWords $ map (show . head) $ group $ sort ls
showAlsaPorts h = do
c <- alsaClients h
putStrLn ""
printf "%15s %s\n" "Ports" "Names"
printf "%15s %s\n" "=====" "====="
forM c (\(name, ports) -> printf "%15s %s\n" (showPorts ports) name)
putStrLn ""
alsaClients h = do
portsNames <- ClientInfo.queryLoop h $ \cinfo -> do
ports <- alsaClientPorts h cinfo
name <- ClientInfo.getName cinfo
return (name, ports)
return portsNames
alsaClientPorts h cinfo = do
client <- ClientInfo.getClient cinfo
ports <- PortInfo.queryLoop h client $ \pinfo -> do
c <- PortInfo.getClient pinfo
let (Client.Cons p) = c in
return p
return ports
alsaInit k = do
SndSeq.withDefault SndSeq.Nonblock $ \h -> do
Client.setName (h :: SndSeq.T SndSeq.DuplexMode) "Haskell Beats" -- In imperative language MIDI sequencer, you rock beat. In Haskell language MIDI sequencer, rock beat you!
Port.withSimple h "inout"
(Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite, Port.capSubsWrite])
(Port.types [Port.typeMidiGeneric, Port.typeApplication]) $ \public -> do
Port.withSimple h "private"
(Port.caps [Port.capRead, Port.capWrite])
(Port.types [Port.typeMidiGeneric]) $ \private -> do
Queue.with h $ \q -> do
PortInfoM.modify h public $ do
PortInfoM.setTimestamping True
PortInfoM.setTimestampReal True
PortInfoM.setTimestampQueue q
c <- Client.getId h
let publicAddr = Addr.Cons c public
privateAddr = Addr.Cons c private
Queue.control h q Event.QueueStart Nothing
k h public private q publicAddr privateAddr
cmdlineAlsaConnect h public = do
args <- getArgs
case args of
[input, output] -> do
(Connect.createFrom h public =<< Addr.parse h input)
(Connect.createTo h public =<< Addr.parse h output)
return ()
_ -> do
showAlsaPorts h
IO.hPutStrLn IO.stderr "need arguments: input-port output-port"
Exit.exitFailure
parseAlsaEvents h keysDown immediate = loop keysDown
where
loop keysDown = do
pending <- Event.inputPending h True
if (pending == 0) then
return keysDown
else do
ev <- Event.input h
case Event.body ev of
Event.NoteEv Event.NoteOn n -> do
immediate Event.NoteEv Event.NoteOn n
loop (Set.insert (Event.noteNote n) keysDown)
Event.NoteEv Event.NoteOff n -> do
immediate Event.NoteEv Event.NoteOff n
loop (Set.delete (Event.noteNote n) keysDown)
_ -> loop keysDown
main :: IO ()
main = (do
alsaInit $ \h public private q publicAddr privateAddr -> do
cmdlineAlsaConnect h public
let mkEv e =
(Event.simple publicAddr e) {
Event.queue = q,
Event.time = Time.consAbs $ Time.Real $ RealTime.fromDouble 0
}
let
go keysDown = do
let immediate = \a b c -> do { Event.output h $ mkEv $ a b c; _ <- Event.drainOutput h; return (); }
keysDown' <- parseAlsaEvents h keysDown immediate
if (keysDown == keysDown') then
threadDelay 15000 -- 15ms. Seems like a lot, but it sounds OK. Cuts CPU down to 2%.
else do
printWords $ pitchWords keysDown'
go keysDown'
putStrLn "Rock on!"
go Set.empty)
`AlsaExc.catch` \e ->
putStrLn $ "alsa_exception: " ++ AlsaExc.show e
|
