module Sound.MIDI.ALSA.EventList where
import Sound.MIDI.ALSA.Common
(Bundle, EventDataBundle, Time, TimeAbs,
Handle, PatternMono, PatternPoly,
sequ, with, incTime,
singletonBundle, checkController, checkChannel,
checkProgram, checkPitch,
SweepState, sweepSpeed, sweepPhase, sweepDepth, sweepCenter,
updateDur, updateChord, )
import qualified Sound.MIDI.ALSA.Common as Common
import qualified Sound.ALSA.Sequencer.Event as Event
import qualified Sound.ALSA.Exception as Exc
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.Message.Channel (Channel, )
import Sound.MIDI.Message.Channel.Voice (Controller, Program, )
import qualified Data.EventList.Relative.TimeBody as EventList
import qualified Data.EventList.Absolute.TimeBody as EventListAbs
import Data.Accessor.Basic ((^.), )
import qualified Data.List.HT as ListHT
import qualified Data.List.Match as Match
import Data.Tuple.HT (mapFst, mapSnd, mapPair, )
import Data.Ord.HT (limit, )
import qualified Data.List as List
import Data.Maybe (mapMaybe, )
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.IO.Class (liftIO, )
import qualified Control.Applicative as App
import Control.Monad (liftM2, guard, )
import qualified Data.Foldable as Fold
import qualified Data.Traversable as Trav
import qualified Numeric.NonNegative.Class as NonNeg
import Data.Int (Int32, )
import System.IO.Unsafe (unsafeInterleaveIO, )
import Prelude hiding (init, filter, )
ioToLazyList :: IO a -> IO [a]
ioToLazyList m =
let go = unsafeInterleaveIO $ liftM2 (:) m go
in go
inputEventsCore :: ReaderT Handle IO [Event.T]
inputEventsCore =
Reader.ReaderT $ \h ->
ioToLazyList (Event.input (sequ h))
inputEvents :: ReaderT Handle IO (EventList.T Time Event.Data)
inputEvents =
fmap (EventList.fromAbsoluteEventList .
EventListAbs.fromPairList .
map (\ev -> (Common.timeFromStamp (Event.timestamp ev),
Event.body ev))) $
inputEventsCore
pairListFromRelativeEvents :: EventList.T Time a -> [(TimeAbs,a)]
pairListFromRelativeEvents =
EventListAbs.toPairList .
EventListAbs.mapTime Common.deconsTime .
EventList.toAbsoluteEventList 0
outputEvents :: EventList.T Time Event.Data -> ReaderT Handle IO ()
outputEvents =
mapM_ (uncurry Common.outputEvent) .
pairListFromRelativeEvents
outputEventBundles :: EventList.T Time EventDataBundle -> ReaderT Handle IO ()
outputEventBundles =
mapM_
(\(t,evs) ->
flip mapM_ evs (\(dt,ev) ->
Common.outputEvent (incTime dt t) ev)) .
pairListFromRelativeEvents
outputEventBundled :: EventList.T Time EventDataBundle -> ReaderT Handle IO ()
outputEventBundled =
mapM_
(\(t,evs) -> Reader.ReaderT $ \h ->
flip mapM_ evs (\(dt,ev) ->
Event.output (sequ h) (Common.makeEvent h (incTime dt t) ev)) >>
Event.drainOutput (sequ h) >>
return ()) .
pairListFromRelativeEvents
data Trigger a =
Regular a
| Trigger
instance Functor Trigger where
fmap f (Regular a) = Regular (f a)
fmap _ Trigger = Trigger
instance Fold.Foldable Trigger where
foldMap = Trav.foldMapDefault
instance Trav.Traversable Trigger where
sequenceA (Regular a) = fmap Regular a
sequenceA Trigger = App.pure Trigger
type EventDataTrigger = Bundle (Trigger Event.Data)
makeTriggerEvent :: Handle -> TimeAbs -> Trigger Event.Data -> Event.T
makeTriggerEvent h t x =
case x of
Regular ev -> Common.makeEvent h t ev
Trigger -> Common.makeEcho h t (Event.Custom 0 0 0)
makeTriggerEvents :: Handle -> TimeAbs -> EventDataTrigger -> [Event.T]
makeTriggerEvents h t =
map (\(dt,ev) -> makeTriggerEvent h (incTime dt t) ev)
outputTriggerEvents ::
EventList.T Time EventDataTrigger ->
ReaderT Handle IO ()
outputTriggerEvents =
mapM_
(\(t,ee) -> Reader.ReaderT $ \h ->
mapM_
(\e ->
Event.output (sequ h) e >>
Event.drainOutput (sequ h))
(makeTriggerEvents h t ee)
>> return ()) .
pairListFromRelativeEvents
mergeGenerated ::
EventList.T Time (Bundle a) ->
EventList.T Time (Bundle a) ->
EventList.T Time (Bundle (Trigger a))
mergeGenerated gens ins =
merge
(fmap (\t -> [(t, Trigger)]) $ EventList.fromPairList $
ListHT.mapAdjacent (,) (0 : EventList.getTimes gens))
(fmap (map (mapSnd Regular)) $
merge gens ins)
equidistantEvents :: Time -> [a] -> EventList.T Time a
equidistantEvents dur as =
case as of
[] -> EventList.empty
x:xs ->
EventList.cons 0 x $
EventList.fromPairList (map ((,) dur) xs)
whirl :: EventList.T Time EventDataBundle
whirl =
let dur = 0.125
notes =
cycle $ concat $ concatMap (replicate 4) $
[57, 59, 60, 64] :
[57, 59, 60, 65] :
[57, 62, 64, 65] :
[57, 59, 60, 64] :
[]
ctrls =
map (\t -> round (80 + 47 * sin t)) (iterate (0.1+) (0::Double))
events =
zipWith (:)
(map
(\k -> (0, Event.CtrlEv Event.Controller (Event.Ctrl
{Event.ctrlChannel = 0,
Event.ctrlParam = 23,
Event.ctrlValue = k})))
ctrls)
(map
(\k ->
(0, Event.NoteEv Event.NoteOn $ Event.simpleNote 0 k 64) :
(dur, Event.NoteEv Event.NoteOff $ Event.simpleNote 0 k 64) :
[])
notes)
in EventList.cons 0
[(0, Event.CtrlEv Event.PgmChange (Event.Ctrl
{Event.ctrlChannel = 0,
Event.ctrlParam = 0,
Event.ctrlValue = 5}))] $
equidistantEvents dur events
mergeGeneratedAtoms ::
(Time -> a) ->
EventList.T Time a ->
EventList.T Time a ->
EventList.T Time a
mergeGeneratedAtoms trigger gens ins =
Common.mergeStable
(fmap trigger $ EventList.fromPairList $
ListHT.mapAdjacent (,) (0 : EventList.getTimes gens))
(Common.mergeStable gens ins)
patternMono ::
PatternMono i ->
Time ->
EventList.T Time Event.Data ->
EventList.T Time EventDataTrigger
patternMono (Common.PatternMono select ixs) dur ins =
flip State.evalState Map.empty $ Trav.sequenceA $
mergeGeneratedAtoms
(\dt -> return [(dt, Trigger)])
(fmap
(\n -> State.gets (map (mapSnd Regular) . select n dur . Map.toAscList))
(equidistantEvents dur ixs))
(fmap
(\e ->
case e of
Event.NoteEv notePart note -> do
State.modify (updateChord notePart note)
return []
_ -> return $ singletonBundle (Regular e))
ins)
patternMonoTempo ::
PatternMono i ->
((Channel,Controller), (Time,Time,Time)) ->
EventList.T Time Event.Data ->
EventList.T Time EventDataTrigger
patternMonoTempo
(Common.PatternMono select ixs0)
((chan,ctrl), (minDur, defltDur, maxDur)) =
let recourse dur chord ixs =
EventList.switchL EventList.empty $ \(time,me) rest ->
uncurry (EventList.cons time) $
case me of
Nothing ->
case ixs of
[] -> ([], recourse dur chord ixs rest)
i:ir ->
((dur, Trigger) :
map (mapSnd Regular) (select i dur $ Map.toAscList chord),
recourse dur chord ir $
EventList.insertBy (\_ _ -> True) dur Nothing rest)
Just e ->
case e of
Event.NoteEv notePart note ->
([],
recourse dur (updateChord notePart note chord) ixs rest)
Event.CtrlEv Event.Controller param |
Common.controllerMatch chan ctrl param ->
([],
recourse
(updateDur param (minDur,maxDur))
chord ixs rest)
_ -> (singletonBundle (Regular e),
recourse dur chord ixs rest)
in recourse defltDur Map.empty ixs0 .
EventList.insertBy (\_ _ -> True) defltDur Nothing .
fmap Just
patternPolyTempo ::
PatternPoly i ->
((Channel,Controller), (Time,Time,Time)) ->
EventList.T Time Event.Data ->
EventList.T Time EventDataTrigger
patternPolyTempo
(Common.PatternPoly select ixs0)
((chan,ctrl), (minDur, defltDur, maxDur)) =
let recourse dur chord ixs =
EventList.switchL EventList.empty $ \(time,me) rest ->
uncurry (EventList.cons time) $
case me of
Nothing ->
EventList.switchL
([], recourse dur chord ixs rest)
(\(t,is) ir0 ->
let (notes,ir1) =
if t>0
then ([], EventList.cons (t1) is ir0)
else
(do Common.IndexNote d i <- is
evs <-
select i (fromIntegral d * dur) $
Map.toAscList chord
return (mapSnd Regular evs),
ir0)
in ((dur, Trigger) : notes,
recourse dur chord ir1 $
EventList.insertBy (\_ _ -> True) dur Nothing rest))
ixs
Just e ->
case e of
Event.NoteEv notePart note ->
([],
recourse dur (updateChord notePart note chord) ixs rest)
Event.CtrlEv Event.Controller param |
Common.controllerMatch chan ctrl param ->
([],
recourse
(updateDur param (minDur,maxDur))
chord ixs rest)
_ -> (singletonBundle (Regular e),
recourse dur chord ixs rest)
in recourse defltDur Map.empty ixs0 .
EventList.insertBy (\_ _ -> True) defltDur Nothing .
fmap Just
class Pattern pat where
patternTempo ::
pat ->
((Channel,Controller), (Time,Time,Time)) ->
EventList.T Time Event.Data ->
EventList.T Time EventDataTrigger
instance Pattern (PatternMono i) where
patternTempo = patternMonoTempo
instance Pattern (PatternPoly i) where
patternTempo = patternPolyTempo
sweep ::
Channel ->
Time ->
(Controller, (Time,Time)) ->
Controller ->
Controller ->
(Double -> Double) ->
EventList.T Time Event.Data ->
EventList.T Time EventDataTrigger
sweep chan dur (speedCtrl, (minSpeed, maxSpeed)) depthCtrl centerCtrl
wave ins =
flip State.evalState
(Common.SweepState {
sweepSpeed =
realToFrac $ Common.deconsTime $
dur*(minSpeed+maxSpeed)/2,
sweepDepth = 64,
sweepCenter = 64,
sweepPhase = 0
}) $
Trav.sequenceA $
mergeGeneratedAtoms
(\dt -> return [(dt, Trigger)])
(fmap
(\() -> do
ev <-
State.gets (\s ->
Event.CtrlEv Event.Controller $
Event.Ctrl {
Event.ctrlChannel = MALSA.fromChannel chan,
Event.ctrlParam = MALSA.fromController centerCtrl,
Event.ctrlValue =
round $ limit (0,127) $
sweepCenter s + sweepDepth s * wave (sweepPhase s)
})
State.modify (\s ->
s{sweepPhase = Common.fraction (sweepPhase s + sweepSpeed s)})
return $ singletonBundle (Regular ev))
(equidistantEvents dur $ repeat ()))
(fmap
(\e ->
maybe (return $ singletonBundle (Regular e))
(\f -> State.modify f >> return []) $ do
Event.CtrlEv Event.Controller param <- Just e
let c = param ^. MALSA.ctrlChannel
ctrl = param ^. MALSA.ctrlController
x :: Num a => a
x = fromIntegral (Event.ctrlValue param)
guard (c==chan)
lookup ctrl $
(speedCtrl,
\s -> s{sweepSpeed =
realToFrac $ Common.deconsTime $ (dur *) $
minSpeed + (maxSpeedminSpeed) * x/127}) :
(depthCtrl, \s -> s{sweepDepth = x}) :
(centerCtrl, \s -> s{sweepCenter = x}) :
[])
ins)
filter ::
(a -> Bool) ->
State.State
(EventList.T Time (Bundle a))
(EventList.T Time (Bundle a))
filter p = State.state $
EventList.foldrPair
(\t evs ->
let (evsT,evsF) =
List.partition (p . snd) evs
in mapPair
(EventList.cons t evsT,
EventList.cons t evsF))
(EventList.empty, EventList.empty)
filterSimple ::
(a -> Bool) ->
EventList.T Time (Bundle a) ->
EventList.T Time (Bundle a)
filterSimple p =
EventList.foldrPair
(\t evs ->
EventList.cons t (List.filter (p . snd) evs))
EventList.empty
merge ::
EventList.T Time (Bundle a) ->
EventList.T Time (Bundle a) ->
EventList.T Time (Bundle a)
merge x0 y0 =
flip (EventList.switchL y0) x0 $ \(tx,bx) rx ->
flip (EventList.switchL x0) y0 $ \(ty,by) ry ->
let (tz, ~(bz, rz)) =
mapSnd
(\ ~(b,d) ->
if b
then
mapFst (bx++) $
if d == NonNeg.zero
then (by, merge rx ry)
else ([], merge rx (EventList.cons d by ry))
else
(by, merge (EventList.cons d bx rx) ry)) $
NonNeg.split tx ty
in EventList.cons tz bz rz
process ::
(EventList.T Time Event.Data ->
EventList.T Time EventDataTrigger) ->
ReaderT Handle IO ()
process f = do
Common.startQueue
outputTriggerEvents . f =<< inputEvents
processSimple ::
(EventList.T Time Event.Data ->
EventList.T Time EventDataBundle) ->
ReaderT Handle IO ()
processSimple f = do
Common.startQueue
outputEventBundles . f =<< inputEvents
runWhirl :: ReaderT Handle IO ()
runWhirl =
process
(
EventList.cons 0 [(0,Trigger)] .
mergeGenerated whirl .
fmap singletonBundle)
runDelay :: ReaderT Handle IO ()
runDelay =
processSimple (fmap (Common.delayAdd 50 0.3))
runKeyboardSplit :: ReaderT Handle IO ()
runKeyboardSplit =
processSimple $
uncurry merge .
State.runState (do
low <-
filter (\e ->
(checkChannel (ChannelMsg.toChannel 0 ==) e &&
checkPitch (VoiceMsg.toPitch 60 >) e) ||
checkController (VoiceMsg.toController 91 ==) e ||
checkController (VoiceMsg.toController 93 ==) e)
return $
fmap (mapMaybe (\(t,p) -> fmap ((,) t) $ Common.transpose 12 p) .
map (mapSnd (Common.setChannel (ChannelMsg.toChannel 1)))) low) .
fmap singletonBundle
runKeyboardSplitLow :: ReaderT Handle IO ()
runKeyboardSplitLow =
processSimple $
fmap (mapMaybe (\(t,p) -> fmap ((,) t) $ Common.transpose 12 p) .
map (mapSnd (Common.setChannel (ChannelMsg.toChannel 1)))) .
filterSimple (\e ->
(checkChannel (ChannelMsg.toChannel 0 ==) e &&
checkPitch (VoiceMsg.toPitch 60 >) e) ||
checkController (VoiceMsg.toController 91 ==) e ||
checkController (VoiceMsg.toController 93 ==) e) .
fmap singletonBundle
runKeyboardSplitHigh :: ReaderT Handle IO ()
runKeyboardSplitHigh =
processSimple $
filterSimple (\e ->
(checkChannel (ChannelMsg.toChannel 0 ==) e &&
checkPitch (VoiceMsg.toPitch 60 <=) e) ||
checkController (const True) e ||
checkProgram (const True) e) .
fmap singletonBundle
runCyclePrograms :: [Program] -> ReaderT Handle IO ()
runCyclePrograms pgms =
processSimple
(fmap Common.immediateBundle .
flip State.evalState (cycle pgms) .
Trav.traverse (Common.traverseProgramsSeek (length pgms)))
runProgramsAsBanks :: [Int32] -> ReaderT Handle IO ()
runProgramsAsBanks ns =
processSimple
(fmap singletonBundle .
flip State.evalState (Match.replicate ns 0) .
Trav.traverse (Common.programsAsBanks ns))
runPattern ::
Time ->
PatternMono i ->
ReaderT Handle IO ()
runPattern dur pat =
process (patternMono pat dur)
runPatternTempo ::
Pattern pat =>
Time ->
pat ->
ReaderT Handle IO ()
runPatternTempo dur pat =
process
(patternTempo pat
(Common.defaultTempoCtrl, (1.5*dur, dur, 0.5*dur)))
runFilterSweep ::
ReaderT Handle IO ()
runFilterSweep =
process
(sweep (ChannelMsg.toChannel 1)
0.01 (VoiceMsg.toController 72, (0.1, 1))
(VoiceMsg.toController 73) (VoiceMsg.toController 91)
(sin . (2*pi*)))
main :: IO ()
main = (with $ do
liftIO $ putStrLn "Please connect me to a synth"
_ <- liftIO $ getLine
Common.startQueue
liftIO . mapM_ print =<< inputEventsCore
outputEvents =<< inputEvents
outputEventBundles whirl
outputEvents . EventList.mapMaybe (Common.transpose 1) =<< inputEvents)
`Exc.catch` \e ->
putStrLn $ "alsa_exception: " ++ Exc.show e