From 98a3be73f6fa8a8e3f998dd3ace2efab34aa38b8 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Wed, 15 Jan 2014 12:25:02 -0500 Subject: factor functions into separate module AlsaSeq.hs --- midi-dump.hs | 137 ++--------------------------------------------------------- 1 file changed, 3 insertions(+), 134 deletions(-) (limited to 'midi-dump.hs') 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 @@ +import AlsaSeq +import Control.Concurrent (threadDelay) 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 ev - loop (Set.insert (Event.noteNote n) keysDown) - Event.NoteEv Event.NoteOff n -> do - immediate ev - loop (Set.delete (Event.noteNote n) keysDown) - _ -> loop keysDown - -forwardNoteEvent h q publicAddr ev = do - let mkEv e = (Event.simple publicAddr e) { Event.queue = q, Event.time = Time.consAbs $ Time.Real $ RealTime.fromDouble 0 } - let immediate = \a b c -> do { Event.output h $ mkEv $ a b c; _ <- Event.drainOutput h; return (); } - case Event.body ev of - Event.NoteEv Event.NoteOn n -> immediate Event.NoteEv Event.NoteOn n - Event.NoteEv Event.NoteOff n -> immediate Event.NoteEv Event.NoteOff n - -- TODO: forward other event types? - _ -> return () -main :: IO () main = (do alsaInit $ \h public private q publicAddr privateAddr -> do @@ -146,7 +15,7 @@ main = (do 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' + printChordLn keysDown' go keysDown' putStrLn "Rock on!" -- cgit v1.2.3