streamed-0.1: src/Sound/MIDI/ALSA/Common.hs
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Sound.MIDI.ALSA.Common where
import qualified Sound.ALSA.Sequencer as SndSeq
import qualified Sound.ALSA.Sequencer.Address as Addr
import qualified Sound.ALSA.Sequencer.Client as Client
import qualified Sound.ALSA.Sequencer.Port as Port
import qualified Sound.ALSA.Sequencer.Port.Info as PortInfo
import qualified Sound.ALSA.Sequencer.Queue as Queue
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.ALSA.Sequencer.RealTime as RealTime
import qualified Sound.MIDI.ALSA as MALSA
import qualified Sound.MIDI.Message.Channel as ChannelMsg
import qualified Sound.MIDI.Message.Channel.Voice as VoiceMsg
import Sound.MIDI.ALSA (normalNoteFromEvent, )
import Sound.MIDI.Message.Channel (Channel, )
import Sound.MIDI.Message.Channel.Voice (Velocity, Pitch, Controller, Program, )
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Data.EventList.Relative.MixedBody as EventListMB
import Data.EventList.Relative.MixedBody ((/.), (./), )
import Data.Accessor.Basic ((^.), (^=), )
import qualified Data.List.HT as ListHT
import Data.Maybe.HT (toMaybe, )
import Data.Tuple.HT (mapFst, mapSnd, )
import qualified Data.List as List
import qualified System.Random as Rnd
import qualified Data.Map as Map
import qualified Control.Monad.Trans.State as State
import qualified Control.Monad.Trans.Reader as Reader
import Control.Monad.Trans.Reader (ReaderT, )
import Control.Monad (guard, )
import qualified Numeric.NonNegative.Class as NonNeg
import qualified Data.Monoid as Mn
import Data.Ratio ((%), )
import Data.Word (Word8, )
import Data.Int (Int32, )
import Prelude hiding (init, filter, )
-- * helper functions
data Handle =
Handle {
sequ :: SndSeq.T SndSeq.DuplexMode,
client :: Client.T,
portIn, portOut :: Port.T,
queue :: Queue.T
}
init :: IO Handle
init = do
h <- SndSeq.open SndSeq.defaultName SndSeq.Block
Client.setName h "Haskell-Filter"
c <- Client.getId h
pout <-
Port.createSimple h "sender"
(Port.caps [Port.capRead, Port.capSubsRead])
Port.typeMidiGeneric
pin <-
Port.createSimple h "receiver"
(Port.caps [Port.capWrite, Port.capSubsWrite])
Port.typeMidiGeneric
q <- Queue.alloc h
let hnd = Handle h c pin pout q
Reader.runReaderT setTimeStamping hnd
return hnd
exit :: Handle -> IO ()
exit h = do
Event.outputPending (sequ h)
Queue.free (sequ h) (queue h)
Port.delete (sequ h) (portIn h)
Port.delete (sequ h) (portOut h)
SndSeq.close (sequ h)
with :: ReaderT Handle IO a -> IO a
with f =
SndSeq.with SndSeq.defaultName SndSeq.Block $ \h -> do
Client.setName h "Haskell-Filter"
c <- Client.getId h
Port.withSimple h "sender"
(Port.caps [Port.capRead, Port.capSubsRead])
Port.typeMidiGeneric $ \pout -> do
Port.withSimple h "receiver"
(Port.caps [Port.capWrite, Port.capSubsWrite])
Port.typeMidiGeneric $ \pin -> do
Queue.with h $ \q ->
flip Reader.runReaderT (Handle h c pin pout q) $
setTimeStamping >> f
-- | make ALSA set the time stamps in incoming events
setTimeStamping :: ReaderT Handle IO ()
setTimeStamping = Reader.ReaderT $ \h -> do
info <- PortInfo.get (sequ h) (portIn h)
PortInfo.setTimestamping info True
PortInfo.setTimestampReal info True
PortInfo.setTimestampQueue info (queue h)
PortInfo.set (sequ h) (portIn h) info
startQueue :: ReaderT Handle IO ()
startQueue = Reader.ReaderT $ \h -> do
Queue.control (sequ h) (queue h) Event.QueueStart 0 Nothing
Event.drainOutput (sequ h)
return ()
connect :: String -> String -> ReaderT Handle IO ()
connect fromName toName = Reader.ReaderT $ \h -> do
from <- Addr.parse (sequ h) fromName
to <- Addr.parse (sequ h) toName
SndSeq.connectFrom (sequ h) (portIn h) from
SndSeq.connectTo (sequ h) (portOut h) to
connectTimidity :: ReaderT Handle IO ()
connectTimidity =
connect "E-MU Xboard61" "TiMidity"
connectLLVM :: ReaderT Handle IO ()
connectLLVM =
connect "E-MU Xboard61" "Haskell-Synthesizer"
-- * helper
channel :: Int -> Channel
channel = ChannelMsg.toChannel
pitch :: Int -> Pitch
pitch = VoiceMsg.toPitch
velocity :: Int -> Velocity
velocity = VoiceMsg.toVelocity
controller :: Int -> Controller
controller = VoiceMsg.toController
program :: Int -> Program
program = VoiceMsg.toProgram
-- * time
{- |
The 'Time' types are used instead of floating point types,
because the latter ones caused unpredictable 'negative number' errors.
The denominator must always be a power of 10,
this way we can prevent unlimited grow of denominators.
-}
type TimeAbs = Rational
newtype Time = Time {deconsTime :: Rational}
deriving (Show, Eq, Ord, Num, Fractional)
consTime :: String -> Rational -> Time
consTime msg x =
if x>=0
then Time x
else error $ msg ++ ": negative number"
incTime :: Time -> TimeAbs -> TimeAbs
incTime dt t = t + deconsTime dt
nano :: Num a => a
nano = 1000^(3::Int)
instance Mn.Monoid Time where
mempty = Time 0
mappend (Time x) (Time y) = Time (x+y)
instance NonNeg.C Time where
split = NonNeg.splitDefault deconsTime Time
-- * events
makeEvent :: Handle -> TimeAbs -> Event.Data -> Event.T
makeEvent h t e =
Event.Cons
{ Event.highPriority = False
, Event.tag = 0
, Event.queue = queue h
, Event.timestamp =
Event.RealTime (RealTime.fromInteger (round (t*nano)))
, Event.source = Addr.Cons (client h) (portOut h)
, Event.dest = Addr.subscribers
, Event.body = e
}
makeEcho :: Handle -> TimeAbs -> Event.Custom -> Event.T
makeEcho h t c =
Event.Cons
{ Event.highPriority = False
, Event.tag = 0
, Event.queue = queue h
, Event.timestamp =
Event.RealTime (RealTime.fromInteger (round (t*nano)))
, Event.source = Addr.Cons (client h) (portOut h)
, Event.dest = Addr.Cons (client h) (portIn h)
, Event.body = Event.CustomEv Event.Echo c
}
{- |
The times are relative to the start time of the bundle
and do not need to be ordered.
-}
type Bundle a = [(Time, a)]
type EventDataBundle = Bundle Event.Data
singletonBundle :: a -> Bundle a
singletonBundle ev = [(0,ev)]
timeFromStamp :: Event.TimeStamp -> Time
timeFromStamp t =
case t of
Event.RealTime rt ->
consTime "time conversion" $
RealTime.toInteger rt % nano
-- _ -> 0,
_ -> error "unsupported time stamp type"
defaultTempoCtrl :: (Channel,Controller)
defaultTempoCtrl =
(ChannelMsg.toChannel 0, VoiceMsg.toController 70)
-- * effects
{- |
Transpose a note event by the given number of semitones.
Non-note events are returned without modification.
If by transposition a note leaves the range of representable MIDI notes,
then we return Nothing.
-}
transpose ::
Int -> Event.Data -> Maybe Event.Data
transpose d e =
case e of
Event.NoteEv notePart note ->
fmap (\p ->
Event.NoteEv notePart $
(MALSA.notePitch ^= p) note) $
increasePitch d $
note ^. MALSA.notePitch
_ -> Just e
setChannel ::
Channel -> Event.Data -> Event.Data
setChannel chan e =
case e of
Event.NoteEv notePart note ->
Event.NoteEv notePart $
(MALSA.noteChannel ^= chan) note
Event.CtrlEv Event.Controller ctrl ->
Event.CtrlEv Event.Controller $
(MALSA.ctrlChannel ^= chan) ctrl
_ -> e
{- |
> > replaceProgram [1,2,3,4] 5 [10,11,12,13]
> (True,[10,11,2,13])
-}
replaceProgram :: [Int32] -> Int32 -> [Int32] -> (Bool, [Int32])
replaceProgram (n:ns) pgm pt =
let (p,ps) =
case pt of
[] -> (0,[])
(x:xs) -> (x,xs)
in if pgm<n
then (True, pgm:ps)
else mapSnd (p:) $
replaceProgram ns (pgm-n) ps
replaceProgram [] _ ps = (False, ps)
programFromBanks :: [Int32] -> [Int32] -> Int32
programFromBanks ns ps =
foldr (\(n,p) s -> p+n*s) 0 $
zip ns ps
{- |
Interpret program changes as a kind of bank switches
in order to increase the range of instruments
that can be selected via a block of patch select buttons.
@programAsBanks ns@ divides the first @sum ns@ instruments
into sections of sizes @ns!!0, ns!!1, ...@.
Each program in those sections is interpreted as a bank in a hierarchy,
where the lower program numbers are the least significant banks.
Programs from @sum ns@ on are passed through as they are.
@product ns@ is the number of instruments
that you can address using this trick.
In order to avoid overflow it should be less than 128.
E.g. @programAsBanks [n,m]@ interprets subsequent program changes to
@a@ (@0<=a<n@) and @n+b@ (@0<=b<m@)
as a program change to @b*n+a@.
@programAsBanks [8,8]@ allows to select 64 instruments
by 16 program change buttons,
whereas @programAsBanks [8,4,4]@
allows to address the full range of MIDI 128 instruments
with the same number of buttons.
-}
programsAsBanks ::
[Int32] ->
Event.Data -> State.State [Int32] Event.Data
programsAsBanks ns e =
case e of
Event.CtrlEv Event.PgmChange ctrl -> State.state $ \ps0 ->
let pgm = Event.ctrlValue ctrl
(valid, ps1) = replaceProgram ns pgm ps0
in (Event.CtrlEv Event.PgmChange $
ctrl{Event.ctrlValue =
if valid
then programFromBanks ns ps1
else pgm},
ps1)
_ -> return e
nextProgram :: Event.Note -> State.State [Program] EventDataBundle
nextProgram note =
State.state $ \pgms ->
case pgms of
pgm:rest ->
(singletonBundle $
Event.CtrlEv Event.PgmChange $
Event.Ctrl {
Event.ctrlChannel = Event.noteChannel note,
Event.ctrlParam = 0,
Event.ctrlValue = MALSA.fromProgram pgm},
rest)
[] -> ([],[])
{- |
Before every note switch to another instrument
according to a list of programs given as state of the State monad.
I do not know how to handle multiple channels in a reasonable way.
Currently I just switch the instrument independent from the channel,
and send the program switch to the same channel as the beginning note.
-}
traversePrograms ::
Event.Data -> State.State [Program] EventDataBundle
traversePrograms e =
fmap (++ singletonBundle e) $
case e of
Event.NoteEv notePart note ->
(case fst $ normalNoteFromEvent notePart note of
Event.NoteOn -> nextProgram note
_ -> return [])
_ -> return []
{- |
This function extends 'traversePrograms'.
It reacts on external program changes
by seeking an according program in the list.
This way we can reset the pointer into the instrument list.
However the search must be limited in order to prevent an infinite loop
if we receive a program that is not contained in the list.
-}
traverseProgramsSeek ::
Int ->
Event.Data -> State.State [Program] EventDataBundle
traverseProgramsSeek maxSeek e =
fmap (++ singletonBundle e) $
case e of
Event.NoteEv notePart note ->
case fst $ normalNoteFromEvent notePart note of
Event.NoteOn -> nextProgram note
_ -> return []
Event.CtrlEv Event.PgmChange ctrl ->
let pgm = ctrl ^. MALSA.ctrlProgram
in fmap (const []) $
State.modify $
uncurry (++) .
mapFst (dropWhile (pgm/=)) .
splitAt maxSeek
_ -> return []
reduceNoteVelocity ::
Word8 -> Event.Note -> Event.Note
reduceNoteVelocity decay note =
note{Event.noteVelocity =
let vel = Event.noteVelocity note
in if vel==0
then 0
else vel - min decay (vel-1)}
delayAdd ::
Word8 -> Time -> Event.Data -> EventDataBundle
delayAdd decay d e =
singletonBundle e ++
case e of
Event.NoteEv notePart note ->
[(d, Event.NoteEv notePart $
reduceNoteVelocity decay note)]
_ -> []
simpleNote :: Channel -> Pitch -> Velocity -> Event.Note
simpleNote c p v =
Event.simpleNote
(MALSA.fromChannel c)
(MALSA.fromPitch p)
(MALSA.fromVelocity v)
type KeySet = Map.Map (Pitch, Channel) Velocity
type KeyQueue = [((Pitch, Channel), Velocity)]
eventsFromKey ::
Time -> ((Pitch, Channel), Velocity) ->
EventDataBundle
eventsFromKey dur ((pit,chan), vel) =
(0, Event.NoteEv Event.NoteOn $ simpleNote chan pit vel) :
(dur, Event.NoteEv Event.NoteOff $ simpleNote chan pit vel) :
[]
selectFromLimittedChord ::
Int ->
Time ->
KeyQueue ->
EventDataBundle
selectFromLimittedChord n dur =
maybe [] (eventsFromKey dur) .
(!!n) . (++ repeat Nothing) . map Just
{- |
Generate notes according to the key set,
where notes for negative and too large indices
are padded with keys that are transposed by octaves.
-}
selectFromOctaveChord ::
Int ->
Time ->
KeyQueue ->
EventDataBundle
selectFromOctaveChord d dur chord =
maybe [] (eventsFromKey dur) $ do
guard (not $ null chord)
let (q,r) = divMod d (fromIntegral $ length chord)
((pit,chan), vel) = chord !! r
transPitch <- increasePitch (12*q) pit
return ((transPitch,chan), vel)
selectFromChord ::
Integer ->
Time ->
KeyQueue ->
EventDataBundle
selectFromChord d dur chord =
if null chord
then []
else
eventsFromKey dur $
chord !! fromInteger d
selectFromChordRatio ::
Double ->
Time ->
KeyQueue ->
EventDataBundle
selectFromChordRatio d dur chord =
if null chord
then []
else
eventsFromKey dur $
chord !! floor (d * fromIntegral (length chord))
increasePitch :: Int -> Pitch -> Maybe Pitch
increasePitch d p =
let pInt = d + VoiceMsg.fromPitch p
in toMaybe
(VoiceMsg.fromPitch minBound <= pInt &&
pInt <= VoiceMsg.fromPitch maxBound)
(VoiceMsg.toPitch pInt)
selectInversion ::
Double ->
Time ->
KeyQueue ->
EventDataBundle
selectInversion d dur chord =
let -- properFraction is useless for negative numbers
splitFraction x =
let n = floor x :: Int
in (n, x - fromIntegral n)
makeNote octave ((pit,chan), vel) =
maybe []
(\pitchTrans -> eventsFromKey dur ((pitchTrans,chan), vel))
(increasePitch (octave*12) pit)
(oct,p) = splitFraction d
pivot = floor (p * fromIntegral (length chord))
(low,high) = splitAt pivot chord
in concatMap (makeNote oct) high ++
concatMap (makeNote (oct+1)) low
updateChord ::
Event.NoteEv -> Event.Note ->
KeySet -> KeySet
updateChord notePart note =
let key =
(note ^. MALSA.notePitch,
note ^. MALSA.noteChannel)
(part, vel) =
normalNoteFromEvent notePart note
in case part of
Event.NoteOn -> Map.insert key vel
Event.NoteOff -> Map.delete key
_ -> id
controllerMatch ::
Channel -> Controller -> Event.Ctrl -> Bool
controllerMatch chan ctrl param =
Event.ctrlChannel param == MALSA.fromChannel chan &&
Event.ctrlParam param == MALSA.fromController ctrl
updateDur ::
Event.Ctrl -> (Time, Time) -> Time
updateDur param (minDur, maxDur) =
minDur + (maxDur-minDur)
* fromIntegral (Event.ctrlValue param) / 127
type Selector i = i -> Time -> KeyQueue -> EventDataBundle
type Pattern i = (Selector i, [i])
data IndexNote i = IndexNote Int i
deriving (Show, Eq, Ord)
item :: i -> Int -> IndexNote i
item i n = IndexNote n i
type PatternMulti i = (Selector i, EventList.T Int [IndexNote i])
fraction :: RealFrac a => a -> a
fraction x =
let n = floor x
in x - fromIntegral (n::Integer)
data SweepState =
SweepState {
sweepSpeed, sweepDepth, sweepCenter, sweepPhase :: Double
}
{-
ctrlRange ::
(RealFrac b) =>
(b,b) -> (a -> b) -> (a -> Int)
ctrlRange (l,u) f x =
round $
limit (0,127) $
127*(f x - l)/(u-l)
-}
-- * patterns
{-
flipSeq m !! n = cross sum of the m-ary representation of n modulo m.
For m=2 this yields
http://www.research.att.com/cgi-bin/access.cgi/as/njas/sequences/eisA.cgi?Anum=A010060
-}
flipSeq :: Int -> [Int]
flipSeq n =
let incList m = map (\x -> mod (x+m) n)
recourse y = let z = concatMap (flip incList y) [1..(n-1)]
in z ++ recourse (y++z)
in [0] ++ recourse [0]
cycleUp, cycleDown, pingPong, crossSum ::
Int -> Pattern Int
cycleUp number =
(selectFromLimittedChord, cycle [0..(number-1)])
cycleDown number =
(selectFromLimittedChord, cycle $ reverse [0..(number-1)])
pingPong number =
(selectFromLimittedChord,
cycle $ [0..(number-2)] ++ reverse [1..(number-1)])
crossSum number =
(selectFromLimittedChord, flipSeq number)
cycleUpAuto, cycleDownAuto, pingPongAuto, crossSumAuto ::
Pattern Integer
cycleUpAuto =
(\ d dur chord ->
selectFromChord (mod d (fromIntegral $ length chord)) dur chord,
[0..])
cycleDownAuto =
(\ d dur chord ->
selectFromChord (mod d (fromIntegral $ length chord)) dur chord,
[0,(-1)..])
pingPongAuto =
(\ d dur chord ->
let s = 2 * (fromIntegral (length chord) - 1)
m =
if s<=0
then 0
else min (mod d s) (mod (-d) s)
in selectFromChord m dur chord,
[0..])
crossSumAuto =
(\ d dur chord ->
let m = fromIntegral $ length chord
s =
if m <= 1
then 0
else sum $ decomposePositional m d
in selectFromChord (mod s m) dur chord,
[0..])
binaryStaccato, binaryLegato, binaryAccident :: PatternMulti Int
{-
binary number pattern:
0
1
0 1
2
0 2
1 2
0 1 2
3
-}
binaryStaccato =
(selectFromLimittedChord,
EventList.fromPairList $
zip (0 : repeat 1) $
map
(map (IndexNote 1 . fst) .
List.filter ((/=0) . snd) .
zip [0..] .
decomposePositional 2)
[0..])
binaryLegato =
(selectFromLimittedChord,
EventList.fromPairList $
zip (0 : repeat 1) $
map
(\m ->
map (uncurry IndexNote) $
List.filter (\(p,_i) -> mod m p == 0) $
takeWhile ((<=m) . fst) $
zip (iterate (2*) 1) [0..])
[0..])
{-
This was my first try to implement binaryLegato.
It was not what I wanted, but it sounded nice.
-}
binaryAccident =
(selectFromLimittedChord,
EventList.fromPairList $
zip (0 : repeat 1) $
map
(zipWith IndexNote (iterate (2*) 1) .
map fst .
List.filter ((/=0) . snd) .
zip [0..] .
decomposePositional 2)
[0..])
-- cf. htam:NumberTheory
decomposePositional :: Integer -> Integer -> [Integer]
decomposePositional b =
let recourse 0 = []
recourse x =
let (q,r) = divMod x b
in r : recourse q
in recourse
cycleUpOctave ::
Int -> Pattern Int
cycleUpOctave number =
(selectFromOctaveChord, cycle [0..(number-1)])
random, randomInversions :: Pattern Double
random =
(selectFromChordRatio, Rnd.randomRs (0,1) (Rnd.mkStdGen 42))
randomInversions =
inversions $
map sum $
ListHT.sliceVertical 3 $
Rnd.randomRs (-0.5,0.5) $
Rnd.mkStdGen 42
cycleUpInversions :: Int -> Pattern Double
cycleUpInversions n =
inversions $ cycle $ take n $
map (\i -> fromInteger i / fromIntegral n) [0..]
inversions :: [Double] -> Pattern Double
inversions rs =
(selectInversion, rs)
{-
We cannot use cycle function here, because we need to cycle a Body-Time list
which is incompatible to a Body-Body list,
even if the end is never reached.
-}
examplePatternMultiTempo0 ::
EventList.T Int [IndexNote Int]
examplePatternMultiTempo0 =
let pat =
[item 0 1] ./ 1 /. [item 1 1, item 2 1] ./ 2 /.
[item 1 1, item 2 1] ./ 1 /. [item 0 1] ./ 2 /.
pat
in 0 /. pat
examplePatternMultiTempo1 ::
EventList.T Int [IndexNote Int]
examplePatternMultiTempo1 =
let pat =
[item 0 1] ./ 1 /.
[item 2 1, item 3 1, item 4 1] ./ 1 /.
[item 2 1, item 3 1, item 4 1] ./ 1 /.
[item 1 1] ./ 1 /.
[item 2 1, item 3 1, item 4 1] ./ 1 /.
[item 2 1, item 3 1, item 4 1] ./ 1 /.
pat
in 0 /. pat
-- * predicates
checkChannel ::
(Channel -> Bool) ->
(Event.Data -> Bool)
checkChannel p e =
case e of
Event.NoteEv _notePart note ->
p (note ^. MALSA.noteChannel)
Event.CtrlEv Event.Controller ctrl ->
p (ctrl ^. MALSA.ctrlChannel)
_ -> False
checkPitch ::
(Pitch -> Bool) ->
(Event.Data -> Bool)
checkPitch p e =
case e of
Event.NoteEv _notePart note ->
p (note ^. MALSA.notePitch)
_ -> False
checkController ::
(Controller -> Bool) ->
(Event.Data -> Bool)
checkController p e =
case e of
Event.CtrlEv Event.Controller ctrl ->
p (ctrl ^. MALSA.ctrlController)
_ -> False
checkProgram ::
(Program -> Bool) ->
(Event.Data -> Bool)
checkProgram p e =
case e of
Event.CtrlEv Event.PgmChange ctrl ->
p (ctrl ^. MALSA.ctrlProgram)
_ -> False