From 7477265c3c91341bcc96181fd876de0231bd667f Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Sat, 5 Dec 2015 09:21:11 -0500 Subject: start to move midi serialization into separate file --- Midi.hs | 59 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ axis-of-eval.cabal | 3 ++- midi-dump.hs | 51 +++++++++------------------------------------- stack.yaml | 2 ++ 4 files changed, 72 insertions(+), 43 deletions(-) create mode 100644 Midi.hs diff --git a/Midi.hs b/Midi.hs new file mode 100644 index 0000000..4609d04 --- /dev/null +++ b/Midi.hs @@ -0,0 +1,59 @@ +module Midi where +import BasePrelude +import qualified Data.ByteString as BS +import Data.ByteString.Char8 (pack) +import Prelude hiding (id, (.)) +-- import Sound.MIDI.ALSA +import System.Clock +import Database.SQLite.Simple +import Database.SQLite.Simple.FromRow () + +import qualified Sound.ALSA.Sequencer.Event as Event + +-- import qualified Sound.ALSA.Sequencer +-- import qualified Sound.ALSA.Sequencer.Address +-- import qualified Sound.ALSA.Sequencer.Port +-- import qualified Sound.ALSA.Sequencer.Queue +-- import qualified Sound.ALSA.Sequencer.Time as Time +-- import qualified Sound.ALSA.Sequencer.RealTime as RealTime + +type RecordedEvent = (TimeSpec, Event.T) + +data Recording = StartRecording TimeSpec | + RecordingInProgress TimeSpec TimeSpec [RecordedEvent] + deriving Show + +data CompleteRecording = CompleteRecording { + _recStart :: TimeSpec, + _recEnd :: TimeSpec, + _recFirst :: TimeSpec, + _recLast :: TimeSpec, + _recEvents :: [RecordedEvent] +} deriving Show + +instance FromRow CompleteRecording where + fromRow = cons <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field + where + cons a a' b b' c c' d d' z = CompleteRecording (TimeSpec a a') (TimeSpec b b') (TimeSpec c c') (TimeSpec d d') (bytesToMidi z) + +instance ToRow CompleteRecording where + toRow reco = toRow (s, ns, s', ns', s'', ns'', s''', ns''', midiToBytes midi) + where + (CompleteRecording (TimeSpec s ns) (TimeSpec s' ns') (TimeSpec s'' ns'') (TimeSpec s''' ns''') midi) = reco + + +recordEvents :: Recording -> [RecordedEvent]-> Recording +recordEvents (RecordingInProgress x y orig) new = RecordingInProgress x y $ new ++ orig +recordEvents i@(StartRecording _) [] = i +recordEvents (StartRecording x) new@(_:_) = RecordingInProgress x y new + where y = fst $ last new + +stopRecording :: Recording -> TimeSpec -> Maybe CompleteRecording +stopRecording (RecordingInProgress x y ls@((z,_):_)) end = Just $ CompleteRecording x end y z ls +stopRecording _ _ = Nothing + + +midiToBytes :: [RecordedEvent] -> BS.ByteString +midiToBytes = pack . show +bytesToMidi :: BS.ByteString -> [RecordedEvent] +bytesToMidi = undefined diff --git a/axis-of-eval.cabal b/axis-of-eval.cabal index f69d3f5..acafc72 100644 --- a/axis-of-eval.cabal +++ b/axis-of-eval.cabal @@ -26,7 +26,8 @@ executable midi-dump default-language: Haskell2010 hs-source-dirs: . build-depends: - base, time, containers, haskore, alsa-seq, alsa-core, mtl, clock, sqlite-simple, bytestring, base-prelude + base, time, containers, haskore, alsa-seq, alsa-core, mtl, clock, + sqlite-simple, bytestring, base-prelude, midi-alsa, midi main-is: midi-dump.hs other-modules: AlsaSeq ghc-options: -threaded -W -Wall -O2 diff --git a/midi-dump.hs b/midi-dump.hs index f053e28..07281f5 100644 --- a/midi-dump.hs +++ b/midi-dump.hs @@ -14,8 +14,6 @@ import qualified Sound.ALSA.Sequencer.Event as Event import System.Clock import Control.Applicative -import qualified Data.ByteString as BS -import Data.ByteString.Char8 (pack) import Data.Int import Database.SQLite.Simple import Database.SQLite.Simple.FromRow () @@ -31,6 +29,8 @@ import qualified Sound.ALSA.Sequencer.Queue import qualified Sound.ALSA.Sequencer.Time as Time import qualified Sound.ALSA.Sequencer.RealTime as RealTime +import Midi + verbose :: Bool verbose = False @@ -39,30 +39,6 @@ main = main' `AlsaExc.catch` handler where handler e = when verbose $ putStrLn $ "alsa_exception: " ++ AlsaExc.show e -type RecordedEvent = (TimeSpec, Event.T) - -data Recording = StartRecording TimeSpec | - RecordingInProgress TimeSpec TimeSpec [RecordedEvent] - -data CompleteRecording = CompleteRecording { - _recStart :: TimeSpec, - _recEnd :: TimeSpec, - _recFirst :: TimeSpec, - _recLast :: TimeSpec, - _recEvents :: [RecordedEvent] -} - -recordEvents :: Recording -> [RecordedEvent]-> Recording -recordEvents (RecordingInProgress x y orig) new = RecordingInProgress x y $ new ++ orig -recordEvents i@(StartRecording _) [] = i -recordEvents (StartRecording x) new@(_:_) = RecordingInProgress x y new - where y = fst $ last new - -stopRecording :: Recording -> TimeSpec -> Maybe CompleteRecording -stopRecording (RecordingInProgress x y ls@((z,_):_)) end = Just $ CompleteRecording x end y z ls -stopRecording _ _ = Nothing - - data LoopState = LoopState { _wantExit :: Bool, keysDown :: MidiPitchSet, @@ -176,7 +152,7 @@ playNoteEv :: Event.Data -> RWST LoopEnv () LoopState IO () playNoteEv nevdata = do ms <- getMidiSender publicAddr <- asks _publicAddr - liftIO $ ms $ Event.simple publicAddr nevdata `delayEvent` (10 * 10^(9::Int)) + liftIO $ ms $ Event.simple publicAddr nevdata `delayEvent` (2 * 10^(9::Int)) _whenFlag :: forall (m :: * -> *) s. MonadState s m => (s -> Bool) -> m () -> m () _whenFlag flag f = gets flag >>= flip when f @@ -188,6 +164,12 @@ processCommand "C" = do let mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128) let notes = (Event.NoteEv Event.NoteOn . mkNote) <$> [60, 64, 67] modify $ \s -> s { _playNOW = notes } +processCommand "C'" = do + -- changing the duration seems to do nothing + let mkNote pitch = Event.simpleNote (Event.Channel 0) (Event.Pitch pitch) (Event.Velocity 128) + setDuration d note = note { Event.noteDuration = Event.Duration d } + let notes = (Event.NoteEv Event.NoteOn . setDuration 4290000000 . mkNote) <$> [60, 64, 67] + modify $ \s -> s { _playNOW = notes } processCommand str = liftIO $ putStrLn $ "Unknown command: " ++ str getMidiSender :: RWST LoopEnv () LoopState IO MidiHook @@ -239,21 +221,6 @@ startLineReader = do _thread <- liftIO $ forkIO (forever $ tryIOError getLine >>= either (const $ putMVar mv "exit") (putMVar mv)) return mv -midiToBytes :: [RecordedEvent] -> BS.ByteString -midiToBytes = pack . show -bytesToMidi :: BS.ByteString -> [RecordedEvent] -bytesToMidi = undefined - -instance FromRow CompleteRecording where - fromRow = cons <$> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field <*> field - where - cons a a' b b' c c' d d' z = CompleteRecording (TimeSpec a a') (TimeSpec b b') (TimeSpec c c') (TimeSpec d d') (bytesToMidi z) - -instance ToRow CompleteRecording where - toRow reco = toRow (s, ns, s', ns', s'', ns'', s''', ns''', midiToBytes midi) - where - (CompleteRecording (TimeSpec s ns) (TimeSpec s' ns') (TimeSpec s'' ns'') (TimeSpec s''' ns''') midi) = reco - saveMidi :: forall (m :: * -> *). (MonadIO m, MonadState LoopState m, MonadReader LoopEnv m) => Recording -> m () saveMidi recording = do saver <- asks _saver diff --git a/stack.yaml b/stack.yaml index abcd766..0fa3f39 100644 --- a/stack.yaml +++ b/stack.yaml @@ -21,5 +21,7 @@ extra-deps: - monoid-transformer-0.0.3 - storable-record-0.0.3 +- midi-alsa-0.2.1 + resolver: lts-3.7 system-ghc: false -- cgit v1.2.3