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
|
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.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 PortInfo
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 qualified Data.Set as Set
printWords [] = return ()
printWords ls = putStrLn $ foldr1 (\a b -> a ++ " " ++ b) ls
pitchWords set = map (show . 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
alsaInit k = do
SndSeq.withDefault SndSeq.Nonblock $ \h -> do
Client.setName (h :: SndSeq.T SndSeq.DuplexMode) "Haskell-Beat"
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
PortInfo.modify h public $ do
PortInfo.setTimestamping True
PortInfo.setTimestampReal True
PortInfo.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
main :: IO ()
main = (do
alsaInit $ \h public private q publicAddr privateAddr -> 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
IO.hPutStrLn IO.stderr "need arguments: input-client output-client"
Exit.exitFailure
let wait keysDown = do
pending <- Event.inputPending h True
if (pending > 0)
then do
ev <- Event.input h
case Event.body ev of
Event.NoteEv Event.NoteOn n -> return (Event.NoteOn, n, Set.insert (Event.noteNote n) keysDown)
Event.NoteEv Event.NoteOff n -> return (Event.NoteOff, n, Set.delete (Event.noteNote n) keysDown)
_ -> wait keysDown
else
wait keysDown
let mkEv e =
(Event.simple publicAddr e) {
Event.queue = q,
Event.time = Time.consAbs $ Time.Real $ RealTime.fromDouble 0
}
let go keysDown = do
(onoff, note, down) <- wait keysDown
--putStrLn $ prettyNote note
printWords $ pitchWords down
Event.output h $ mkEv $ Event.NoteEv onoff note
_ <- Event.drainOutput h
go down
go Set.empty)
`AlsaExc.catch` \e ->
putStrLn $ "alsa_exception: " ++ AlsaExc.show e
|
