module Synthesizer.Storable.ALSA.MIDI where
import qualified Sound.Alsa as ALSASig
import qualified Sound.Alsa.Sequencer as ALSA
import qualified Sound.Sox.Play as Play
import qualified Sound.Sox.Option.Format as SoxOpt
import qualified Synthesizer.Basic.Binary as BinSmp
import qualified Synthesizer.Storable.Cut as CutSt
import qualified Synthesizer.Storable.Signal as SigSt
import qualified Data.StorableVector.Lazy.Pattern as SigStV
import qualified Data.StorableVector.Lazy as SVL
import qualified Data.StorableVector.Base as SV
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Data.EventList.Relative.TimeTime as EventListTT
import qualified Data.EventList.Relative.MixedBody as EventListMB
import qualified Data.EventList.Relative.TimeMixed as EventListTM
import qualified Data.EventList.Relative.MixedTime as EventListMT
import qualified Data.EventList.Relative.BodyTime as EventListBT
import qualified Data.EventList.Absolute.TimeBody as AbsEventList
import qualified Foreign
import Foreign.Storable (Storable)
import System.IO.Unsafe (unsafeInterleaveIO, )
import Control.Concurrent (threadDelay)
import System.Time (ClockTime(TOD), getClockTime, )
import Control.Exception (bracket, )
import Control.Monad.Trans.State (State, state, )
import qualified Numeric.NonNegative.Wrapper as NonNegW
import qualified Numeric.NonNegative.ChunkyPrivate as NonNegChunky
import qualified Algebra.RealField as RealField
import Data.Tuple.HT (mapPair, mapSnd, )
import Data.Maybe.HT (toMaybe, )
import Control.Monad (liftM, liftM2, guard, )
import NumericPrelude (round, )
import Prelude hiding (round, break, )
getTimeSeconds :: Fractional time => IO time
getTimeSeconds =
fmap clockTimeToSeconds getClockTime
clockTimeToSeconds :: Fractional time => ClockTime -> time
clockTimeToSeconds (TOD secs picos) =
fromInteger secs + fromInteger picos * 1e-12
type ALSAEvent = (Double, ALSA.Event)
getStampedEvent :: ALSA.SndSeq -> IO ALSAEvent
getStampedEvent h =
liftM2 (,)
getTimeSeconds
(ALSA.event_input h)
getWaitingEvents :: ALSA.SndSeq -> IO [ALSAEvent]
getWaitingEvents h =
let loop =
ALSA.alsa_catch
(liftM2 (:) (getStampedEvent h) loop)
(const $ return [])
in loop
type StrictTime = NonNegW.Integer
withMIDIEventsNonblock ::
Double -> (EventList.T StrictTime (Maybe ALSA.Event) -> IO a) -> IO a
withMIDIEventsNonblock rate proc =
withInPort ALSA.Nonblock $ \ h _p ->
do l <- ioToLazyList $ threadDelay 10000 >>
liftM2 (:)
(liftM (\t->(t,Nothing)) getTimeSeconds)
(liftM (map (mapSnd Just)) (getWaitingEvents h))
proc $
discretizeTime rate $
AbsEventList.fromPairList $ concat l
withMIDIEventsNonblockSimple ::
Double -> (EventList.T StrictTime ALSA.Event -> IO a) -> IO a
withMIDIEventsNonblockSimple rate proc =
withInPort ALSA.Nonblock $ \ h _p ->
do l <- ioToLazyList $ threadDelay 10000 >> getWaitingEvents h
proc $
discretizeTime rate $
AbsEventList.fromPairList $ concat l
withMIDIEventsBlock ::
Double -> (EventList.T StrictTime ALSA.Event -> IO a) -> IO a
withMIDIEventsBlock rate proc =
withInPort ALSA.Block $ \ h _p ->
do l <- ioToLazyList $ getStampedEvent h
proc $
discretizeTime rate $
AbsEventList.fromPairList l
withInPort ::
ALSA.BlockMode -> (ALSA.SndSeq -> ALSA.Port -> IO t) -> IO t
withInPort blockMode act =
bracket
(ALSA.open ALSA.default_seq_name ALSA.open_input blockMode)
(ALSA.close) $
\h ->
ALSA.set_client_name h "Haskell-Synthesizer" >>
(bracket
(ALSA.create_simple_port h "listener"
(ALSA.caps [ALSA.cap_write, ALSA.cap_subs_write])
ALSA.type_midi_generic)
(ALSA.delete_port h) $
\p ->
act h p)
discretizeTime :: Double -> AbsEventList.T Double a -> EventList.T StrictTime a
discretizeTime sampleRate =
EventListMB.mapTimeHead (const 0) .
EventList.fromAbsoluteEventList .
AbsEventList.mapTime
(NonNegW.fromNumberMsg "time conversion" . round . (sampleRate*))
type LazyTime = NonNegChunky.T NonNegW.Integer
getSlice ::
(ALSA.Event -> Maybe a) ->
State (EventList.T StrictTime (Maybe ALSA.Event)) (EventListTT.T LazyTime a)
getSlice f =
fmap
(EventListTT.catMaybesR .
flip EventListTM.snocTime 0 .
EventList.mapTime NonNegChunky.fromNumber) $
state (partitionMaybeBeat f)
partitionMaybe ::
(a -> Maybe b) -> EventList.T StrictTime a ->
(EventList.T StrictTime b, EventList.T StrictTime a)
partitionMaybe f =
mapPair (EventList.catMaybes, EventList.catMaybes) .
EventList.foldrPair (\t a ->
let (x,y) =
case f a of
Just b -> (Just b, Nothing)
Nothing -> (Nothing, Just a)
in mapPair (EventList.cons t x, EventList.cons t y))
(EventList.empty, EventList.empty)
partitionMaybeBeat ::
(a -> Maybe b) -> EventList.T StrictTime (Maybe a) ->
(EventList.T StrictTime (Maybe b), EventList.T StrictTime (Maybe a))
partitionMaybeBeat f =
mapPair (EventList.catMaybes, EventList.catMaybes) .
EventList.foldrPair (\t a0 ->
let (x,y) =
case a0 of
Nothing -> (Just Nothing, Just Nothing)
Just a1 ->
case f a1 of
Just b -> (Just $ Just b, Nothing)
Nothing -> (Nothing, Just $ Just a1)
in mapPair (EventList.cons t x, EventList.cons t y))
(EventList.empty, EventList.empty)
maybeController :: Int -> Int -> ALSA.Event -> Maybe (Int, Int)
maybeController chan ctrl e =
let ALSA.TickTime n = ALSA.ev_timestamp e
in case ALSA.ev_data e of
ALSA.CtrlEv ALSA.Controller c ->
toMaybe (fromIntegral (ALSA.ctrl_channel c) == chan &&
fromIntegral (ALSA.ctrl_param c) == ctrl)
(fromIntegral n, fromIntegral $ ALSA.ctrl_value c)
_ -> Nothing
getControllerEvents ::
Int -> Int ->
State (EventList.T StrictTime (Maybe ALSA.Event)) (EventListTT.T LazyTime Int)
getControllerEvents chan ctrl =
getSlice (fmap snd . maybeController chan ctrl)
controllerValuesToSignal ::
Double -> EventListTT.T LazyTime Double -> SigSt.T Double
controllerValuesToSignal initial =
EventListBT.foldrPair
(\y t -> SigSt.append (SigStV.replicate (chunkSizesFromLazyTime t) y)) SigSt.empty .
EventListMT.consBody initial
chunkSizesFromLazyTime :: LazyTime -> NonNegChunky.T SigSt.ChunkSize
chunkSizesFromLazyTime =
NonNegChunky.fromChunks .
map (SVL.ChunkSize . fromInteger . NonNegW.toNumber) .
NonNegChunky.toChunks .
NonNegChunky.normalize
controllerValueToSample ::
(Double,Double) -> Int -> Double
controllerValueToSample (lower,upper) n =
let k = fromIntegral n / 127
in (1k) * lower + k * upper
getControllerSignal ::
Int -> Int ->
(Double,Double) -> Double ->
State (EventList.T StrictTime (Maybe ALSA.Event)) (SigSt.T Double)
getControllerSignal chan ctrl bnd initial =
liftM (controllerValuesToSignal initial .
EventListTT.mapBody (controllerValueToSample bnd)) $
getControllerEvents chan ctrl
controllerValueToSampleExp ::
(Double,Double) -> Int -> Double
controllerValueToSampleExp (lower,upper) n =
let k = fromIntegral n / 127
in lower**(1k) * upper**k
getControllerSignalExp ::
Int -> Int ->
(Double,Double) -> Double ->
State (EventList.T StrictTime (Maybe ALSA.Event)) (SigSt.T Double)
getControllerSignalExp chan ctrl bnd initial =
liftM (controllerValuesToSignal initial .
EventListTT.mapBody (controllerValueToSampleExp bnd)) $
getControllerEvents chan ctrl
maybePitchBend :: Int -> ALSA.Event -> Maybe Int
maybePitchBend chan e =
case ALSA.ev_data e of
ALSA.CtrlEv ALSA.PitchBend c ->
toMaybe (fromIntegral (ALSA.ctrl_channel c) == chan)
(fromIntegral $ ALSA.ctrl_value c)
_ -> Nothing
pitchBendValueToSample ::
Double -> Double -> Int -> Double
pitchBendValueToSample range center n =
center * range ** (fromIntegral n / 8192)
getPitchBendSignal ::
Int ->
Double -> Double ->
State (EventList.T StrictTime (Maybe ALSA.Event)) (SigSt.T Double)
getPitchBendSignal chan range center =
liftM (controllerValuesToSignal center .
EventListTT.mapBody (pitchBendValueToSample range center)) $
getSlice (maybePitchBend chan)
getNoteEvents ::
Int ->
State
(EventList.T StrictTime (Maybe ALSA.Event))
(EventListTT.T LazyTime (Int,Int,Bool))
getNoteEvents chan =
getSlice $ \e ->
case ALSA.ev_data e of
ALSA.NoteEv notePart note ->
do guard (fromIntegral (ALSA.note_channel note) == chan)
(vel,press) <-
case notePart of
ALSA.NoteOn ->
return $
let v = ALSA.note_velocity note
in if v==0
then (64, False)
else (fromIntegral v, True)
ALSA.NoteOff ->
return
(fromIntegral $ ALSA.note_velocity note, False)
_ -> Nothing
return (fromIntegral $ ALSA.note_note note, vel, press)
_ -> Nothing
matchNoteEventsAlt ::
EventListTT.T LazyTime (Int,Int,Bool) ->
EventListTT.T LazyTime (Int,Int,LazyTime)
matchNoteEventsAlt =
EventListTT.catMaybesR .
matchNoteEventsMaybe .
EventListTT.mapBody Just
matchNoteEventsMaybe ::
EventListTT.T LazyTime (Maybe (Int,Int,Bool)) ->
EventListTT.T LazyTime (Maybe (Int,Int,LazyTime))
matchNoteEventsMaybe =
EventListMT.mapTimeTail $ \r0 ->
flip (EventListMT.switchBodyL EventListBT.empty) r0 $
\ev r1 ->
case ev of
Nothing ->
EventListMT.consBody Nothing $ matchNoteEventsMaybe r1
Just (pitchOn,velOn,pressOn) ->
let (dur,r2) =
if not pressOn
then (0, r1)
else
let (prefix,_noteOff,suffix) =
break (maybe False
(\(pitchOff,_velOff,pressOff) ->
pitchOn == pitchOff && not pressOff)) r1
in (lazyDuration prefix,
EventListTM.prependBodyEnd
(EventListTM.snocBody prefix Nothing) suffix)
in EventListMT.consBody (Just (pitchOn,velOn,dur)) $ matchNoteEventsMaybe r2
matchNoteEvents ::
EventListTT.T LazyTime (Int,Int,Bool) ->
EventListTT.T LazyTime (Int,Int,LazyTime)
matchNoteEvents =
EventListMT.mapTimeTail $ \r0 ->
flip (EventListMT.switchBodyL EventListBT.empty) r0 $
\(pitchOn,velOn,pressOn) r1 ->
let (dur,r2) =
if not pressOn
then (0, r1)
else
let (prefix,_noteOff,suffix) =
break (\(pitchOff,_velOff,pressOff) ->
pitchOn == pitchOff && not pressOff) r1
in (lazyDuration prefix,
appendTTLazy prefix suffix)
in EventListMT.consBody (pitchOn,velOn,dur) $ matchNoteEvents r2
appendTTLazy ::
EventListTT.T LazyTime body ->
EventListTT.T LazyTime body ->
EventListTT.T LazyTime body
appendTTLazy xs ys =
EventListTT.foldr
(\t zs ->
let (d,ws) = either EventListMT.viewTimeL ((,) NonNegChunky.zero) zs
in EventListMT.consTime (t + d) ws)
(\b zs -> Right $ EventListMT.consBody b zs)
(Left ys) xs
lazyDuration :: EventListTT.T LazyTime body -> LazyTime
lazyDuration = foldr (+) 0 . EventListTT.getTimes
break ::
(body -> Bool) -> EventListTT.T LazyTime body ->
(EventListTT.T LazyTime body, body, EventListTT.T LazyTime body)
break p =
EventListMT.switchTimeL $ \t xs ->
let (prefix,suffix) = EventListBT.span (not . p) xs
(b,r) =
EventListMT.switchBodyL
(error "no matching body element found",
error "list ended before matching element found")
(,)
suffix
in (EventListMT.consTime t prefix, b, r)
remove ::
(body -> Bool) -> EventListTT.T LazyTime body ->
(body, EventListTT.T LazyTime body)
remove p =
EventListMT.switchTimeL $ \t xs ->
let (prefix,suffix) = EventListBT.span p xs
(b,r) =
EventListMT.switchBodyL
(error "no matching body element found",
error "list ended before matching element found")
(,)
suffix
in (b, EventListTT.append (EventListMT.consTime t prefix) r)
type Instrument = LazyTime -> Double -> Double -> SigSt.T Double
makeInstrumentSounds ::
Instrument ->
EventListTT.T time (Int,Int,LazyTime) ->
EventListTT.T time (SigSt.T Double)
makeInstrumentSounds instrument =
EventListTT.mapBody
(\(pitch, vel, dur) ->
instrument
dur
(fromIntegral (vel64)/63)
(440 * 2 ** (fromIntegral (pitch + 3 6*12) / 12)))
insertBreaks ::
EventListTT.T LazyTime (SigSt.T Double) ->
EventListTT.T StrictTime (SigSt.T Double)
insertBreaks =
EventListTT.foldr
(\lt r ->
case NonNegChunky.toChunksUnsafe (NonNegChunky.normalize lt) of
[] -> EventListMT.consTime 0 r
(t:ts) ->
EventListMT.consTime t $
foldr (\dt ->
EventListMT.consBody SigSt.empty .
EventListMT.consTime dt) r ts)
EventListMT.consBody
EventListBT.empty
getNoteSignal ::
Int ->
Instrument ->
State
(EventList.T StrictTime (Maybe ALSA.Event))
(SigSt.T Double)
getNoteSignal chan instr =
fmap (CutSt.arrangeEquidist defaultChunkSize .
EventListTM.switchTimeR const .
EventListTT.mapTime fromIntegral .
insertBreaks .
makeInstrumentSounds instr .
matchNoteEvents) $
getNoteEvents chan
ioToLazyList :: IO a -> IO [a]
ioToLazyList m =
unsafeInterleaveIO $
liftM2 (:) m (ioToLazyList m)
dump :: IO ()
dump =
do putStrLn "Starting."
h <- ALSA.open ALSA.default_seq_name ALSA.open_input ALSA.Block
ALSA.set_client_name h "Haskell-Synthesizer"
putStrLn "Created sequencer."
p <- ALSA.create_simple_port h "one"
(ALSA.caps [ALSA.cap_write, ALSA.cap_subs_write]) ALSA.type_midi_generic
let loop = do putStrLn "waiting for an event:"
e <- ALSA.event_input h
print e
loop
loop
ALSA.delete_port h p
putStrLn "Deleted ports."
ALSA.close h
putStrLn "Closed sequencer."
playMonoSox ::
(Storable a, RealField.C a) =>
a -> SigSt.T a -> IO ()
playMonoSox rate =
fmap (const ()) .
Play.simple SigSt.hPut SoxOpt.none (round rate) .
SigSt.map BinSmp.int16FromCanonical
defaultSampleRate :: Num a => a
defaultSampleRate = 48000
bufferSize :: Int
bufferSize = 256
defaultChunkSize :: SigSt.ChunkSize
defaultChunkSize = SigSt.chunkSize bufferSize
latency :: Int
latency = 1000
playMono ::
(Storable a, RealField.C a) =>
a -> SigSt.T a -> IO ()
playMono rate xs =
let sink = ALSASig.alsaSoundSink "plughw:0,0" soundFormat
ys = SigSt.map BinSmp.int16FromCanonical xs
soundFormat :: ALSASig.SoundFmt
soundFormat =
ALSASig.SoundFmt {
ALSASig.sampleFmt = ALSASig.SampleFmtLinear16BitSignedLE,
ALSASig.sampleFreq = round rate,
ALSASig.numChannels = 1
}
in ALSASig.withSoundSink sink $ \to ->
flip mapM_ (SVL.chunks (SigSt.append (SigSt.replicate defaultChunkSize latency 0) ys)) $ \c ->
SV.withStartPtr c $ \ptr size ->
ALSASig.soundSinkWrite sink to (Foreign.castPtr ptr) size