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
|
module AlsaSeq (withAlsaInit, parseAlsaEvents, parseAlsaEvents'', forwardNoteEvent,
cmdlineAlsaConnect, printChordLn, printChordLn', showChord, pitchList, showPitch,
unPitch, unChannel, MidiHook, MidiPitchSet, MidiPitchMap) where
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
import qualified Data.Set as Set
import qualified Data.Map.Strict as Map
import Data.List (group, sort)
import Haskore.Basic.Pitch
import Foreign.C.Error (Errno(Errno))
import Control.Exception.Base (try)
unPitch = Event.unPitch
unChannel = Event.unChannel
printChordLn set = printWords $ pitchWords set
printChordLn' = printWords . map (showPitch . Event.unPitch . snd) . Map.keys
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
showChord ls = joinWords $ pitchWords ls
showPitch x =
let (octave, pitch) = Haskore.Basic.Pitch.fromInt $ fromIntegral x
in Haskore.Basic.Pitch.classFormat pitch (show octave)
pitchWords set = map showPitch $ pitchList set
pitchList set = map (Event.unPitch . snd) (Set.toList set)
pitchLists set = map (\ (c, n) -> (Event.unChannel c, Event.unPitch n)) $ 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 =
ClientInfo.queryLoop h $ \cinfo -> do
ports <- alsaClientPorts h cinfo
name <- ClientInfo.getName cinfo
return (name, ports)
alsaClientPorts h cinfo = do
client <- ClientInfo.getClient cinfo
PortInfo.queryLoop h client $ \pinfo -> do
(Client.Cons ports) <- PortInfo.getClient pinfo
return ports
withAlsaInit k =
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" inout_caps inout_types $ \public ->
Port.withSimple h "private" private_caps private_types $ \private -> 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
where
inout_caps = Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite, Port.capSubsWrite]
inout_types = Port.types [Port.typeMidiGeneric, Port.typeApplication]
private_caps = Port.caps [Port.capRead, Port.capWrite]
private_types = Port.types [Port.typeMidiGeneric]
cmdlineAlsaConnect h public = do
args <- getArgs
case args of
["0"] ->
return ()
["0", output] ->
void $ Connect.createTo h public =<< Addr.parse h output
[input] ->
void $ Connect.createFrom h public =<< Addr.parse h input
[input, output] -> do
void $ Connect.createFrom h public =<< Addr.parse h input
void $ Connect.createTo h public =<< Addr.parse h output
_ -> do
showAlsaPorts h
IO.hPutStrLn IO.stderr "need arguments: <input-port> [output-port]"
IO.hPutStrLn IO.stderr " (use port 0 for no input)"
Exit.exitFailure
inputPendingLoop h b = do
mres <- try (Event.inputPending h b)
case mres of
(Left e) ->
case e of
(AlsaExc.Cons _ _ (Errno 4)) -> inputPendingLoop h b
-- axis: AlsaException.Cons "inputPending" "Interrupted system call" (Errno 4)
-- Happens all the time, means nothing.
(AlsaExc.Cons location _ code) -> do
putStrLn $ "alsa_exception: " ++ AlsaExc.show e -- TODO: log this to a file
AlsaExc.throw location code
(Right result) -> return result
type MidiPitchSet = Set.Set (Event.Channel, Event.Pitch)
type MidiPitchMap = Map.Map (Event.Channel, Event.Pitch) Event.Velocity
parseAlsaEvents :: SndSeq.AllowInput mode =>
SndSeq.T mode -> Set.Set (Event.Channel, Event.Pitch) -> (Event.T -> IO a) -> IO MidiPitchSet
parseAlsaEvents h keysDownInit immediate = loop keysDownInit
where
loop keysDown = do
pending <- inputPendingLoop h True
if pending == 0 then
return keysDown
else do
ev <- Event.input h
_ <- immediate ev
case Event.body ev of
Event.NoteEv Event.NoteOn n ->
if Event.unVelocity (Event.noteVelocity n) == 0 then
loop (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown)
else
loop (Set.insert (Event.noteChannel n, Event.noteNote n) keysDown)
Event.NoteEv Event.NoteOff n ->
loop (Set.delete (Event.noteChannel n, Event.noteNote n) keysDown)
_ -> loop keysDown
parseAlsaEvents'' :: SndSeq.AllowInput mode => SndSeq.T mode -> MidiPitchMap -> (Event.T -> IO t) -> IO ([Event.T], MidiPitchMap)
parseAlsaEvents'' h keysDownInit immediate = loop [] keysDownInit
where
loop events keysDown = do
pending <- inputPendingLoop h True
if pending == 0 then
return (events, keysDown)
else do
ev <- Event.input h
_ <- immediate ev
case Event.body ev of
Event.NoteEv Event.NoteOn n ->
if Event.unVelocity (Event.noteVelocity n) == 0 then
loop (ev:events) (Map.delete (Event.noteChannel n, Event.noteNote n) keysDown)
else
loop (ev:events) (Map.insert (Event.noteChannel n, Event.noteNote n) (Event.noteVelocity n) keysDown)
Event.NoteEv Event.NoteOff n ->
loop (ev:events) (Map.delete (Event.noteChannel n, Event.noteNote n) keysDown)
_ -> loop (ev:events) keysDown
type MidiHook = Event.T -> IO ()
forwardNoteEvent :: SndSeq.AllowOutput mode => SndSeq.T mode -> Queue.T -> Addr.T -> MidiHook
forwardNoteEvent h q publicAddr ev = do
--let immediate = \a b c -> do { Event.output h $ mkEv $ a b c; _ <- Event.drainOutput h; return (); }
-- data T = Cons { highPriority :: !Bool , tag :: !Tag , queue :: !Queue.T , time :: !Time.T , source :: !Addr.T , dest :: !Addr.T , body :: !Data } deriving Show
let (Event.Cons highPriority tag _ time _ _ body) = ev
void $ Event.output h (Event.Cons highPriority tag q time publicAddr Addr.subscribers body)
void $ Event.drainOutput h
|
