summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--AlsaSeq.hs137
-rw-r--r--midi-dump.hs137
2 files changed, 140 insertions, 134 deletions
diff --git a/AlsaSeq.hs b/AlsaSeq.hs
new file mode 100644
index 0000000..a6920f0
--- /dev/null
+++ b/AlsaSeq.hs
@@ -0,0 +1,137 @@
1module AlsaSeq (alsaInit, parseAlsaEvents, forwardNoteEvent, cmdlineAlsaConnect, printChordLn) where
2import qualified Sound.ALSA.Exception as AlsaExc
3import qualified Sound.ALSA.Sequencer.Address as Addr
4import qualified Sound.ALSA.Sequencer as SndSeq
5import qualified Sound.ALSA.Sequencer.Client as Client
6import qualified Sound.ALSA.Sequencer.Client.Info as ClientInfo
7import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo
8import qualified Sound.ALSA.Sequencer.Connect as Connect
9import qualified Sound.ALSA.Sequencer.Event as Event
10import qualified Sound.ALSA.Sequencer.Event.RemoveMonad as Remove
11import qualified Sound.ALSA.Sequencer.Port as Port
12import qualified Sound.ALSA.Sequencer.Port.InfoMonad as PortInfoM
13import qualified Sound.ALSA.Sequencer.Queue as Queue
14import qualified Sound.ALSA.Sequencer.RealTime as RealTime
15import qualified Sound.ALSA.Sequencer.Time as Time
16import qualified System.Exit as Exit
17import qualified System.IO as IO
18import System.Environment (getArgs, )
19import Text.Printf
20import Control.Monad (when, forM_, forM)
21
22import qualified Data.Set as Set
23import Data.List (group, sort)
24import Haskore.Basic.Pitch
25
26printChordLn set = printWords $ pitchWords set
27
28joinWords [] = ""
29joinWords ls = foldr1 (\a b -> a ++ " " ++ b) ls
30
31printWords [] = return () -- print nothing if no words (not an empty line)
32printWords ls = putStrLn $ joinWords ls
33
34showPitch x =
35 let (octave, pitch) = Haskore.Basic.Pitch.fromInt $ fromIntegral x
36 in Haskore.Basic.Pitch.classFormat pitch (show octave)
37
38pitchWords set = map (showPitch . Event.unPitch) $ Set.toList set
39
40prettyNote :: Event.Note -> String
41prettyNote (Event.Note noteChannel noteNote noteVelocity noteOffVelocity noteDuration) =
42 let pitch = Event.unPitch noteNote
43 vlcty = Event.unVelocity noteVelocity
44 in
45 printf "%d(%d)" pitch vlcty
46
47showPorts ls = joinWords $ map (show . head) $ group $ sort ls
48
49showAlsaPorts h = do
50 c <- alsaClients h
51 putStrLn ""
52 printf "%15s %s\n" "Ports" "Names"
53 printf "%15s %s\n" "=====" "====="
54 forM c (\(name, ports) -> printf "%15s %s\n" (showPorts ports) name)
55 putStrLn ""
56
57alsaClients h = do
58 portsNames <- ClientInfo.queryLoop h $ \cinfo -> do
59 ports <- alsaClientPorts h cinfo
60 name <- ClientInfo.getName cinfo
61 return (name, ports)
62 return portsNames
63
64alsaClientPorts h cinfo = do
65 client <- ClientInfo.getClient cinfo
66 ports <- PortInfo.queryLoop h client $ \pinfo -> do
67 c <- PortInfo.getClient pinfo
68 let (Client.Cons p) = c in
69 return p
70 return ports
71
72alsaInit k = do
73 SndSeq.withDefault SndSeq.Nonblock $ \h -> do
74
75 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!
76
77 Port.withSimple h "inout"
78 (Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite, Port.capSubsWrite])
79 (Port.types [Port.typeMidiGeneric, Port.typeApplication]) $ \public -> do
80 Port.withSimple h "private"
81 (Port.caps [Port.capRead, Port.capWrite])
82 (Port.types [Port.typeMidiGeneric]) $ \private -> do
83 Queue.with h $ \q -> do
84
85 PortInfoM.modify h public $ do
86 PortInfoM.setTimestamping True
87 PortInfoM.setTimestampReal True
88 PortInfoM.setTimestampQueue q
89
90 c <- Client.getId h
91 let publicAddr = Addr.Cons c public
92 privateAddr = Addr.Cons c private
93
94 Queue.control h q Event.QueueStart Nothing
95
96 k h public private q publicAddr privateAddr
97
98cmdlineAlsaConnect h public = do
99 args <- getArgs
100 case args of
101
102 [input, output] -> do
103 (Connect.createFrom h public =<< Addr.parse h input)
104 (Connect.createTo h public =<< Addr.parse h output)
105 return ()
106
107 _ -> do
108 showAlsaPorts h
109 IO.hPutStrLn IO.stderr "need arguments: input-port output-port"
110 Exit.exitFailure
111
112parseAlsaEvents h keysDown immediate = loop keysDown
113 where
114 loop keysDown = do
115 pending <- Event.inputPending h True
116 if (pending == 0) then
117 return keysDown
118 else do
119 ev <- Event.input h
120 case Event.body ev of
121 Event.NoteEv Event.NoteOn n -> do
122 immediate ev
123 loop (Set.insert (Event.noteNote n) keysDown)
124 Event.NoteEv Event.NoteOff n -> do
125 immediate ev
126 loop (Set.delete (Event.noteNote n) keysDown)
127 _ -> loop keysDown
128
129forwardNoteEvent h q publicAddr ev = do
130 let mkEv e = (Event.simple publicAddr e) { Event.queue = q, Event.time = Time.consAbs $ Time.Real $ RealTime.fromDouble 0 }
131 let immediate = \a b c -> do { Event.output h $ mkEv $ a b c; _ <- Event.drainOutput h; return (); }
132 case Event.body ev of
133 Event.NoteEv Event.NoteOn n -> immediate Event.NoteEv Event.NoteOn n
134 Event.NoteEv Event.NoteOff n -> immediate Event.NoteEv Event.NoteOff n
135 -- TODO: forward other event types?
136 _ -> return ()
137
diff --git a/midi-dump.hs b/midi-dump.hs
index d463750..3de065b 100644
--- a/midi-dump.hs
+++ b/midi-dump.hs
@@ -1,139 +1,8 @@
1import AlsaSeq
2import Control.Concurrent (threadDelay)
1import qualified Sound.ALSA.Exception as AlsaExc 3import qualified Sound.ALSA.Exception as AlsaExc
2import qualified Sound.ALSA.Sequencer.Address as Addr
3import qualified Sound.ALSA.Sequencer as SndSeq
4import qualified Sound.ALSA.Sequencer.Client as Client
5import qualified Sound.ALSA.Sequencer.Client.Info as ClientInfo
6import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo
7import qualified Sound.ALSA.Sequencer.Connect as Connect
8import qualified Sound.ALSA.Sequencer.Event as Event
9import qualified Sound.ALSA.Sequencer.Event.RemoveMonad as Remove
10import qualified Sound.ALSA.Sequencer.Port as Port
11import qualified Sound.ALSA.Sequencer.Port.InfoMonad as PortInfoM
12import qualified Sound.ALSA.Sequencer.Queue as Queue
13import qualified Sound.ALSA.Sequencer.RealTime as RealTime
14import qualified Sound.ALSA.Sequencer.Time as Time
15import qualified System.Exit as Exit
16import qualified System.IO as IO
17import System.Environment (getArgs, )
18import Text.Printf
19import Control.Monad (when, forM_, forM)
20
21import qualified Data.Set as Set 4import qualified Data.Set as Set
22import Data.List (group, sort)
23import Haskore.Basic.Pitch
24import Control.Concurrent (threadDelay)
25
26joinWords [] = ""
27joinWords ls = foldr1 (\a b -> a ++ " " ++ b) ls
28
29printWords [] = return () -- print nothing if no words (not an empty line)
30printWords ls = putStrLn $ joinWords ls
31
32showPitch x =
33 let (octave, pitch) = Haskore.Basic.Pitch.fromInt $ fromIntegral x
34 in Haskore.Basic.Pitch.classFormat pitch (show octave)
35
36pitchWords set = map (showPitch . Event.unPitch) $ Set.toList set
37
38prettyNote :: Event.Note -> String
39prettyNote (Event.Note noteChannel noteNote noteVelocity noteOffVelocity noteDuration) =
40 let pitch = Event.unPitch noteNote
41 vlcty = Event.unVelocity noteVelocity
42 in
43 printf "%d(%d)" pitch vlcty
44
45showPorts ls = joinWords $ map (show . head) $ group $ sort ls
46
47showAlsaPorts h = do
48 c <- alsaClients h
49 putStrLn ""
50 printf "%15s %s\n" "Ports" "Names"
51 printf "%15s %s\n" "=====" "====="
52 forM c (\(name, ports) -> printf "%15s %s\n" (showPorts ports) name)
53 putStrLn ""
54
55alsaClients h = do
56 portsNames <- ClientInfo.queryLoop h $ \cinfo -> do
57 ports <- alsaClientPorts h cinfo
58 name <- ClientInfo.getName cinfo
59 return (name, ports)
60 return portsNames
61
62alsaClientPorts h cinfo = do
63 client <- ClientInfo.getClient cinfo
64 ports <- PortInfo.queryLoop h client $ \pinfo -> do
65 c <- PortInfo.getClient pinfo
66 let (Client.Cons p) = c in
67 return p
68 return ports
69
70alsaInit k = do
71 SndSeq.withDefault SndSeq.Nonblock $ \h -> do
72
73 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!
74
75 Port.withSimple h "inout"
76 (Port.caps [Port.capRead, Port.capSubsRead, Port.capWrite, Port.capSubsWrite])
77 (Port.types [Port.typeMidiGeneric, Port.typeApplication]) $ \public -> do
78 Port.withSimple h "private"
79 (Port.caps [Port.capRead, Port.capWrite])
80 (Port.types [Port.typeMidiGeneric]) $ \private -> do
81 Queue.with h $ \q -> do
82
83 PortInfoM.modify h public $ do
84 PortInfoM.setTimestamping True
85 PortInfoM.setTimestampReal True
86 PortInfoM.setTimestampQueue q
87
88 c <- Client.getId h
89 let publicAddr = Addr.Cons c public
90 privateAddr = Addr.Cons c private
91
92 Queue.control h q Event.QueueStart Nothing
93
94 k h public private q publicAddr privateAddr
95
96cmdlineAlsaConnect h public = do
97 args <- getArgs
98 case args of
99
100 [input, output] -> do
101 (Connect.createFrom h public =<< Addr.parse h input)
102 (Connect.createTo h public =<< Addr.parse h output)
103 return ()
104
105 _ -> do
106 showAlsaPorts h
107 IO.hPutStrLn IO.stderr "need arguments: input-port output-port"
108 Exit.exitFailure
109
110parseAlsaEvents h keysDown immediate = loop keysDown
111 where
112 loop keysDown = do
113 pending <- Event.inputPending h True
114 if (pending == 0) then
115 return keysDown
116 else do
117 ev <- Event.input h
118 case Event.body ev of
119 Event.NoteEv Event.NoteOn n -> do
120 immediate ev
121 loop (Set.insert (Event.noteNote n) keysDown)
122 Event.NoteEv Event.NoteOff n -> do
123 immediate ev
124 loop (Set.delete (Event.noteNote n) keysDown)
125 _ -> loop keysDown
126
127forwardNoteEvent h q publicAddr ev = do
128 let mkEv e = (Event.simple publicAddr e) { Event.queue = q, Event.time = Time.consAbs $ Time.Real $ RealTime.fromDouble 0 }
129 let immediate = \a b c -> do { Event.output h $ mkEv $ a b c; _ <- Event.drainOutput h; return (); }
130 case Event.body ev of
131 Event.NoteEv Event.NoteOn n -> immediate Event.NoteEv Event.NoteOn n
132 Event.NoteEv Event.NoteOff n -> immediate Event.NoteEv Event.NoteOff n
133 -- TODO: forward other event types?
134 _ -> return ()
135 5
136main :: IO ()
137main = (do 6main = (do
138 7
139 alsaInit $ \h public private q publicAddr privateAddr -> do 8 alsaInit $ \h public private q publicAddr privateAddr -> do
@@ -146,7 +15,7 @@ main = (do
146 if (keysDown == keysDown') then 15 if (keysDown == keysDown') then
147 threadDelay 15000 -- 15ms. Seems like a lot, but it sounds OK. Cuts CPU down to 2%. 16 threadDelay 15000 -- 15ms. Seems like a lot, but it sounds OK. Cuts CPU down to 2%.
148 else do 17 else do
149 printWords $ pitchWords keysDown' 18 printChordLn keysDown'
150 go keysDown' 19 go keysDown'
151 20
152 putStrLn "Rock on!" 21 putStrLn "Rock on!"
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-29 16:44:10 +0000